diff options
| author | andreao <andreao@138bc75d-0d04-0410-961f-82ee72b054a4> | 2009-04-20 15:55:41 +0000 |
|---|---|---|
| committer | andreao <andreao@138bc75d-0d04-0410-961f-82ee72b054a4> | 2009-04-20 15:55:41 +0000 |
| commit | f4f4b17469bc718e4525d8178a55d032167ae6c9 (patch) | |
| tree | edaa0d1f6aaaebef184277735b2f9eee4b8133dc | |
| parent | 7a8f426c0120cf9c92726ce9b5ba73a65cad8147 (diff) | |
merge from trunk revisions 127002-132392, 4/N
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/st/cli-be@146435 138bc75d-0d04-0410-961f-82ee72b054a4
558 files changed, 23615 insertions, 10014 deletions
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 374040d018d..6260ed30b44 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,1280 +1,513 @@ -2007-07-27 Janne Blomqvist <jb@gcc.gnu.org> +2008-02-10 Jerry DeLisle <jvdelisle@gcc.gnu.org> - * io/transfer.c (st_set_nml_var_dim): Use index_type instead of - GFC_INTEGER_4 for array descriptor triplets. + PR libfortran/35063 + * io/unit.c (destroy_unit_mutex): New function that uses + __gthread_mutex_destroy_function or pthread_mutex_destroy after + unlocking and before free_mem for final closure of I/O unit. + (delete_root): Use new function. + (free_internal_unit): Likewise. + (close_unit_1): Likewise. -2007-07-27 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> +2008-02-02 Thomas Koenig <tkoenig@gcc.gnu.org> - * io/unix.c (stream_ttyname): Mark argument as potentialy unused. + PR libfortran/35001 + * m4/shape.m4: Return 0 for extents <= 0. + * generated/shape_i4.c: Regenerated. + * generated/shape_i8.c: Regenerated. + * generated/shape_i16.c: Regenerated. -2007-07-27 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> +2008-01-27 Thomas Koenig <tkoenig@gcc.gnu.org> - PR fortran/32035 - * runtime/select.c (select_string): Adjust prototype and function - so that the return value is an integer, not a pointer. + PR libfortran/34980 + * m4/shape.m4: If return array is empty, return early. + * generated/shape_i4.c: Regenerated. + * generated/shape_i8.c: Regenerated. + * generated/shape_i16.c: Regenerated. -2007-07-24 Tobias Burnus <burnus@net-b.de> +2008-01-26 Thomas Koenig <tkoenig@gcc.gnu.org> - * libgfortran.h: Add bounds_check to compile_options_t. + PR libfofortran/34887 + * io/transfer.c (next_record_w): Always move to the farthest + position when completing the record (also when we are + processing a slash edit descriptor). -2007-07-24 Thomas Koenig <tkoenig@gcc.gnu.org> +2008-01-25 Jerry DeLisle <jvdelisle@gcc.gnu.org> - PR fortran/30814 - * libgfortran.h: Add bounds_check to compile_options_t. - * runtime/compile_options.c (set_options): Add handling - of compile_options.bounds_check. - * intrinsics/pack_generic.c (pack_internal): Also determine - the number of elements if compile_options.bounds_check is - true. Raise runtime error if a different array shape is - detected. - -2007-07-23 Christopher D. Rickett <crickett@lanl.gov> - - PR fortran/32600 - * intrinsics/iso_c_binding.c (c_funloc): Remove. - * intrinsics/iso_c_binding.h: Remove c_funloc. - * gfortran.map: Ditto. - -2007-07-22 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - * io/read.c (convert_real): Generate error only on EINVAL. - -2007-07-21 Christopher D. Rickett <crickett@lanl.gov> - - PR fortran/32627 - * libgfortran/intrinsics/iso_c_generated_procs.c: Add c_f_pointer - for character/string arguments. - * libgfortran/intrinsic/iso_c_binding.c (c_f_pointer_u0): Allow - the optional SHAPE arg to be any valid integer kind. - * libgfortran/gfortran.map: Add c_f_pointer_s0. - * libgfortran/mk-kinds-h.sh: Save smallest integer kind as default - character kind. - * libgfortran/intrinsics/iso_c_generated_procs.c: Add versions of - c_f_pointer for complex and logical types. - * libgfortran/gfortran.map: Add c_f_pointer versions for logical - and complex types. - -2007-07-19 Christopher D. Rickett <crickett@lanl.gov> - - PR fortran/32600 - * libgfortran/intrinsics/iso_c_binding.c: Remove C_LOC. - * libgfortran/intrinsics/iso_c_binding.h: Ditto. - * libgfortran/gfortran.map: Ditto. - -2007-07-15 Jerry DeLisle <jvdelisle@gcc.gnu.org> - Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> - - PR fortran/32611 - * runtime/compile_options.c (set_std): Remove. - (set_options): New function. - (init_compile_options): Add initialization for -fsign-zero option. - * gfortran.map (GFORTRAN_1.0): Rename _gfortran_set_std into - _gfortran_set_options. - * libgfortran.h (compile_options_t): Add sign_zero field. - * io/write.c (output_float): Use the sign bit of the value to determine - if a negative sign should be emitted for zero values. Do not emit the - negative sign for zero if -fno-sign-zero was set during compile. + PR libfortran/34876 + * io/transfer.c (write_buf): Handle case of zero sized array. + (transfer_array): Set data pointer to NULL and size to zero. Then + make a data transfer and return. -2007-07-14 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libgfortran/32752 - * io/unix.c (unix_stream): Move buffer pointer adjacent to small_buffer. - * io/transfer.c (formatted_transfer_scalar): If stream I/O, set - bytes_used to zero. Fix off by one error in calculation of pos and - skips. Eliminate duplicate pending_spaces check. - -2007-07-15 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> - - PR fortran/32357 - * intrinsics/mvbits.c: Change prototype so that FROMPOS, LEN and - TOPOS arguments are C int. - -2007-07-09 Jerry DeLisle <jvdelisle@gcc.gnu.org> +2008-01-24 David Edelsohn <edelsohn@gnu.org> - PR libgfortran/32702 - * io/unix.c (unix_stream): Restore buffer pointer and small_buffer. - (fd_alloc): If the number of bytes needed is greater than the default - BUFFER_SIZE, allocate a new buffer large enough. Free the old buffer if - necessary. (fd_sfree): Restore use of buffer pointer. - (fd_close): Likewise. (fd_open): Likewise. - (init_error_stream): Likewise. - -2007-07-09 Thomas Koenig <tkoenig@gcc.gnu.org> - - PR libfortran/32336 - * m4/matmul.m4: When the dimension of b is incorrect, - raise a runtime error instead of a failed assertion. - * generated/matmul_i1.c: Regenerated. - * generated/matmul_i2.c: Regenerated. - * generated/matmul_i4.c: Regenerated. - * generated/matmul_i8.c: Regenerated. - * generated/matmul_i16.c: Regenerated. - * generated/matmul_r4.c: Regenerated. - * generated/matmul_r8.c: Regenerated. - * generated/matmul_r10.c: Regenerated. - * generated/matmul_r16.c: Regenerated. - -2007-07-08 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libgfortran/32678 - * io/transfer.c (formatted_transfer_scalar): Don't allow pending_spaces - to go negative. - -2007-07-08 Thomas Koenig <tkoenig@gcc.gnu.org> - - PR libfortran/32217 - * intrinsics/unpack_generic.c: If the destination array is - empty, return early. - -2007-07-05 H.J. Lu <hongjiu.lu@intel.com> - - * aclocal.m4: Regenerated. - -2007-07-04 David Edelsohn <edelsohn@gnu.org> - - * configure.ac: SUBST CFLAGS. * configure: Regenerate. -2007-07-03 Janne Blomqvist <jb@gcc.gnu.org> - - * libgfortran.h: Mark internal_malloc_size as a malloc function. - * runtime/memory.c (internal_realloc_size): Remove. - (internal_realloc): Call realloc directly instead of - internal_realloc_size. - (allocate_size): Remove. - (allocate): Call malloc directly instead of allocate_size, mark as - malloc function. - -2007-07-02 Steven G. Kargl <kargl@gcc.gnu.org> - - Restore collateral damage from ISO C Binding merge. - -2007-06-29 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libgfortran/32456 - * io/unit.c (filename_from_unit): Don't use find_unit, instead search - for unit directly. - -2007-07-02 Steven G. Kargl <kargl@gcc.gnu.org> - - * Makefile.in: Regenerated with automake 1.9.6. - -2007-07-02 Steven G. Kargl <kargl@gcc.gnu.org> - - * Makefile.in: Remove extraneous kill.lo rule. - -2007-07-02 Janne Blomqvist <jb@gcc.gnu.org> - - PR fortran/32239 - * generated/pow_r*_i4.c: Removed. - -2007-07-01 Christopher D. Rickett <crickett@lanl.gov> - - * Makefile.in: Add support for iso_c_generated_procs.c and - iso_c_binding.c. - * Makefile.am: Ditto. - * intrinsics/iso_c_generated_procs.c: New file containing helper - functions. - * intrinsics/iso_c_binding.c: Ditto. - * intrinsics/iso_c_binding.h: New file - * gfortran.map: Include the __iso_c_binding_c_* functions. - * libgfortran.h: define GFC_NUM_RANK_BITS. - -2007-07-01 Janne Blomqvist <jb@gcc.gnu.org> - - PR fortran/32239 - * Makefile.am: Don't generate real**int4 pow functions. - * gfortran.map: Remove real**int4 pow symbols. - * Makefile.in: Regenerated. - -2007-07-01 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libgfortran/32554 - * io/write.c (output_float): Set edigits to a fixed size, avoiding - variation in field width calculation and eliminate buffer overrun. - -2007-07-01 Janne Blomqvist <jb@gcc.gnu.org> - - * runtime/memory.c (internal_realloc): Use index_type for size - argument instead of GFC_INTEGER_4. - (allocate_array): Likewise. - (allocate): Likewise, add ifdef around unnecessary check. - (internal_reallo64): Remove. - (allocate_array64): Remove. - (allocate64): Remove. - * gfortran.map: Remove symbols for 64-bit allocation functions. - -2007-06-29 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libgfortran/32456 - * io/unit.c (filename_from_unit): Don't use find_unit, instead search - for unit directly. - -2007-06-24 Adam Nemet <anemet@caviumnetworks.com> - - PR libfortran/32495 - * runtime/backtrace.c (local_strcasestr): Rename from strcasestr. - (show_backtrace): Rename strcasestr to local_strcasestr. - -2007-06-24 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libgfortran/32456 - * runtime/error.c (show_locus): Update to emit the unit number - and file name involved with the error. Use new function - filename_from_unit. - * libgfortran.h (filename_from_unit): Declare new function. - * io/unit.c (init_units): Set the unit file name for stdin, stdout, - and stderr for use later in error reporting. - (filename_from_unit): Add this new function. - -2007-06-24 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libgfortran/32446 - * io/write.c (output_float): Calculate ndigits correctly for large - numbered formats that must pad zeros before the decimal point. - -2007-06-15 Rainer Orth <ro@TechFak.Uni-Bielefeld.DE> - - PR libfortran/32345 - * runtime/backtrace.c (show_backtrace): Only use snprintf if - available. - -2007-06-10 Jerry DeLisle <jvdelisle@gcc.gnu.org> +2008-01-19 Jerry DeLisle <jvdelisle@gcc.gnu.org> - PR libgfortran/32235 - * io/transfer.c (st_read): Remove test for end of file condition. - (next_record_r): Add test for end of file condition. - -2007-06-02 Paolo Bonzini <bonzini@gnu.org> - - * configure: Regenerate. - -2007-05-28 Tobias Burnus <burnus@net-b.de> - - PR fortran/32124 - * runtime/memory.c (allocate_size): Use ERROR_ALLOCATION. - (allocate,allocate64): Use stat variable if present. - -2007-05-27 Janne Blomqvist <jb@gcc.gnu.org> - - * runtime/string.c (compare0): Use gfc_charlen_type instead of - int. - (fstrlen): Likewise. - (find_option): Likewise. - (fstrcpy): Use gfc_charlen_type instead of int, return length. - (cf_strcpy): Likewise. - * libgfortran.h: Change string prototypes to use gfc_charlen_type. - * io/open.c (new_unit): Use snprintf if available. - * io/list_read.c (nml_touch_nodes): Use memcpy instead of - strcpy/strcat. - (nml_read_obj): Likewise. - * io/transfer.c (st_set_nml_var): Likewise. - * io/write.c (output_float): Use snprintf if available. - (nml_write_obj) Use memcpy instead of strcpy/strcat. - -2007-05-26 Janne Blomqvist <jb@gcc.gnu.org> - - * io/unix.c (unix_stream): Rearrange struct members, remove - small_buffer. - (int_stream): New struct. - (fd_alloc): Always use existing buffer, never reallocate. - (fd_sfree): Remove check for buffer != small_buffer. - (fd_close): Likewise. - (mem_alloc_r_at): Change to use int_stream. - (mem_alloc_w_at): Likewise. - (mem_read): Likewise. - (mem_write): Likewise. - (mem_set): Likewise. - (mem_truncate): Likewise. - (mem_close): Likewise. - (mem_sfree): Likewise. - (empty_internal_buffer): Likewise. - (open_internal): Likewise. + PR libfortran/34795 + * io/inquire.c (inquire_via_unit): If a unit is opened, return values + according to the open action for DIRECT, FORMATTED, and UNFORMATTED. + (inquire_via_filename): Return "UNKNOWN" for SEQUENTIAL, DIRECT, + FORAMATTED, and UNFORMATTED inquiries. + * io/unix.c (inquire_sequential): Return "UNKNOWN" when appropriate + for files that are not opened. (inquire_direct): Same. + (inquire_formatted): Same. -2007-05-25 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - * io/transfer.c (unformatted_read): Use size from front end eliminating - use of size_from_real_kind. (unformatted_write): Ditto. - -2007-05-23 Steve Ellcey <sje@cup.hp.com> - - * Makefile.in: Regenerate. - * configure: Regenerate. - * aclocal.m4: Regenerate. - -2007-05-22 Tobias Burnus <burnus@net-b.de> - - * libgfortran.h: Mark stop_numeric as noreturn. - -2007-05-22 Tobias Burnus <burnus@net-b.de> - - PR libgfortran/31295 - * intrinsics/eoshift0.c (eoshift0): Silence uninitialized warning. - * intrinsics/eoshift2.c (eoshift2): Ditto. - -2007-05-18 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/31964 - * intrinsics/ishftc.c (ishftc4, ishftc8, ishftc16): Fix mask to handle - shift of bit-size number of bits. - -2007-05-17 Tobias Burnus <burnus@net-b.de> - - PR fortran/31917 - * runtime/environ.c (mark_range): Fix setting default convert unit. - -2007-05-15 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/31922 - * intrinsics/string_intrinsics.c (string_trim): Set result to null if - string length is zero. - -2007-05-15 Tobias Burnus <burnus@net-b.de> - - PR libfortran/31915 - * io/transfer.c (unformatted_read): Use proper size for real(10). - (unformatted_write): Ditto. - -2007-05-14 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> - - PR fortran/30723 - * runtime/memory.c (internal_malloc, internal_malloc64, - internal_free): Remove. - * runtime/error.c (os_error): Export function. - * intrinsics/move_alloc.c: Include stdlib.h. - (move_alloc): Call free instead of internal_free. - (move_alloc_c): Wrap long lines. - * libgfortran.h (os_error): Export prototype. - (internal_free): Remove prototype. - * gfortran.map (GFORTRAN_1.0): Remove _gfortran_internal_free, - _gfortran_internal_malloc and _gfortran_internal_malloc64. - Add _gfortran_os_error. - -2007-05-09 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/31880 - * io/unix.c (fd_alloc_r_at): Fix calculation of physical offset. - -2007-05-07 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> - - PR libfortran/31607 - * intrinsics/system.c (system_sub): Call flush_all_units. - * io/io.h (flush_all_units): Move prototype to libgfortran.h. - * libgfortran.h (flush_all_units): Add prototype. - -2007-05-06 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/31201 - * runtime/error.c (runtime_error_at): New function. - (generate_error): Export this function. - * gfortran.map: Add _gfortran_generate_error and - _gfortran_runtime_error_at. - * libgfortran.h: Add comment to reference error codes in front end. - (library_start): Locate prototype with library_end macro and add - a new comment. Add prototype for runtime_error_at. Export prototype for - generate_error. - * io/lock.c (library_start): Fix check for error condition. - * io/transfer.c (data_transfer_init): Add library check. - -2007-05-04 Daniel Franke <franke.daniel@gmail.com> - - PR fortran/22359 - * io/intrinsics.c (fseek_sub): New. - * io/unix.c (fd_fseek): Change logical and physical offsets only - if seek succeeds. - * gfortran.map (fseek_sub): New. - -2007-05-04 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> - - PR libfortran/31210 - * io/transfer.c (transfer_character): Avoid passing a NULL - pointer as source to the transfer routines, if the string length - is zero. - -2007-04-28 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/31501 - * io/list_read.c (next_char): Fix whitespace. - * io/io.h: Remove prototypes and define macros for is_array_io, - is_stream_io, and is_internal_unit. - * io/unit.c (is_array_io), (is_internal_unit), (is_stream_io): Delete - these functions. - * io/transfer.c (read_sf): Change handling of internal_unit to make a - single call to salloc_r and use memcpy to transfer the data. - -2007-04-27 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/31532 - * io/file_pos.c (st_backspace): Set flags.position for end of file - condition and use new function update_position. - (st_endfile): Use new function update_position. - * io/io.h: Add prototype for new function. - * io/inquire.c (inquire_via_unit): If not direct access, set NEXTREC - to zero. - * io/unit.c (update_position): New function to update position info - used by inquire. - * io/transfer.c (next_record): Fix typo and use new function. - -2007-04-25 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> - - PR libfortran/31299 - * intrinsics/getlog.c: Use getpwuid and geteuid instead of - getlogin if they are available. - * configure.ac: Add checks for getpwuid and geteuid. - * configure: Regenerate. - * config.h.in: Regenerate. - -2007-04-25 Janne Blomqvist <jb@gcc.gnu.org> - - * configure: Regenerate using autoconf 2.59. - * Makefile.in: Likewise. - * config.h.in: Likewise. - -2007-04-24 Janne Blomqvist <jb@gcc.gnu.org> - - PR libfortran/27740 - * configure.ac: New test to determine if symbol versioning is - supported. - * Makefile.am: Use result of above test to add appropriate linker - flags. - * gfortran.map: New file. - * configure: Regenerated. - * Makefile.in: Regenerated. - * config.h.in: Regenerated. - -2007-04-23 Thomas Koenig <tkoenig@gcc.gnu.org> - - PR fortran/31618 - * io/transfer.c (read_block_direct): Instead of calling us_read, - set dtp->u.p.current_unit->current_record = 0 so that pre_position - will read the record marker. - (data_transfer_init): For different error conditions, call - generate_error, then return. - -2007-04-19 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> - - * runtime/main.c (please_free_exe_path_when_done): New variable. - (store_exe_path): Initialize character buffer, and mark whether - exe_path should be free'd by the library destructor function. - (cleanup): Only free exe_path if needed. - -2007-04-18 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> - Tobias Burnus <burnus@net-b.de> - - PR libfortran/31286 - PR libfortran/31296 - * intrinsics/cshift0.c (cshift0): Initialize sstride[0] and rstride[0]. - * intrinsics/unpack_generic.c (unpack0, unpack0_char): Zero the - array structures we pass to unpack_internal. - -2007-04-14 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - * io/open.c (test_endfile): Revert changes for 31052, restoring this - function. - -2007-04-14 Steve Ellcey <sje@cup.hp.com> - - * Makefile.am: Add -I .. to ACLOCAL_AMFLAGS. Add libgfortran_la_LINK. - * Makefile.in: Regenerate. - -2007-04-11 Kai Tietz <kai.tietz@onevision.com> - - * configure: Regenerate. - -2007-04-06 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> - - * intrinsics/cpu_time.c: Don't include headers already included - by libgfortran.h. Protect inclusion of sys/times.h. - * configure.ac: Remove unneeded checks for finit, stdio.h, - stddef.h, math.h and sys/params.h. - * config/fpu-aix.h: Don't include headers already included by - libgfortran.h. - * config/fpu-sysv.h: Likewise. - * io/write.c: Likewise. - * m4/minloc1.m4: Likewise. - * m4/maxloc1.m4: Likewise. - * m4/fraction.m4: Likewise. - * m4/set_exponent.m4: Likewise. - * m4/spacing.m4: Likewise. - * m4/minval.m4: Likewise. - * m4/maxval.m4: Likewise. - * m4/exponent.m4: Likewise. - * m4/nearest.m4: Likewise. - * m4/minloc0.m4: Likewise. - * m4/maxloc0.m4: Likewise. - * m4/rrspacing.m4: Likewise. - * runtime/main.c: Likewise. - * runtime/error.c: Likewise. - * intrinsics/system_clock.c: Likewise. - * intrinsics/etime.c: Likewise. - * intrinsics/stat.c: Likewise. - * intrinsics/date_and_time.c: Likewise. - * intrinsics/env.c: Likewise. - * intrinsics/kill.c: Likewise. - * intrinsics/getXid.c: Likewise. - * intrinsics/chmod.c: Likewise. - * intrinsics/args.c: Likewise. - * intrinsics/c99_functions.c: Likewise. - * generated/minval_r8.c: Regenerate. - * generated/maxloc1_4_r8.c: Regenerate. - * generated/minloc1_16_r16.c: Regenerate. - * generated/maxval_i2.c: Regenerate. - * generated/maxloc1_8_i4.c: Regenerate. - * generated/exponent_r16.c: Regenerate. - * generated/maxloc0_4_r4.c: Regenerate. - * generated/fraction_r16.c: Regenerate. - * generated/fraction_r4.c: Regenerate. - * generated/minloc0_4_r16.c: Regenerate. - * generated/minloc0_4_i1.c: Regenerate. - * generated/maxloc0_4_r16.c: Regenerate. - * generated/maxloc0_4_i2.c: Regenerate. - * generated/minloc1_8_r16.c: Regenerate. - * generated/maxloc1_8_r16.c: Regenerate. - * generated/set_exponent_r8.c: Regenerate. - * generated/maxloc0_8_i8.c: Regenerate. - * generated/minloc1_4_r8.c: Regenerate. - * generated/maxloc1_16_r16.c: Regenerate. - * generated/minloc1_16_i4.c: Regenerate. - * generated/maxloc1_16_i4.c: Regenerate. - * generated/minloc0_16_i8.c: Regenerate. - * generated/maxloc0_16_i8.c: Regenerate. - * generated/nearest_r8.c: Regenerate. - * generated/spacing_r16.c: Regenerate. - * generated/maxval_r16.c: Regenerate. - * generated/minloc1_8_i4.c: Regenerate. - * generated/minloc0_16_i16.c: Regenerate. - * generated/minloc0_4_r4.c: Regenerate. - * generated/set_exponent_r10.c: Regenerate. - * generated/rrspacing_r10.c: Regenerate. - * generated/minloc0_4_i2.c: Regenerate. - * generated/maxloc0_8_i1.c: Regenerate. - * generated/minloc0_8_i8.c: Regenerate. - * generated/spacing_r4.c: Regenerate. - * generated/minloc1_16_r10.c: Regenerate. - * generated/minloc0_16_i1.c: Regenerate. - * generated/maxloc0_16_i1.c: Regenerate. - * generated/maxloc1_8_r8.c: Regenerate. - * generated/minval_i16.c: Regenerate. - * generated/exponent_r10.c: Regenerate. - * generated/maxval_i4.c: Regenerate. - * generated/minval_i8.c: Regenerate. - * generated/maxloc1_4_i8.c: Regenerate. - * generated/fraction_r10.c: Regenerate. - * generated/maxloc0_16_i16.c: Regenerate. - * generated/maxloc0_8_r4.c: Regenerate. - * generated/rrspacing_r8.c: Regenerate. - * generated/minloc1_4_i16.c: Regenerate. - * generated/minloc0_4_r10.c: Regenerate. - * generated/maxloc1_4_i16.c: Regenerate. - * generated/minloc0_8_i16.c: Regenerate. - * generated/maxloc0_4_r10.c: Regenerate. - * generated/maxloc0_8_i16.c: Regenerate. - * generated/minloc1_8_r10.c: Regenerate. - * generated/minloc0_16_r4.c: Regenerate. - * generated/maxloc1_8_r10.c: Regenerate. - * generated/maxloc0_16_r4.c: Regenerate. - * generated/minloc1_16_r8.c: Regenerate. - * generated/minloc0_8_i1.c: Regenerate. - * generated/maxloc0_4_i4.c: Regenerate. - * generated/maxloc1_16_r8.c: Regenerate. - * generated/maxloc0_8_i2.c: Regenerate. - * generated/nearest_r16.c: Regenerate. - * generated/maxloc1_16_r10.c: Regenerate. - * generated/minloc0_16_i2.c: Regenerate. - * generated/minloc1_8_r8.c: Regenerate. - * generated/maxloc0_16_i2.c: Regenerate. - * generated/exponent_r4.c: Regenerate. - * generated/spacing_r10.c: Regenerate. - * generated/maxval_r10.c: Regenerate. - * generated/minval_i1.c: Regenerate. - * generated/maxloc1_4_i1.c: Regenerate. - * generated/minloc1_4_i8.c: Regenerate. - * generated/minloc0_8_r4.c: Regenerate. - * generated/minloc0_16_r16.c: Regenerate. - * generated/minloc0_4_i4.c: Regenerate. - * generated/minloc0_8_i2.c: Regenerate. - * generated/minval_r4.c: Regenerate. - * generated/maxloc1_4_r4.c: Regenerate. - * generated/maxval_r8.c: Regenerate. - * generated/minval_r16.c: Regenerate. - * generated/minloc1_4_i1.c: Regenerate. - * generated/minval_i2.c: Regenerate. - * generated/maxloc1_4_i2.c: Regenerate. - * generated/maxloc1_8_i8.c: Regenerate. - * generated/maxloc0_4_r8.c: Regenerate. - * generated/maxloc0_16_r16.c: Regenerate. - * generated/minloc1_4_r16.c: Regenerate. - * generated/fraction_r8.c: Regenerate. - * generated/maxloc1_4_r16.c: Regenerate. - * generated/set_exponent_r4.c: Regenerate. - * generated/minloc0_8_r16.c: Regenerate. - * generated/maxloc0_8_r16.c: Regenerate. - * generated/nearest_r10.c: Regenerate. - * generated/maxloc0_8_i4.c: Regenerate. - * generated/minloc1_4_r4.c: Regenerate. - * generated/minloc0_16_i4.c: Regenerate. - * generated/maxloc0_16_i4.c: Regenerate. - * generated/nearest_r4.c: Regenerate. - * generated/minloc1_16_i8.c: Regenerate. - * generated/maxloc1_16_i8.c: Regenerate. - * generated/minloc1_4_i2.c: Regenerate. - * generated/maxloc1_8_i1.c: Regenerate. - * generated/minloc0_16_r10.c: Regenerate. - * generated/minloc1_8_i8.c: Regenerate. - * generated/minloc0_4_r8.c: Regenerate. - * generated/minloc0_8_i4.c: Regenerate. - * generated/minloc1_16_i16.c: Regenerate. - * generated/spacing_r8.c: Regenerate. - * generated/maxloc1_8_r4.c: Regenerate. - * generated/minloc1_16_i1.c: Regenerate. - * generated/maxloc1_16_i1.c: Regenerate. - * generated/minval_r10.c: Regenerate. - * generated/minval_i4.c: Regenerate. - * generated/minloc1_8_i1.c: Regenerate. - * generated/maxloc1_4_i4.c: Regenerate. - * generated/maxloc1_8_i2.c: Regenerate. - * generated/maxval_i8.c: Regenerate. - * generated/maxloc0_16_r10.c: Regenerate. - * generated/rrspacing_r4.c: Regenerate. - * generated/minloc0_4_i16.c: Regenerate. - * generated/maxloc0_8_r8.c: Regenerate. - * generated/maxloc0_4_i16.c: Regenerate. - * generated/minloc1_4_r10.c: Regenerate. - * generated/minloc1_8_i16.c: Regenerate. - * generated/maxloc1_4_r10.c: Regenerate. - * generated/minloc0_8_r10.c: Regenerate. - * generated/maxloc1_8_i16.c: Regenerate. - * generated/maxloc0_8_r10.c: Regenerate. - * generated/minloc1_16_r4.c: Regenerate. - * generated/maxloc1_16_r4.c: Regenerate. - * generated/minloc0_16_r8.c: Regenerate. - * generated/maxloc0_16_r8.c: Regenerate. - * generated/maxloc0_4_i8.c: Regenerate. - * generated/maxloc1_16_i16.c: Regenerate. - * generated/minloc1_8_r4.c: Regenerate. - * generated/minloc1_16_i2.c: Regenerate. - * generated/maxloc1_16_i2.c: Regenerate. - * generated/maxval_i16.c: Regenerate. - * generated/exponent_r8.c: Regenerate. - * generated/minloc1_4_i4.c: Regenerate. - * generated/maxval_i1.c: Regenerate. - * generated/minloc1_8_i2.c: Regenerate. - * generated/minloc0_8_r8.c: Regenerate. - * generated/set_exponent_r16.c: Regenerate. - * generated/maxloc0_4_i1.c: Regenerate. - * generated/rrspacing_r16.c: Regenerate. - * generated/minloc0_4_i8.c: Regenerate. - * generated/maxval_r4.c: Regenerate. - * configure: Regenerate. - * config.h.in: Regenerate. - -2007-04-06 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/31395 - * io/format.c (parse_format_list): Fix parsing. - -2007-04-03 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> - - PR fortran/31304 - intrinsics/string_intrinsics.c (string_repeat): Remove. - -2007-04-01 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/31052 - * io/open.c (test_endfile): Delete this function. - (edit_modes): Delete call to test_endfile. - (new_unit): Likewise. - * io/io.h: Delete prototype for test_endfile. - * io/transfer.c (next_record_r): Remove use of test_endfile. - (st_read): Add test for end file condition and adjust status. - -2007-04-01 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/31366 - * io/transfer.c (read_block_direct): Do not generate error when reading - past EOF on a short record that is less than the RECL= specified. - -2007-04-01 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/31207 - * io/unit.c (close_unit_1): If there are bytes previously written from - ADVANCE="no", move to the end before closing. - -2007-03-31 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> - - PR libfortran/31335 - * intrinsics/stat.c: Only provide STAT and FSTAT library routines - if stat() and fstat() library functions are available. When lstat() - is not available, use stat() instead. - * configure.ac: Add checks for stat, fstat and lstat. - * configure: Regenerate. - * config.h.in: Regenerate. - -2007-03-27 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/31052 - * io/transfer.c (next_record_r): Do not call test_endfile if in namelist - mode. - -2007-03-25 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/31199 - * io/io.h: Add saved_pos to gfc_unit structure. - * io/open.c (new_unit): Initialize saved_pos. - * io/transfer.c (data_transfer_init): Set max_pos to value in saved_pos. - (next_record_w): Fix whitespace. - (finalze_transfer): Calculate max_pos for ADVANCE="no" and save it for - later use. If not ADVANCE="no" set saved_pos to zero. - -2007-03-25 Thomas Koenig <tkoenig@gcc.gnu.org> - - PR libfortran/31196 - * intrinsics/reshape_generic.c (reshape_internal): Increment - correct variable. - -2007-03-22 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/31052 - * file_pos.c: Update Copyright year. - * io/open.c (test_endfile): Restore test_endfile to fix SPEC regression. - Update Copyright year. - * io/io.h: Same. - * io/unix.c (is_special): Add missing type for this function. - Update Copyright year. - * io/transfer.c (next_record_r): Restore test_endfile. - (st_read): Fix whitespace. Update Copyright year - -2007-03-20 Francois-Xavier Coudert <coudert@clipper.ens.fr> - - * configure.ac: Add missing check for gettimeofday. - * config.h.in: Renegerate. - * configure: Regenerate. - -2007-03-18 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/31052 - * io/file_position (st_rewind): Fix comments. Remove use of - test_endfile. Don't seek if already at 0 position. Use new is_special - function to set endfile state. - * io/open.c (test_endfile): Delete this function. - * io/io.h: Delete prototype for test_endfile. Add prototype - for is_special. - * io/unix.c (is_special): New function. Fix whitespace. - * io/transfer.c (next_record_r): Remove use of test_endfile. - -2007-03-16 David Edelsohn <edelsohn@gnu.org> - - * runtime/main.c: Include "config.h" first. - -2007-03-15 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/31099 - * io/file_pos.c (st_rewind): Don't set bytes_left to zero. - -2007-03-15 Francois-Xavier Coudert <coudert@clipper.ens.fr> - - * runtime/backtrace.c: New file. - * runtime/environ.c (variable_table): New GFORTRAN_ERROR_BACKTRACE - environment variable. - * runtime/compile_options.c (set_std): Add new argument. - * runtime/main.c (store_exe_path, full_exe_path): New functions. - * runtime/error.c (sys_exit): Add call to show_backtrace. - * libgfortran.h (options_t): New backtrace field. - (store_exe_path, full_exe_path, show_backtrace): New prototypes. - * configure.ac: Add checks for execinfo.h, execvp, pipe, dup2, - close, fdopen, strcasestr, getrlimit, backtrace, backtrace_symbols - and getppid. - * Makefile.am: Add runtime/backtrace.c. - * fmain.c (main): Add call to store_exe_path. - * Makefile.in: Renegerate. - * config.h.in: Renegerate. - * configure: Regenerate. - -2007-03-14 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/31051 - * io/transfer.c (formatted_transfer_scalar): Adjust position for pending - spaces when in writing mode. Clean up some formatting. - -2007-03-14 Thomas Koenig <Thomas.Koenig@online.de> - - PR libfortran/30690 - * all.m4: Quote everything, except for m4 macros. - * any.m4: Likewise. - * count.m4: Likewise. - * cshift1.m4: Likewise. - * eoshift1.m4: Likewise. - * eoshift3.m4: Likewise. - * exponent.m4: Likewise. - * fraction.m4: Likewise. - * in_pack.m4: Likewise. - * in_unpack.m4: Likewise. - * matmul.m4: Likewise. - * matmull.m4: Likewise. - * nearest.m4: Likewise. - * pow.m4: Likewise. - * product.m4: Likewise. - * reshape.m4: Likewise. - * rrspacing.m4: Likewise. - * set_exponent.m4: Likewise. - * shape.m4: Likewise. - * spacing.m4: Likewise. - * transpose.m4: Likewise. - -2007-03-14 Jakub Jelinek <jakub@redhat.com> - - * io/unix.c (regular_file): For ACTION_UNSPECIFIED retry with - O_RDONLY even if errno is EROFS. - -2007-03-09 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/31099 - * io/open.c (new_unit): Initialize bytes_left and recl_subrecord. - * io/transfer.c (next_record_w): Set bytes left to record length for - sequential unformatted I/O. - (next_record_r): Ditto. - (read_block_direct): Fix test for exceeding bytes_left. - -2007-03-08 Daniel Franke <franke.daniel@gmail.com> - - PR fortran/30947 - * intrinsics/signal.c (alarm_sub_int): Avoid SEGFAULT with - integer arguments. - -2007-03-04 Thomas Koenig <Thomas.Koenig@online.de> - - PR libfortran/30981 - * m4/pow_m4: Use appropriate unsigned int type for u. - * generated/pow_c10_i16.c: Regenerated. - * generated/pow_c10_i4.c: Regenerated. - * generated/pow_c10_i8.c: Regenerated. - * generated/pow_c16_i16.c: Regenerated. - * generated/pow_c16_i4.c: Regenerated. - * generated/pow_c16_i8.c: Regenerated. - * generated/pow_c4_i16.c: Regenerated. - * generated/pow_c4_i4.c: Regenerated. - * generated/pow_c4_i8.c: Regenerated. - * generated/pow_c8_i16.c: Regenerated. - * generated/pow_c8_i4.c: Regenerated. - * generated/pow_c8_i8.c: Regenerated. - * generated/pow_i16_i16.c: Regenerated. - * generated/pow_i16_i4.c: Regenerated. - * generated/pow_i16_i8.c: Regenerated. - * generated/pow_i4_i16.c: Regenerated. - * generated/pow_i4_i4.c: Regenerated. - * generated/pow_i4_i8.c: Regenerated. - * generated/pow_i8_i16.c: Regenerated. - * generated/pow_i8_i4.c: Regenerated. - * generated/pow_i8_i8.c: Regenerated. - * generated/pow_r10_i16.c: Regenerated. - * generated/pow_r10_i4.c: Regenerated. - * generated/pow_r10_i8.c: Regenerated. - * generated/pow_r16_i16.c: Regenerated. - * generated/pow_r16_i4.c: Regenerated. - * generated/pow_r16_i8.c: Regenerated. - * generated/pow_r4_i16.c: Regenerated. - * generated/pow_r4_i4.c: Regenerated. - * generated/pow_r4_i8.c: Regenerated. - * generated/pow_r8_i16.c: Regenerated. - * generated/pow_r8_i4.c: Regenerated. - * generated/pow_r8_i8.c: Regenerated. - -2007-03-03 Francois-Xavier Coudert <coudert@clipper.ens.fr> - - PR libfortran/31001 - * intrinsics/pack_generic.c (pack_internal): Add special checks - for zero-sized arrays. - -2007-03-01 Brooks Moses <brooks.moses@codesourcery.com> - - * Makefile.am: Add dummy install-pdf target. - * Makefile.in: Regenerate - -2007-02-24 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/30918 - * io/listread.c (namelist_read): Eat comment line. - -2007-02-22 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/30910 - * io/write.c (output_float): Add condition of format F only for - special case rounding with zero precision. - -2007-02-19 Thomas Koenig <Thomas.Koenig@online.de> - - PR libfortran/30533 - PR libfortran/30765 - * Makefile.am: Add $(srcdir) too all files in generated/. - (i_maxloc0_c): Add maxloc0_4_i1.c, maxloc0_8_i1.c, - maxloc0_16_i1.c, maxloc0_4_i2.c, maxloc0_8_i2.c and - maxloc0_16_i2.c. - (i_maxloc1_c): Add maxloc1_4_i1.c, maxloc1_8_i1.c, - maxloc1_16_i1.c, maxloc1_4_i2.c, maxloc1_8_i2.c and - maxloc1_16_i2.c. - (i_maxval_c): Add maxval_i1.c and maxval_i2.c. - (i_minloc0_c): Add minloc0_4_i1.c, minloc0_8_i1.c, - minloc0_16_i1.c, minloc0_4_i2.c, minloc0_8_i2.c and - minloc0_16_i2.c. - (i_minloc_1.c): Add minloc1_4_i1.c, minloc1_8_i1.c, - minloc1_16_i1.c, minloc1_4_i2.c, minloc1_8_i2.c and - minloc1_16_i2.c. - (i_minval_c): Add minval_i1.c and minval_i2.c. - (i_sum_c): Add sum_i1.c and sum_i2.c. - (i_product_c): Add product_i1.c and product_i2.c. - (i_matmul_c): Add matmul_i1.c and matmul_i2.c. - (gfor_built_specific_src): Remove $(srcdir) from target. - (gfor_bulit_specific2_src): Likewise. - Makefile.in: Regenerated. - libgfortran.h: Add GFC_INTEGER_1_HUGE and GFC_INTEGER_2_HUGE. - Add gfc_array_i1 and gfc_array_i2. - * generated/matmul_i1.c: New file. - * generated/matmul_i2.c: New file. - * generated/maxloc0_16_i1.c: New file. - * generated/maxloc0_16_i2.c: New file. - * generated/maxloc0_4_i1.c: New file. - * generated/maxloc0_4_i2.c: New file. - * generated/maxloc0_8_i1.c: New file. - * generated/maxloc0_8_i2.c: New file. - * generated/maxloc1_16_i1.c: New file. - * generated/maxloc1_16_i2.c: New file. - * generated/maxloc1_4_i1.c: New file. - * generated/maxloc1_4_i2.c: New file. - * generated/maxloc1_8_i1.c: New file. - * generated/maxloc1_8_i2.c: New file. - * generated/maxval_i1.c: New file. - * generated/maxval_i2.c: New file. - * generated/minloc0_16_i1.c: New file. - * generated/minloc0_16_i2.c: New file. - * generated/minloc0_4_i1.c: New file. - * generated/minloc0_4_i2.c: New file. - * generated/minloc0_8_i1.c: New file. - * generated/minloc0_8_i2.c: New file. - * generated/minloc1_16_i1.c: New file. - * generated/minloc1_16_i2.c: New file. - * generated/minloc1_4_i1.c: New file. - * generated/minloc1_4_i2.c: New file. - * generated/minloc1_8_i1.c: New file. - * generated/minloc1_8_i2.c: New file. - * generated/minval_i1.c: New file. - * generated/minval_i2.c: New file. - * generated/product_i1.c: New file. - * generated/product_i2.c: New file. - * generated/sum_i1.c: New file. - * generated/sum_i2.c: New file. - -2007-02-16 Francois-Xavier Coudert <coudert@clipper.ens.fr> - - * runtime/memory.c (deallocate): Correct comment. - -2007-02-10 Thomas Koenig <Thomas.Koenig@online.de> - - * Makefile.am: Use $(M4) instead of m4. - * Makefile.in: Regenerate. - -2007-02-10 Thomas Koenig <Thomas.Koenig@online.de> - - * Makefile.am: Remove $(srcdir) from assorted targets - in maintainer mode. - * Makefile.in: Regenerate. - -2007-02-09 Thomas Koenig <Thomas.Koenig@online.de> - Tobias Burnus <burnus@net-b.de> - - PR fortran/30512 - * m4/iparm.m4: Use HUGE-1 for most negative integer. - * generated/maxloc1_8_i4.c: Regenerate. - * generated/maxloc0_8_i8.c: Regenerate. - * generated/maxloc1_16_i4.c: Regenerate. - * generated/maxloc0_16_i8.c: Regenerate. - * generated/maxval_i4.c: Regenerate. - * generated/maxloc1_4_i8.c: Regenerate. - * generated/maxloc0_16_i16.c: Regenerate. - * generated/maxloc1_4_i16.c: Regenerate. - * generated/maxloc0_8_i16.c: Regenerate. - * generated/maxloc0_4_i4.c: Regenerate. - * generated/maxloc1_8_i8.c: Regenerate. - * generated/maxloc0_8_i4.c: Regenerate. - * generated/maxloc0_16_i4.c: Regenerate. - * generated/maxloc1_16_i8.c: Regenerate. - * generated/maxloc1_4_i4.c: Regenerate. - * generated/maxval_i8.c: Regenerate. - * generated/maxloc0_4_i16.c: Regenerate. - * generated/maxloc1_8_i16.c: Regenerate. - * generated/maxloc0_4_i8.c: Regenerate. - * generated/maxloc1_16_i16.c: Regenerate. - * generated/maxval_i16.c: Regenerate. - -2007-02-04 Francois-Xavier Coudert <coudert@clipper.ens.fr> - - PR fortran/30611 - * intrinsics/string_intrinsics.c (string_repeat): Don't check - if ncopies is negative. - -2007-02-04 Francois-Xavier Coudert <coudert@clipper.ens.fr> - - PR libfortran/30007 - * libgfortran.h: Do not prefix symbol name with - __USER_LABEL_PREFIX__ when used in __attribute__((__alias__(...))). - -2007-02-02 Paul Thomas <pault@gcc.gnu.org> - - PR fortran/30284 - PR fortran/30626 - * io/transfer.c (init_loop_spec, next_array_record): Change to - lbound rather than unity base. - -2007-01-21 Francois-Xavier Coudert <coudert@clipper.ens.fr> - - * runtime/error.c: Include sys/time.h before sys/resource.h. - -2007-01-21 Thomas Koenig <Thomas.Koenig@online.de> - - PR libfortran/30525 - * intrinsics/string_intrinsics.c(compare_string): Make - sure that comparisons are done unsigned. - -2007-01-21 Tobias Burnus <burnus@net-b.de> - - PR libfortran/30015 - * intrinsics/date_and_time.c (date_and_time): Fix case where time - can go backwards. - * configure.ac: Remove AC_TRY_RUN test for timezone in - gettimeofday. - * acinclude.m4: Ditto. - * configure: Regenerate. - * config.h.in: Regenerate. - -2007-01-20 Francois-Xavier Coudert <coudert@clipper.ens.fr> - - * m4/misc_specifics.m4: Add _gfortran prefix to specific names. - * m4/specific2.m4: Likewise. - * m4/specific.m4: Likewise. - * intrinsics/f2c_specifics.F90: Likewise. - * intrinsics/selected_int_kind.f90: Add _gfortran prefix. - * intrinsics/selected_real_kind.f90: Likewise. - * intrinsics/dprod_r8.f90: Likewise. - * Makefile.am: Add -fallow-leading-underscore to the - gfor_specific_src files, as well as selected_real_kind.F90 - and selected_int_kind.F90 - * Makefile.in: Regenerate. - * generated/_sqrt_c8.F90: Regenerate. - * generated/_sign_r16.F90: Regenerate. - * generated/_log_c16.F90: Regenerate. - * generated/_sin_c10.F90: Regenerate. - * generated/_tanh_r4.F90: Regenerate. - * generated/_tanh_r8.F90: Regenerate. - * generated/_log10_r10.F90: Regenerate. - * generated/_aimag_c4.F90: Regenerate. - * generated/_sign_r4.F90: Regenerate. - * generated/_aimag_c8.F90: Regenerate. - * generated/_sign_r8.F90: Regenerate. - * generated/_mod_i4.F90: Regenerate. - * generated/_cos_r16.F90: Regenerate. - * generated/_aint_r10.F90: Regenerate. - * generated/_mod_i8.F90: Regenerate. - * generated/_abs_i16.F90: Regenerate. - * generated/_sqrt_c10.F90: Regenerate. - * generated/_atan2_r4.F90: Regenerate. - * generated/_cos_c4.F90: Regenerate. - * generated/_atan_r16.F90: Regenerate. - * generated/_tanh_r10.F90: Regenerate. - * generated/_atan2_r8.F90: Regenerate. - * generated/_cos_c8.F90: Regenerate. - * generated/_exp_r4.F90: Regenerate. - * generated/_log_r10.F90: Regenerate. - * generated/_exp_r8.F90: Regenerate. - * generated/_abs_r4.F90: Regenerate. - * generated/_abs_r8.F90: Regenerate. - * generated/_sin_r16.F90: Regenerate. - * generated/_tan_r4.F90: Regenerate. - * generated/_tan_r8.F90: Regenerate. - * generated/_sign_i4.F90: Regenerate. - * generated/_sign_i8.F90: Regenerate. - * generated/_exp_c16.F90: Regenerate. - * generated/_sqrt_r16.F90: Regenerate. - * generated/_conjg_c4.F90: Regenerate. - * generated/_conjg_c8.F90: Regenerate. - * generated/_dim_r16.F90: Regenerate. - * generated/_mod_r10.F90: Regenerate. - * generated/_abs_c10.F90: Regenerate. - * generated/_conjg_c16.F90: Regenerate. - * generated/_tan_r16.F90: Regenerate. - * generated/_asinh_r10.F90: Regenerate. - * generated/_abs_i4.F90: Regenerate. - * generated/_abs_i8.F90: Regenerate. - * generated/_acos_r10.F90: Regenerate. - * generated/_exp_r10.F90: Regenerate. - * generated/_acosh_r16.F90: Regenerate. - * generated/_atan2_r16.F90: Regenerate. - * generated/_cos_c16.F90: Regenerate. - * generated/_mod_i16.F90: Regenerate. - * generated/_asin_r4.F90: Regenerate. - * generated/_anint_r16.F90: Regenerate. - * generated/_asin_r8.F90: Regenerate. - * generated/_aimag_c10.F90: Regenerate. - * generated/_exp_c4.F90: Regenerate. - * generated/_sinh_r10.F90: Regenerate. - * generated/_exp_c8.F90: Regenerate. - * generated/_log10_r4.F90: Regenerate. - * generated/_log10_r8.F90: Regenerate. - * generated/_abs_c4.F90: Regenerate. - * generated/_abs_r16.F90: Regenerate. - * generated/_abs_c8.F90: Regenerate. - * generated/_asin_r10.F90: Regenerate. - * generated/_sign_r10.F90: Regenerate. - * generated/_atanh_r16.F90: Regenerate. - * generated/_log_c10.F90: Regenerate. - * generated/_cosh_r16.F90: Regenerate. - * generated/_sin_c16.F90: Regenerate. - * generated/_cos_r10.F90: Regenerate. - * generated/_log10_r16.F90: Regenerate. - * generated/_aint_r16.F90: Regenerate. - * generated/_acos_r4.F90: Regenerate. - * generated/_acos_r8.F90: Regenerate. - * generated/_sqrt_c16.F90: Regenerate. - * generated/_acosh_r4.F90: Regenerate. - * generated/_atan_r10.F90: Regenerate. - * generated/_acosh_r8.F90: Regenerate. - * generated/_sign_i16.F90: Regenerate. - * generated/_tanh_r16.F90: Regenerate. - * generated/_log_r4.F90: Regenerate. - * generated/_log_r8.F90: Regenerate. - * generated/_sin_r4.F90: Regenerate. - * generated/_sin_r8.F90: Regenerate. - * generated/_log_r16.F90: Regenerate. - * generated/_sin_r10.F90: Regenerate. - * generated/_sqrt_r4.F90: Regenerate. - * generated/_exp_c10.F90: Regenerate. - * generated/_sqrt_r8.F90: Regenerate. - * generated/_asinh_r4.F90: Regenerate. - * generated/_sqrt_r10.F90: Regenerate. - * generated/_asinh_r8.F90: Regenerate. - * generated/_dim_r4.F90: Regenerate. - * generated/_dim_r8.F90: Regenerate. - * generated/_dim_r10.F90: Regenerate. - * generated/_cosh_r4.F90: Regenerate. - * generated/_conjg_c10.F90: Regenerate. - * generated/_tan_r10.F90: Regenerate. - * generated/_cosh_r8.F90: Regenerate. - * generated/_mod_r16.F90: Regenerate. - * generated/_abs_c16.F90: Regenerate. - * generated/_cos_r4.F90: Regenerate. - * generated/_asinh_r16.F90: Regenerate. - * generated/_cos_r8.F90: Regenerate. - * generated/_atanh_r4.F90: Regenerate. - * generated/_atanh_r8.F90: Regenerate. - * generated/_acos_r16.F90: Regenerate. - * generated/_anint_r4.F90: Regenerate. - * generated/_acosh_r10.F90: Regenerate. - * generated/_anint_r8.F90: Regenerate. - * generated/_exp_r16.F90: Regenerate. - * generated/_mod_r4.F90: Regenerate. - * generated/_cos_c10.F90: Regenerate. - * generated/_atan2_r10.F90: Regenerate. - * generated/_dim_i16.F90: Regenerate. - * generated/_mod_r8.F90: Regenerate. - * generated/_anint_r10.F90: Regenerate. - * generated/_aint_r4.F90: Regenerate. - * generated/_aint_r8.F90: Regenerate. - * generated/_dim_i4.F90: Regenerate. - * generated/_sinh_r4.F90: Regenerate. - * generated/_log_c4.F90: Regenerate. - * generated/_dim_i8.F90: Regenerate. - * generated/_sinh_r8.F90: Regenerate. - * generated/_log_c8.F90: Regenerate. - * generated/_sin_c4.F90: Regenerate. - * generated/_sin_c8.F90: Regenerate. - * generated/misc_specifics.F90: Regenerate. - * generated/_abs_r10.F90: Regenerate. - * generated/_aimag_c16.F90: Regenerate. - * generated/_atan_r4.F90: Regenerate. - * generated/_sinh_r16.F90: Regenerate. - * generated/_atan_r8.F90: Regenerate. - * generated/_atanh_r10.F90: Regenerate. - * generated/_cosh_r10.F90: Regenerate. - * generated/_sqrt_c4.F90: Regenerate. - * generated/_asin_r16.F90: Regenerate. - -2007-01-19 Francois-Xavier Coudert <coudert@clipper.ens.fr> - - PR libfortran/26893 - * acinclude.m4 (LIBGFOR_WORKING_GFORTRAN): New check. - * configure.ac: Add call to LIBGFOR_WORKING_GFORTRAN. - * configure: Regenerate. - * config.h.in: Regenerate because it was forgottent in the last - commit. - -2007-01-18 Francois-Xavier Coudert <coudert@clipper.ens.fr> - Tobias Burnus <burnus@net-b.de> - - PR libfortran/29649 - * runtime/environ.c (variable_table): New GFORTRAN_ERROR_DUMPCORE - environment variable. - * runtime/compile_options.c (set_std): Add new argument. - * runtime/error.c (sys_exit): Move from io/unix.c. Add coredump - functionality. - * libgfortran.h (options_t): New dump_core and backtrace members. - (sys_exit): Move prototype. - * io/unix.c (sys_exit): Move to runtime/error.c. - * configure.ac: Add check for getrlimit. - * configure: Regenerate. - -2007-01-17 Tom Tromey <tromey@redhat.com> - - PR libfortran/27107: - * aclocal.m4, configure, Makefile.in: Rebuilt. - * configure.ac: Enable automake dependency tracking. Update - minimum automake version. - -2007-01-17 Francois-Xavier Coudert <coudert@clipper.ens.fr> - - PR libfortran/27107 - * runtime/environ.c: Don't include io/io.h. - * runtime/string.c: Don't include io/io.h. - (compare0): Add cast to avoid warning. - * runtime/error.c: Don't include io/io.h. - (st_printf): Move to io/unix.c. - * intrinsics/flush.c: Delete, contents moved to io/intrinsics.c. - * intrinsics/fget.c: Likewise. - * intrinsics/ftell.c: Likewise. - * intrinsics/tty.c: Likewise. - * libgfortran.h (DEFAULT_RECL, notification_std, - get_unformatted_convert, IOPARM_*, st_parameter_common, unit_convert, - DEFAULT_TEMPDIR): New declarations. - * io/io.h (DEFAULT_RECL, notification_std, get_unformatted_convert, - IOPARM_*, st_parameter_common, unit_convert, DEFAULT_TEMPDIR): - Move to libgfortran.h. - * io/unix.c: Add io/unix.h content. - (st_printf): New function. - * io/intrinsics.c: New file. - * io/unix.h: Remove, contents moved into unix.c. - * libtool-version: Update library version to 3.0.0. - * configure.ac: Update library version to 0.3. - * Makefile.am (intrinsics/fget.c, intrinsics/flush.c, - intrinsics/ftell.c, intrinsics/tty.c, libgfortran.h): Remove targets. - * Makefile.in: Regenerate. - * configure: Regenerate. - -2007-01-12 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/30435 - * io/list_read.c (finish_separator): Don't call next_record. - (list_formatted_read_scalar): Clean up some comments and whitespace. - (nml_read_obj): Whitespace fix. - -2007-01-05 Jerry DeLisle <jvdelisle@gcc.gnu.org> - - PR libfortran/30162 - * io/unix.c (fd_flush): Don't seek if file is not seekable, defined as - s->file_length == -1. - (fd_alloc_w_at): Do not adjust file_length if file is not seekable. - (fd_seek): If not seekable, just return success. - (fd_truncate): If not seekable, no need to truncate. Return failure if - seek fails and the stream is not a pipe. - (fd_to_stream): Make test for non-seekable file more robust. - -2007-01-01 Steven G. Kargl <kargls@comcast.net> - - * ChangeLog: Copied to ... - * ChangeLog-2006: here. +2008-01-18 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/34782 + * io/transfer.c (formatted_transfer_scalar): Set max_pos to the greater + of the current max_pos or the newly calculated position. + +2008-01-18 Tobias Burnus <burnus@net-b.de> + + * io/write.c (write_real): Increase default precision + for REAL(16) by one. + +2008-01-16 Steven Bosscher <steven@gcc.gnu.org> + + PR libfortran/34669 + * mk-kinds-h.sh: Compile with -S to avoid calling the assembler, + to avoid piping the -fdump-parse-tree output to the assembler + when configuring with -pipe. + * mk-sik-inc.sh: Likewise. + * mk-srk-inc.sh: Likewise. + +2008-01-15 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/34671 + * gfortran.am: Added _gfortran_all_l1, _gfortran_all_l2, + _gfortran_any_l1, _gfortran_any_l2, -28,15 _gfortran_count_1_l, + _gfortran_count_16_l, _gfortran_count_2_l, _gfortran_count_4_l and + _gfortran_count_8_l Removed _gfortran_count_16_l16, + _gfortran_count_16_l4, _gfortran_count_16_l8, + _gfortran_count_4_l16, _gfortran_count_4_l4, _gfortran_count_4_l8, + _gfortran_count_8_l16, _gfortran_count_8_l4 and + _gfortran_count_8_l8. + * Makefile.am: Added generated/any_l1.c and generated/any_l2.c to + i_any_c. Added generated/all_l1. and generated/all_l2.c to + i_all_c. Removed generated/count_4_l4.c, generated/count_8_l4.c, + generated/count_16_l4.c, generated/count_4_l8.c, + generated/count_8_l8.c, generated/count_16_l8.c, + generated/count_4_l16.c, generated/count_8_l16.c, and + generated/count_16_l16.c from i_count_c. Added count_1_l.c, + count_2_l.c, count_4_l.c, count_8_l.c and count_16_l.c to + i_count_c. I_M4_DEPS2 depends on ifunction_logical.m4, for + any of the files generated from all.m4, any.m4 and count.m4. + * Makefile.in: Regenerated. + * m4/ifunction_logical.m4: New file. Use + GFC_LOGICAL_1 pointer for access to source arrays. + * m4/any.m4: Include ifunction_logical.m4 instead of + ifunction.m4. Don't check atype_name. + * m4/all.m4: Likewise. + * m4/count.m4: Likewise. + * generated/any_l1.c: New file. + * generated/any_l2.c: New file. + * generated/all_l1.c: New file. + * generated/count_1_l.c: New file. + * generated/count_2_l.c: New file. + * generated/count_4_l.c: New file. + * generated/count_8_l.c: New file. + * generated/count_16_l.c: New file. + * generated/any_l4.c: Regenerated. + * generated/any_l8.c: Regenerated. + * generated/any_l16.c: Regenerated. + * generated/all_l4.c: Regenerated. + * generated/all_l8.c: Regenerated. + * generated/all_l16.c: Regenerated. + * generated/count_4_l4.c: Removed. + * generated/count_4_l8.c: Removed. + * generated/count_4_l16.c: Removed. + * generated/count_8_l4.c: Removed. + * generated/count_8_l8.c: Removed. + * generated/count_8_l16.c: Removed. + * generated/count_16_l4.c: Removed. + * generated/count_16_l8.c: Removed. + * generated/count_16_l16.c: Removed. + +2008-01-13 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/34746 + * m4/iforeach.m4 (name`'rtype_qual`_'atype_code): Use %ld + in printf format for all bounds checking; cast all + integer-like arguments to runtime_error() to long int. + (`m'name`'rtype_qual`_'atype_code): Likewise. + (`s'name`'rtype_qual`_'atype_code): Likewise. + * m4/ifunction.m4 (name`'rtype_qual`_'atype_code): Likewise. + (`m'name`'rtype_qual`_'atype_code): Likewise. + (`s'name`'rtype_qual`_'atype_code): Likewise. + * generated/all_l16.c: Regenerated. + * generated/all_l4.c: Regenerated. + * generated/all_l8.c: Regenerated. + * generated/any_l16.c: Regenerated. + * generated/any_l4.c: Regenerated. + * generated/any_l8.c: Regenerated. + * generated/count_16_l16.c: Regenerated. + * generated/count_16_l4.c: Regenerated. + * generated/count_16_l8.c: Regenerated. + * generated/count_4_l16.c: Regenerated. + * generated/count_4_l4.c: Regenerated. + * generated/count_4_l8.c: Regenerated. + * generated/count_8_l16.c: Regenerated. + * generated/count_8_l4.c: Regenerated. + * generated/count_8_l8.c: Regenerated. + * generated/maxloc0_16_i1.c: Regenerated. + * generated/maxloc0_16_i16.c: Regenerated. + * generated/maxloc0_16_i2.c: Regenerated. + * generated/maxloc0_16_i4.c: Regenerated. + * generated/maxloc0_16_i8.c: Regenerated. + * generated/maxloc0_16_r10.c: Regenerated. + * generated/maxloc0_16_r16.c: Regenerated. + * generated/maxloc0_16_r4.c: Regenerated. + * generated/maxloc0_16_r8.c: Regenerated. + * generated/maxloc0_4_i1.c: Regenerated. + * generated/maxloc0_4_i16.c: Regenerated. + * generated/maxloc0_4_i2.c: Regenerated. + * generated/maxloc0_4_i4.c: Regenerated. + * generated/maxloc0_4_i8.c: Regenerated. + * generated/maxloc0_4_r10.c: Regenerated. + * generated/maxloc0_4_r16.c: Regenerated. + * generated/maxloc0_4_r4.c: Regenerated. + * generated/maxloc0_4_r8.c: Regenerated. + * generated/maxloc0_8_i1.c: Regenerated. + * generated/maxloc0_8_i16.c: Regenerated. + * generated/maxloc0_8_i2.c: Regenerated. + * generated/maxloc0_8_i4.c: Regenerated. + * generated/maxloc0_8_i8.c: Regenerated. + * generated/maxloc0_8_r10.c: Regenerated. + * generated/maxloc0_8_r16.c: Regenerated. + * generated/maxloc0_8_r4.c: Regenerated. + * generated/maxloc0_8_r8.c: Regenerated. + * generated/maxloc1_16_i1.c: Regenerated. + * generated/maxloc1_16_i16.c: Regenerated. + * generated/maxloc1_16_i2.c: Regenerated. + * generated/maxloc1_16_i4.c: Regenerated. + * generated/maxloc1_16_i8.c: Regenerated. + * generated/maxloc1_16_r10.c: Regenerated. + * generated/maxloc1_16_r16.c: Regenerated. + * generated/maxloc1_16_r4.c: Regenerated. + * generated/maxloc1_16_r8.c: Regenerated. + * generated/maxloc1_4_i1.c: Regenerated. + * generated/maxloc1_4_i16.c: Regenerated. + * generated/maxloc1_4_i2.c: Regenerated. + * generated/maxloc1_4_i4.c: Regenerated. + * generated/maxloc1_4_i8.c: Regenerated. + * generated/maxloc1_4_r10.c: Regenerated. + * generated/maxloc1_4_r16.c: Regenerated. + * generated/maxloc1_4_r4.c: Regenerated. + * generated/maxloc1_4_r8.c: Regenerated. + * generated/maxloc1_8_i1.c: Regenerated. + * generated/maxloc1_8_i16.c: Regenerated. + * generated/maxloc1_8_i2.c: Regenerated. + * generated/maxloc1_8_i4.c: Regenerated. + * generated/maxloc1_8_i8.c: Regenerated. + * generated/maxloc1_8_r10.c: Regenerated. + * generated/maxloc1_8_r16.c: Regenerated. + * generated/maxloc1_8_r4.c: Regenerated. + * generated/maxloc1_8_r8.c: Regenerated. + * generated/maxval_i1.c: Regenerated. + * generated/maxval_i16.c: Regenerated. + * generated/maxval_i2.c: Regenerated. + * generated/maxval_i4.c: Regenerated. + * generated/maxval_i8.c: Regenerated. + * generated/maxval_r10.c: Regenerated. + * generated/maxval_r16.c: Regenerated. + * generated/maxval_r4.c: Regenerated. + * generated/maxval_r8.c: Regenerated. + * generated/minloc0_16_i1.c: Regenerated. + * generated/minloc0_16_i16.c: Regenerated. + * generated/minloc0_16_i2.c: Regenerated. + * generated/minloc0_16_i4.c: Regenerated. + * generated/minloc0_16_i8.c: Regenerated. + * generated/minloc0_16_r10.c: Regenerated. + * generated/minloc0_16_r16.c: Regenerated. + * generated/minloc0_16_r4.c: Regenerated. + * generated/minloc0_16_r8.c: Regenerated. + * generated/minloc0_4_i1.c: Regenerated. + * generated/minloc0_4_i16.c: Regenerated. + * generated/minloc0_4_i2.c: Regenerated. + * generated/minloc0_4_i4.c: Regenerated. + * generated/minloc0_4_i8.c: Regenerated. + * generated/minloc0_4_r10.c: Regenerated. + * generated/minloc0_4_r16.c: Regenerated. + * generated/minloc0_4_r4.c: Regenerated. + * generated/minloc0_4_r8.c: Regenerated. + * generated/minloc0_8_i1.c: Regenerated. + * generated/minloc0_8_i16.c: Regenerated. + * generated/minloc0_8_i2.c: Regenerated. + * generated/minloc0_8_i4.c: Regenerated. + * generated/minloc0_8_i8.c: Regenerated. + * generated/minloc0_8_r10.c: Regenerated. + * generated/minloc0_8_r16.c: Regenerated. + * generated/minloc0_8_r4.c: Regenerated. + * generated/minloc0_8_r8.c: Regenerated. + * generated/minloc1_16_i1.c: Regenerated. + * generated/minloc1_16_i16.c: Regenerated. + * generated/minloc1_16_i2.c: Regenerated. + * generated/minloc1_16_i4.c: Regenerated. + * generated/minloc1_16_i8.c: Regenerated. + * generated/minloc1_16_r10.c: Regenerated. + * generated/minloc1_16_r16.c: Regenerated. + * generated/minloc1_16_r4.c: Regenerated. + * generated/minloc1_16_r8.c: Regenerated. + * generated/minloc1_4_i1.c: Regenerated. + * generated/minloc1_4_i16.c: Regenerated. + * generated/minloc1_4_i2.c: Regenerated. + * generated/minloc1_4_i4.c: Regenerated. + * generated/minloc1_4_i8.c: Regenerated. + * generated/minloc1_4_r10.c: Regenerated. + * generated/minloc1_4_r16.c: Regenerated. + * generated/minloc1_4_r4.c: Regenerated. + * generated/minloc1_4_r8.c: Regenerated. + * generated/minloc1_8_i1.c: Regenerated. + * generated/minloc1_8_i16.c: Regenerated. + * generated/minloc1_8_i2.c: Regenerated. + * generated/minloc1_8_i4.c: Regenerated. + * generated/minloc1_8_i8.c: Regenerated. + * generated/minloc1_8_r10.c: Regenerated. + * generated/minloc1_8_r16.c: Regenerated. + * generated/minloc1_8_r4.c: Regenerated. + * generated/minloc1_8_r8.c: Regenerated. + * generated/minval_i1.c: Regenerated. + * generated/minval_i16.c: Regenerated. + * generated/minval_i2.c: Regenerated. + * generated/minval_i4.c: Regenerated. + * generated/minval_i8.c: Regenerated. + * generated/minval_r10.c: Regenerated. + * generated/minval_r16.c: Regenerated. + * generated/minval_r4.c: Regenerated. + * generated/minval_r8.c: Regenerated. + * generated/product_c10.c: Regenerated. + * generated/product_c16.c: Regenerated. + * generated/product_c4.c: Regenerated. + * generated/product_c8.c: Regenerated. + * generated/product_i1.c: Regenerated. + * generated/product_i16.c: Regenerated. + * generated/product_i2.c: Regenerated. + * generated/product_i4.c: Regenerated. + * generated/product_i8.c: Regenerated. + * generated/product_r10.c: Regenerated. + * generated/product_r16.c: Regenerated. + * generated/product_r4.c: Regenerated. + * generated/product_r8.c: Regenerated. + * generated/sum_c10.c: Regenerated. + * generated/sum_c16.c: Regenerated. + * generated/sum_c4.c: Regenerated. + * generated/sum_c8.c: Regenerated. + * generated/sum_i1.c: Regenerated. + * generated/sum_i16.c: Regenerated. + * generated/sum_i2.c: Regenerated. + * generated/sum_i4.c: Regenerated. + * generated/sum_i8.c: Regenerated. + * generated/sum_r10.c: Regenerated. + * generated/sum_r16.c: Regenerated. + * generated/sum_r4.c: Regenerated. + * generated/sum_r8.c: Regenerated. + +2008-01-11 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/34670 + * m4/iparm.m4 (upcase): New macro (copied from the m4 manual). + (u_name): New macro for the upper case name of the intrinsic. + * m4/iforeach.m4 (name`'rtype_qual`_'atype_code): Add + bounds checking and rank check, depending on + compile_options.bounds_check. + (`m'name`'rtype_qual`_'atype_code): Likewise. + (`s'name`'rtype_qual`_'atype_code): Likewise. + * m4/ifunction.m4 (name`'rtype_qual`_'atype_code): Add + bounds checking and rank check, depending on + compile_options.bounds_check. + (`m'name`'rtype_qual`_'atype_code): Likewise. + (`s'name`'rtype_qual`_'atype_code): Likewise. + * generated/all_l16.c: Regenerated. + * generated/all_l4.c: Regenerated. + * generated/all_l8.c: Regenerated. + * generated/any_l16.c: Regenerated. + * generated/any_l4.c: Regenerated. + * generated/any_l8.c: Regenerated. + * generated/count_16_l16.c: Regenerated. + * generated/count_16_l4.c: Regenerated. + * generated/count_16_l8.c: Regenerated. + * generated/count_4_l16.c: Regenerated. + * generated/count_4_l4.c: Regenerated. + * generated/count_4_l8.c: Regenerated. + * generated/count_8_l16.c: Regenerated. + * generated/count_8_l4.c: Regenerated. + * generated/count_8_l8.c: Regenerated. + * generated/maxloc0_16_i1.c: Regenerated. + * generated/maxloc0_16_i16.c: Regenerated. + * generated/maxloc0_16_i2.c: Regenerated. + * generated/maxloc0_16_i4.c: Regenerated. + * generated/maxloc0_16_i8.c: Regenerated. + * generated/maxloc0_16_r10.c: Regenerated. + * generated/maxloc0_16_r16.c: Regenerated. + * generated/maxloc0_16_r4.c: Regenerated. + * generated/maxloc0_16_r8.c: Regenerated. + * generated/maxloc0_4_i1.c: Regenerated. + * generated/maxloc0_4_i16.c: Regenerated. + * generated/maxloc0_4_i2.c: Regenerated. + * generated/maxloc0_4_i4.c: Regenerated. + * generated/maxloc0_4_i8.c: Regenerated. + * generated/maxloc0_4_r10.c: Regenerated. + * generated/maxloc0_4_r16.c: Regenerated. + * generated/maxloc0_4_r4.c: Regenerated. + * generated/maxloc0_4_r8.c: Regenerated. + * generated/maxloc0_8_i1.c: Regenerated. + * generated/maxloc0_8_i16.c: Regenerated. + * generated/maxloc0_8_i2.c: Regenerated. + * generated/maxloc0_8_i4.c: Regenerated. + * generated/maxloc0_8_i8.c: Regenerated. + * generated/maxloc0_8_r10.c: Regenerated. + * generated/maxloc0_8_r16.c: Regenerated. + * generated/maxloc0_8_r4.c: Regenerated. + * generated/maxloc0_8_r8.c: Regenerated. + * generated/maxloc1_16_i1.c: Regenerated. + * generated/maxloc1_16_i16.c: Regenerated. + * generated/maxloc1_16_i2.c: Regenerated. + * generated/maxloc1_16_i4.c: Regenerated. + * generated/maxloc1_16_i8.c: Regenerated. + * generated/maxloc1_16_r10.c: Regenerated. + * generated/maxloc1_16_r16.c: Regenerated. + * generated/maxloc1_16_r4.c: Regenerated. + * generated/maxloc1_16_r8.c: Regenerated. + * generated/maxloc1_4_i1.c: Regenerated. + * generated/maxloc1_4_i16.c: Regenerated. + * generated/maxloc1_4_i2.c: Regenerated. + * generated/maxloc1_4_i4.c: Regenerated. + * generated/maxloc1_4_i8.c: Regenerated. + * generated/maxloc1_4_r10.c: Regenerated. + * generated/maxloc1_4_r16.c: Regenerated. + * generated/maxloc1_4_r4.c: Regenerated. + * generated/maxloc1_4_r8.c: Regenerated. + * generated/maxloc1_8_i1.c: Regenerated. + * generated/maxloc1_8_i16.c: Regenerated. + * generated/maxloc1_8_i2.c: Regenerated. + * generated/maxloc1_8_i4.c: Regenerated. + * generated/maxloc1_8_i8.c: Regenerated. + * generated/maxloc1_8_r10.c: Regenerated. + * generated/maxloc1_8_r16.c: Regenerated. + * generated/maxloc1_8_r4.c: Regenerated. + * generated/maxloc1_8_r8.c: Regenerated. + * generated/maxval_i1.c: Regenerated. + * generated/maxval_i16.c: Regenerated. + * generated/maxval_i2.c: Regenerated. + * generated/maxval_i4.c: Regenerated. + * generated/maxval_i8.c: Regenerated. + * generated/maxval_r10.c: Regenerated. + * generated/maxval_r16.c: Regenerated. + * generated/maxval_r4.c: Regenerated. + * generated/maxval_r8.c: Regenerated. + * generated/minloc0_16_i1.c: Regenerated. + * generated/minloc0_16_i16.c: Regenerated. + * generated/minloc0_16_i2.c: Regenerated. + * generated/minloc0_16_i4.c: Regenerated. + * generated/minloc0_16_i8.c: Regenerated. + * generated/minloc0_16_r10.c: Regenerated. + * generated/minloc0_16_r16.c: Regenerated. + * generated/minloc0_16_r4.c: Regenerated. + * generated/minloc0_16_r8.c: Regenerated. + * generated/minloc0_4_i1.c: Regenerated. + * generated/minloc0_4_i16.c: Regenerated. + * generated/minloc0_4_i2.c: Regenerated. + * generated/minloc0_4_i4.c: Regenerated. + * generated/minloc0_4_i8.c: Regenerated. + * generated/minloc0_4_r10.c: Regenerated. + * generated/minloc0_4_r16.c: Regenerated. + * generated/minloc0_4_r4.c: Regenerated. + * generated/minloc0_4_r8.c: Regenerated. + * generated/minloc0_8_i1.c: Regenerated. + * generated/minloc0_8_i16.c: Regenerated. + * generated/minloc0_8_i2.c: Regenerated. + * generated/minloc0_8_i4.c: Regenerated. + * generated/minloc0_8_i8.c: Regenerated. + * generated/minloc0_8_r10.c: Regenerated. + * generated/minloc0_8_r16.c: Regenerated. + * generated/minloc0_8_r4.c: Regenerated. + * generated/minloc0_8_r8.c: Regenerated. + * generated/minloc1_16_i1.c: Regenerated. + * generated/minloc1_16_i16.c: Regenerated. + * generated/minloc1_16_i2.c: Regenerated. + * generated/minloc1_16_i4.c: Regenerated. + * generated/minloc1_16_i8.c: Regenerated. + * generated/minloc1_16_r10.c: Regenerated. + * generated/minloc1_16_r16.c: Regenerated. + * generated/minloc1_16_r4.c: Regenerated. + * generated/minloc1_16_r8.c: Regenerated. + * generated/minloc1_4_i1.c: Regenerated. + * generated/minloc1_4_i16.c: Regenerated. + * generated/minloc1_4_i2.c: Regenerated. + * generated/minloc1_4_i4.c: Regenerated. + * generated/minloc1_4_i8.c: Regenerated. + * generated/minloc1_4_r10.c: Regenerated. + * generated/minloc1_4_r16.c: Regenerated. + * generated/minloc1_4_r4.c: Regenerated. + * generated/minloc1_4_r8.c: Regenerated. + * generated/minloc1_8_i1.c: Regenerated. + * generated/minloc1_8_i16.c: Regenerated. + * generated/minloc1_8_i2.c: Regenerated. + * generated/minloc1_8_i4.c: Regenerated. + * generated/minloc1_8_i8.c: Regenerated. + * generated/minloc1_8_r10.c: Regenerated. + * generated/minloc1_8_r16.c: Regenerated. + * generated/minloc1_8_r4.c: Regenerated. + * generated/minloc1_8_r8.c: Regenerated. + * generated/minval_i1.c: Regenerated. + * generated/minval_i16.c: Regenerated. + * generated/minval_i2.c: Regenerated. + * generated/minval_i4.c: Regenerated. + * generated/minval_i8.c: Regenerated. + * generated/minval_r10.c: Regenerated. + * generated/minval_r16.c: Regenerated. + * generated/minval_r4.c: Regenerated. + * generated/minval_r8.c: Regenerated. + * generated/product_c10.c: Regenerated. + * generated/product_c16.c: Regenerated. + * generated/product_c4.c: Regenerated. + * generated/product_c8.c: Regenerated. + * generated/product_i1.c: Regenerated. + * generated/product_i16.c: Regenerated. + * generated/product_i2.c: Regenerated. + * generated/product_i4.c: Regenerated. + * generated/product_i8.c: Regenerated. + * generated/product_r10.c: Regenerated. + * generated/product_r16.c: Regenerated. + * generated/product_r4.c: Regenerated. + * generated/product_r8.c: Regenerated. + * generated/sum_c10.c: Regenerated. + * generated/sum_c16.c: Regenerated. + * generated/sum_c4.c: Regenerated. + * generated/sum_c8.c: Regenerated. + * generated/sum_i1.c: Regenerated. + * generated/sum_i16.c: Regenerated. + * generated/sum_i2.c: Regenerated. + * generated/sum_i4.c: Regenerated. + * generated/sum_i8.c: Regenerated. + * generated/sum_r10.c: Regenerated. + * generated/sum_r16.c: Regenerated. + * generated/sum_r4.c: Regenerated. + * generated/sum_r8.c: Regenerated. + +2008-01-05 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/34676 + * io/list_read.c (next_char): Only save the EOF condition for later if + advance="no". + +2008-01-03 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/34565 + * io/io.h: Adjust protoypes for open_internal(), + next_array_record() and init_loop_spec(). + * io/list_read.c (next_char): Use argument "finished" + of next_array_record to check for end on internal file. + * io/unit.c: Calculate the offset for an array + internal file and supply this informatin to open_internal(). + * io/unix.c (open_internal): Set the offset for the internal + file on open. + * io/transfer.c (init_loop_spec): Calculate the starting + record in case of negative strides. Return size of 0 for + an empty array. + (next_array_record): Use an extra flag to signal that the + array is finished. + (next_record_r): Use the new flag to next_array_record(). + (next_record_w): Likewise. diff --git a/libgfortran/ChangeLog-2007 b/libgfortran/ChangeLog-2007 new file mode 100644 index 00000000000..2b8611018cc --- /dev/null +++ b/libgfortran/ChangeLog-2007 @@ -0,0 +1,2480 @@ +2007-12-27 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/22423 + * intrinsics/pack_generic.c (pack): Change type of mask argument + to gfc_array_l1 * in prototype and function. + (pack_char): Likewise. + * intrinsics/unpack_generic.c (unpack1): Likewise. + (unpack1_char): Likewise. + (unpack0): Likewise. + (unpack0_char): Likewise. + +2007-12-27 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/34594 + * runtime/error.c: If there was a previous error, don't + mask it with another error mesage, EOF or EOR condition. + +2007-12-25 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/34560 + * io/transfer.c (read_sf): Check if readlen was less than the requested + number of bytes to read and if so, generate error. + +2007-12-25 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/34533 + * intrinsics/cpu_time.c: Moved code commonly usable for CPU_TIME, + DTIME and ETIME to ... + * intrinsics/time_1.h: ... here. + * intrinsics/dtime.c: New file. + * intrinsics/etime.c: Newly implemented using the common + time-aquisition function from time_1.h. + * gfortran.map (_gfortran_dtime, _gfortran_dtime_sub): New. + * Makefile.am: Added new file. + * Makefile.in: Regenerated. + * configure: Regenerated. + +2007-12-25 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/34566 + * m4/matmull.m4: Multiply xstride and ystride by correct kind. + * generated/matmul_l4.c: Regenerated. + * generated/matmul_l8.c: Regenerated. + * generated/matmul_l16.c: Regenerated. + +2007-12-19 Tobias Burnus <burnus@net-b.de> + + PR fortran/34530 + * io/list_read.c (eat_line): Move up in the file. + (eat_separator): In namelist mode, skip over comment lines. + +2007-12-16 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/34427 + * io/list_read.c (read_real): Handle intervening line ends and spaces. + (get_name): Don't push separators to saved_string. + (eat_separator): If in namelist mode eat spaces and line ends as well. + +2007-12-13 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/34370 + PR libfortran/34323 + PR libfortran/34405 + * io/io.h: Add previous_nonadvancing_write to gfc_unit. + Add prototype for finish_last_advance_record. + * io/file_pos.c (st_backspace): Generate error if backspace is + attempted for direct access or unformatted stream. + If there are bytes left from a previous ADVANCE="no", write + them out before performing the backspace. + (st_endfile): Generate error if endfile is attempted for + direct access. + If there are bytes left from a previous ADVANCE="no", write + them out before performing the endfile. + (st_rewind): Generate error if rewind is attempted for + direct access. + * unit.c (close_unit_1): Move functionality to write + previously written bytes to... + (finish_last_advance_record): ... here. + * transfer.c (data_transfer_init): If reading, reset + previous_nonadvancing_write. + (finalize_transfer): Set the previous_noadvancing_write + flag if we are writing and ADVANCE="no" was specified. + Only call next_record() if advance="no" wasn't specified. + +2007-12-13 Tobias Burnus <burnus@net-b.de> + + PR fortran/34427 + * io/list_read.c (read_real): Fix unwinding for namelists. + +2007-12-10 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/34411 + * io/read.c (convert_real, read_l, read_decimal, read_radix, read_f): + Call next_record after bad read or overflow error. + +2007-12-09 Tobias Burnus <burnus@net-b.de> + + PR fortran/34404 + * io/list_read.c (parse_real): Remove superfluous "goto bad;". + +2007-12-08 Tobias Burnus <burnus@net-b.de> + + PR fortran/34319 + * io/list_read.c (parse_real, read_real): Support NaN/Infinity. + +2007-12-02 Jerry DeLisle <jvdelisle@gcc.gnu.org> + Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/33985 + * io/transfer.c (read_block, read_block_direct, write_block, write_buf): + Don't seek if file position is already there for STREAM I/O. + (finalize_transfer): For STREAM I/O don't flush unless the file position + has moved past the start position before the transfer. + +2007-12-01 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * intrinsic/stat.c (stat_i4_sub_0, stat_i8_sub_0): Mark parameter + with unused attribute. + * intrinsics/system_clock.c (system_clock_4, system_clock_8): + Remove unused variable. + * intrinsics/umask.c: Include unistd.h. + +2007-11-30 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/34291 + * io/list_read.c (read_character): When reading an unquoted string, + return if special characters that could signify the end of the namelist + read are encountered. + +2007-11-29 Steven G. Kargl <kargls@comcast.net> + + PR libfortran/33583 + * libgfortran/gfortran.map: Add tgammaf, tgamma, lgamma, and lgammaf. + * gfortran.dg/gamma_5.f90: Remove xfail. + +2007-11-16 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR libfortran/33583 + PR libfortran/33698 + * intrinsics/c99_functions.c (tgamma, tgammaf, lgamma, lgammaf): + New fallback functions. + * c99_protos.h (tgamma, tgammaf, lgamma, lgammaf): New prototypes. + * configure.ac: Add checks for tgamma, tgammaf, tgammal, lgamma, + lgammaf and lgammal. + * config.h.in: Regenerate. + * configure: Regenerate. + +2007-11-08 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * mk-kinds-h.sh: Change sed syntax. + +2007-11-06 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/33985 + * io/transfer.c (finalize_transfer): Revert previous patch. + +2007-11-03 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/33985 + * io/transfer.c (finalize_transfer): Do not flush for + unformatted STREAM I/O. + +2007-10-27 Tobias Burnus <burnus@net-b.de> + + * mk-kinds-h.sh: Change LANG=C to LC_ALL=C. + +2007-10-26 Tobias Burnus <burnus@net-b.de> + + * mk-kinds-h.sh: Add "LANG=C". + +2007-10-26 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * libgfortran.h (GFC_REAL_*_HUGE, GFC_REAL_*_DIGITS, + GFC_REAL_*_RADIX): Remove. + * mk-kinds-h.sh: Define GFC_REAL_*_HUGE, GFC_REAL_*_DIGITS and + GFC_REAL_*_RADIX. Don't define GFC_REAL_LARGEST_FORMAT and + GFC_REAL_LARGEST. + +2007-10-19 Ben Elliston <bje@au.ibm.com> + + * intrinsics/signal.c (alarm_sub_i4): Mark conditionally unused + parameters with __attribute__ ((unused)). + (alarm_sub_i8): Likewise. + (alarm_sub_int_i4): Likewise. + (alarm_sub_int_i8): Likewise. + +2007-10-18 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/33795 + * libgfortran.h: Add unbuffered_preconnected. + * io/unix.c (output_stream): Set stream unbuffered flag if + options.unbuffered_preconnected has been set. + (error_stream): Ditto. + * runtime/environ.c (variable_table): Add to environment variable table + the entry: GFORTRAN_UNBUFFERED_PRECONNECTED. + +2007-10-18 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR libfortran/32021 + * runtime/backtrace.c (local_strcasestr): Protect by appropriate + macros. + * runtime/main.c (cleanup): Cast argument to free. + * intrinsics/spread_generic.c (spread_internal): Match runtime_error + arguments and format. + * intrinsics/signal.c (alarm_sub_int_i4, alarm_sub_int_i8): Cast + pointers to avoid warnings. + +2007-10-18 Ben Elliston <bje@au.ibm.com> + + * runtime/environ.c (init_choice): Remove unused function. + (show_choice): Likewise. + (choice): Remove. + (FP_ROUND_NEAREST, FP_ROUND_UP, FP_ROUND_DOWN, FP_ROUND_ZERO): + Remove. + (precision, signal_choices): Remove. + +2007-10-15 Christopher D. Rickett <crickett@lanl.gov> + + PR fortran/32600 + * libgfortran/intrinsics/iso_c_binding.c: Remove c_associated_1 + and c_associated_2. + * libgfortran/intrinsics/iso_c_binding.h: Ditto. + * libgfortran/gfortran.map: Ditto. + +2007-10-15 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/33055 + * io/inquire.c (inquire_via_unit): If inquiring by unit, check for + an error condition from the IOSTAT variable and set EXIST to false if + there was a bad unit number. + +2007-10-14 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/33672 + * io/list_read.c (nml_parse_qualifier): Add character specific error + messages. Check for proper form of sub-string qualifiers. Return the + parsed_rank flag indicating a non-zero rank qualifier. + (nml_get_obj_data): Count the instances of non-zero rank qualifiers. + Issue an error if more that one non-zero rank qualifier is found. + +2007-10-04 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/33253 + * io/list_read.c (read_character): Use line_buffer to scan ahead for + object name or string when no delimiter is found. + +2007-10-04 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR libfortran/32021 + * runtime/environ.c (init_mem, show_mem, init_round, show_round, + init_precision, show_precision, init_signal, show_signal): Remove. + (variable_table): Remove GFORTRAN_MEM_INIT, GFORTRAN_MEM_CHECK, + GFORTRAN_SIGHUP, GFORTRAN_SIGINT, GFORTRAN_FPU_ROUND and + GFORTRAN_FPU_PRECISION. + * libgfortran.h (options_t): Remove mem_check, fpu_round, + fpu_precision, sighup, sigint, allocate_init_flag and + allocate_init_value. + +2007-10-02 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/33253 + * io/list_read.c (read_character): Use DELIM_APOSTROPHE and DELIM_QUOTE + and quote value in check of first character in string. + +2007-10-02 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/33469 + * io/write.c (write_real): Widen the default formats. + +2007-09-28 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/33400 + * io/list_read.c (next_char): Interpret encountering the end of file the + first time as an end of line. Subsequent reads give EOF error. + +2007-09-27 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/33421 + * io/list_read.c (read_character): Revert r128057. + +2007-09-21 Bernhard Fischer <aldot> + + PR fortran/31546 + * (configure.ac): Add --enable-intermodule for onestep build. + * (Makefile.am): Handle onestep build. + * (configure, Makefile.in): Regenerate. + +2007-09-21 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR libfortran/26253 + * intrinsics/c99_functions.c (scalbn): Use ldexp if appopriate. + +2007-09-21 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR libfortran/23272 + * io/unix.c (id_from_handle, id_from_path, id_from_fd): New + functions. + (compare_file_filename, find_file, find_file0): Use the new + functions above. + +2007-09-21 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * acinclude.m4 (LIBGFOR_TARGET_ILP32): Remove test. + * configure.ac: Don't call LIBGFOR_TARGET_ILP32. + * configure: Regenerate. + * config.h.in: Regenerate. + +2007-09-15 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR libfortran/21185 + * runtime/compile_options.c (set_options): Fix typo. + * runtime/main.c (store_exe_path): If getcwd is not available, + don't use it. + * intrinsics/getcwd.c: Same thing here. + * io/unix.c (fallback_access): New fallback function for access. + (fix_fd): Don't use dup if it's not available. + * configure.ac: Check for dup and getcwd. + * configure: Regenerate. + * config.h.in: Regenerate. + +2007-09-12 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * io/io.h: Include libgfortran.h first. + +2007-09-11 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR libfortran/33386 + * runtime/select.c (select_string): Initialize default_jump. + +2007-09-07 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/33307 + * io/filepos.c (st_backspace): Don't truncate when already at the end + of the file. + +2007-09-07 Uros Bizjak <ubizjak@gmail.com> + + * config/fpu-387.h: Include cpuid.h. + (set_fpu): Use __get_cpuid to check for SSE. + +2007-09-06 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/33298 + * intrinsics/spread_generic.c(spread_internal): Enable + bounds checking by comparing extents if the bounds_check + option has been set. If any extent is <=0, return early. + +2007-09-06 David Edelsohn <edelsohn@gnu.org> + + * libgfortran.h: Include config.h first. + * io/io.h (struct stream): Rename truncate to trunc. + * io/unix.c (fd_open): Same. + (open_internal): Same. + +2007-09-05 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/33253 + * io/write.c (nml_write_obj): Set the delimiter correctly before + calling write_character. (namelist_write): Clean up the code a little + and add comments to clarify what its doing. + +2007-09-04 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/33225 + * io/write.c (stdbool.h): Add include. (sign_t): Move typedef to + new file write_float.def. Include write_float.def. + (extract_real): Delete. (calculate_sign): Delete. + (calculate_exp): Delete. (calculate_G_format): Delete. + (output_float): Delete. (write_float): Delete. + * io/write_float.def (calculate_sign): Added. + (output_float): Refactored to be independent of kind and added to this + file for inclusion. (write_infnan): New function to write "Infinite" + or "NaN" depending on flags passed, independent of kind. + (CALCULATE_EXP): New macro to build kind specific functions. Use it. + (OUTPUT_FLOAT_FMT_G): New macro, likewise. Use it. + (DTOA, DTOAL): Macros to implement "decimal to ascii". + (WRITE_FLOAT): New macro for kind specific write_float functions. + (write_float): Revised function to determine kind and use WRITE_FLOAT + to implement kind specific output. + +2007-09-03 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/33253 + * io/list_read.c (read_character): Use DELIM_APOSTROPHE and + DELIM_QUOTE in check of first character in string. + +2007-09-03 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/31675 + * libgfortran.h: Include gcc/fortran/libgfortran.h. + Remove M_PI, GFC_MAX_DIMENSIONS, GFC_DTYPE_*, GFC_NUM_RANK_BITS, + error_codes, GFC_STD_*, GFC_FPE_* and unit_convert. + * runtime/environ.c (variable_table): Use GFC_*_UNIT_NUMBER instead + of hardcoded constants. + (do_parse, init_unformatted): Use GFC_CONVERT_* macros instead of + CONVERT_*. + * runtime/string.c (find_option): Use LIBERROR_BAD_OPTION instead + of ERROR_BAD_OPTION. + * runtime/error.c (translate_error, generate_error): Use + LIBERROR_* macros instead of ERROR_*. + * io/file_pos.c (formatted_backspace, unformatted_backspace, + st_backspace, st_rewind, st_flush): Rename macros. + * io/open.c (convert_opt, edit_modes, new_unit, already_open, + st_open): Likewise. + * io/close.c (st_close): Likewise. + * io/list_read.c (next_char, convert_integer, parse_repeat, + read_logical, read_integer, read_character, parse_real, + check_type, list_formatted_read_scalar, namelist_read, + nml_err_ret): Likewise. + * io/read.c (convert_real, read_l, read_decimal, read_radix, + read_f): Likewise. + * io/inquire.c (inquire_via_unit): Likewise. + * io/unit.c (get_internal_unit): Likewise. + * io/transfer.c (read_sf, read_block, read_block_direct, + write_block, write_buf, unformatted_read, unformatted_write, + formatted_transfer_scalar, us_read, us_write, data_transfer_init, + skip_record, next_record_r, write_us_marker, next_record_w_unf, + next_record_w, finalize_transfer, st_read, st_write_done): + Likewise. + * io/format.c (format_error): Likewise. + +2007-08-31 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * m4/minloc1.m4: Update copyright year and ajust headers order. + * m4/maxloc1.m4: Likewise. + * m4/in_pack.m4: Likewise. + * m4/sum.m4: Likewise. + * m4/fraction.m4: Likewise. + * m4/all.m4: Likewise. + * m4/set_exponent.m4: Likewise. + * m4/transpose.m4: Likewise. + * m4/eoshift1.m4: Likewise. + * m4/spacing.m4: Likewise. + * m4/eoshift3.m4: Likewise. + * m4/minval.m4: Likewise. + * m4/count.m4: Likewise. + * m4/maxval.m4: Likewise. + * m4/exponent.m4: Likewise. + * m4/shape.m4: Likewise. + * m4/head.m4: Likewise. + * m4/cshift1.m4: Likewise. + * m4/minloc0.m4: Likewise. + * m4/nearest.m4: Likewise. + * m4/maxloc0.m4: Likewise. + * m4/pow.m4: Likewise. + * m4/in_unpack.m4: Likewise. + * m4/matmull.m4: Likewise. + * m4/product.m4: Likewise. + * m4/reshape.m4: Likewise. + * m4/any.m4: Likewise. + * m4/rrspacing.m4: Likewise. + * m4/matmul.m4: Likewise. + * runtime/backtrace.c: Likewise. + * runtime/environ.c: Likewise. + * runtime/in_pack_generic.c: Likewise. + * runtime/compile_options.c: Likewise. + * runtime/in_unpack_generic.c: Likewise. + * runtime/main.c: Likewise. + * runtime/stop.c: Likewise. + * runtime/string.c: Likewise. + * runtime/memory.c: Likewise. + * runtime/error.c: Likewise. + * runtime/pause.c: Likewise. + * intrinsics/ierrno.c: Likewise. + * intrinsics/system_clock.c: Likewise. + * intrinsics/cshift0.c: Likewise. + * intrinsics/unlink.c: Likewise. + * intrinsics/ctime.c: Likewise. + * intrinsics/etime.c: Likewise. + * intrinsics/cpu_time.c: Likewise. + * intrinsics/malloc.c: Likewise. + * intrinsics/hostnm.c: Likewise. + * intrinsics/sleep.c: Likewise. + * intrinsics/exit.c: Likewise. + * intrinsics/perror.c: Likewise. + * intrinsics/transpose_generic.c: Likewise. + * intrinsics/pack_generic.c: Likewise. + * intrinsics/spread_generic.c: Likewise. + * intrinsics/stat.c: Likewise. + * intrinsics/string_intrinsics.c: Likewise. + * intrinsics/getcwd.c: Likewise. + * intrinsics/date_and_time.c: Likewise. + * intrinsics/unpack_generic.c: Likewise. + * intrinsics/move_alloc.c: Likewise. + * intrinsics/getlog.c: Likewise. + * intrinsics/eoshift0.c: Likewise. + * intrinsics/eoshift2.c: Likewise. + * intrinsics/reshape_generic.c: Likewise. + * intrinsics/system.c: Likewise. + * intrinsics/iso_c_binding.c: Likewise. + * intrinsics/env.c: Likewise. + * intrinsics/kill.c: Likewise. + * intrinsics/reshape_packed.c: Likewise. + * intrinsics/time.c: Likewise. + * intrinsics/gerror.c: Likewise. + * intrinsics/access.c: Likewise. + * intrinsics/fnum.c: Likewise. + * intrinsics/abort.c: Likewise. + * intrinsics/rename.c: Likewise. + * intrinsics/signal.c: Likewise. + * intrinsics/symlnk.c: Likewise. + * intrinsics/random.c: Likewise. + * intrinsics/umask.c: Likewise. + * intrinsics/getXid.c: Likewise. + * intrinsics/rand.c: Likewise. + * intrinsics/chdir.c: Likewise. + * intrinsics/chmod.c: Likewise. + * intrinsics/clock.c: Likewise. + * intrinsics/args.c: Likewise. + * intrinsics/link.c: Likewise. + * c99_protos.h: Likewise. + * config/fpu-387.h: Likewise. + * config/fpu-aix.h: Likewise. + * config/fpu-sysv.h: Likewise. + * config/fpu-generic.h: Likewise. + * config/fpu-glibc.h: Likewise. + * io/file_pos.c: Likewise. + * io/open.c: Likewise. + * io/size_from_kind.c: Likewise. + * io/close.c: Likewise. + * io/list_read.c: Likewise. + * io/read.c: Likewise. + * io/inquire.c: Likewise. + * io/unit.c: Likewise. + * io/unix.c: Likewise. + * io/transfer.c: Likewise. + * io/intrinsics.c: Likewise. + * io/format.c: Likewise. + * io/lock.c: Likewise. + * io/write.c: Likewise. + * io/write_float.def: Likewise. + * fmain.c: Likewise. + * generated/minval_r8.c: Regenerate. + * generated/minloc1_16_r16.c: Regenerate. + * generated/maxloc1_4_r8.c: Regenerate. + * generated/sum_i8.c: Regenerate. + * generated/eoshift3_4.c: Regenerate. + * generated/transpose_c8.c: Regenerate. + * generated/any_l16.c: Regenerate. + * generated/eoshift1_8.c: Regenerate. + * generated/pow_r8_i8.c: Regenerate. + * generated/reshape_r16.c: Regenerate. + * generated/pow_i4_i16.c: Regenerate. + * generated/maxval_i2.c: Regenerate. + * generated/product_r4.c: Regenerate. + * generated/maxloc1_8_i4.c: Regenerate. + * generated/exponent_r16.c: Regenerate. + * generated/maxloc0_4_r4.c: Regenerate. + * generated/fraction_r16.c: Regenerate. + * generated/in_unpack_i8.c: Regenerate. + * generated/matmul_r8.c: Regenerate. + * generated/product_i2.c: Regenerate. + * generated/fraction_r4.c: Regenerate. + * generated/minloc0_4_r16.c: Regenerate. + * generated/reshape_c4.c: Regenerate. + * generated/minloc0_4_i1.c: Regenerate. + * generated/maxloc0_4_r16.c: Regenerate. + * generated/maxloc0_4_i2.c: Regenerate. + * generated/minloc1_8_r16.c: Regenerate. + * generated/maxloc1_8_r16.c: Regenerate. + * generated/set_exponent_r8.c: Regenerate. + * generated/in_unpack_i16.c: Regenerate. + * generated/transpose_c16.c: Regenerate. + * generated/maxloc0_8_i8.c: Regenerate. + * generated/pow_c4_i8.c: Regenerate. + * generated/sum_r16.c: Regenerate. + * generated/sum_i1.c: Regenerate. + * generated/minloc1_4_r8.c: Regenerate. + * generated/transpose_r10.c: Regenerate. + * generated/pow_i8_i4.c: Regenerate. + * generated/maxloc1_16_r16.c: Regenerate. + * generated/minloc1_16_i4.c: Regenerate. + * generated/maxloc1_16_i4.c: Regenerate. + * generated/minloc0_16_i8.c: Regenerate. + * generated/maxloc0_16_i8.c: Regenerate. + * generated/nearest_r8.c: Regenerate. + * generated/spacing_r16.c: Regenerate. + * generated/transpose_i8.c: Regenerate. + * generated/count_16_l16.c: Regenerate. + * generated/maxval_r16.c: Regenerate. + * generated/count_8_l8.c: Regenerate. + * generated/product_c10.c: Regenerate. + * generated/minloc1_8_i4.c: Regenerate. + * generated/minloc0_16_i16.c: Regenerate. + * generated/matmul_r16.c: Regenerate. + * generated/eoshift1_16.c: Regenerate. + * generated/minloc0_4_r4.c: Regenerate. + * generated/pow_c16_i16.c: Regenerate. + * generated/set_exponent_r10.c: Regenerate. + * generated/pow_i16_i16.c: Regenerate. + * generated/product_c4.c: Regenerate. + * generated/sum_r4.c: Regenerate. + * generated/pow_c16_i4.c: Regenerate. + * generated/rrspacing_r10.c: Regenerate. + * generated/in_pack_c16.c: Regenerate. + * generated/minloc0_4_i2.c: Regenerate. + * generated/maxloc0_8_i1.c: Regenerate. + * generated/reshape_i4.c: Regenerate. + * generated/minloc0_8_i8.c: Regenerate. + * generated/matmul_c8.c: Regenerate. + * generated/spacing_r4.c: Regenerate. + * generated/in_pack_c4.c: Regenerate. + * generated/all_l16.c: Regenerate. + * generated/minloc1_16_r10.c: Regenerate. + * generated/sum_i2.c: Regenerate. + * generated/minloc0_16_i1.c: Regenerate. + * generated/reshape_c16.c: Regenerate. + * generated/maxloc0_16_i1.c: Regenerate. + * generated/maxloc1_8_r8.c: Regenerate. + * generated/minval_i16.c: Regenerate. + * generated/reshape_r10.c: Regenerate. + * generated/exponent_r10.c: Regenerate. + * generated/maxval_i4.c: Regenerate. + * generated/any_l4.c: Regenerate. + * generated/minval_i8.c: Regenerate. + * generated/maxloc1_4_i8.c: Regenerate. + * generated/fraction_r10.c: Regenerate. + * generated/maxloc0_16_i16.c: Regenerate. + * generated/shape_i4.c: Regenerate. + * generated/pow_r16_i8.c: Regenerate. + * generated/maxloc0_8_r4.c: Regenerate. + * generated/rrspacing_r8.c: Regenerate. + * generated/pow_c10_i4.c: Regenerate. + * generated/minloc1_4_i16.c: Regenerate. + * generated/minloc0_4_r10.c: Regenerate. + * generated/maxloc1_4_i16.c: Regenerate. + * generated/minloc0_8_i16.c: Regenerate. + * generated/maxloc0_4_r10.c: Regenerate. + * generated/maxloc0_8_i16.c: Regenerate. + * generated/minloc1_8_r10.c: Regenerate. + * generated/product_i4.c: Regenerate. + * generated/minloc0_16_r4.c: Regenerate. + * generated/sum_c16.c: Regenerate. + * generated/maxloc1_8_r10.c: Regenerate. + * generated/maxloc0_16_r4.c: Regenerate. + * generated/transpose_c10.c: Regenerate. + * generated/minloc1_16_r8.c: Regenerate. + * generated/minloc0_8_i1.c: Regenerate. + * generated/maxloc0_4_i4.c: Regenerate. + * generated/transpose_r4.c: Regenerate. + * generated/maxloc1_16_r8.c: Regenerate. + * generated/pow_i16_i8.c: Regenerate. + * generated/cshift1_4.c: Regenerate. + * generated/maxloc0_8_i2.c: Regenerate. + * generated/sum_r10.c: Regenerate. + * generated/nearest_r16.c: Regenerate. + * generated/sum_c4.c: Regenerate. + * generated/maxloc1_16_r10.c: Regenerate. + * generated/count_4_l16.c: Regenerate. + * generated/pow_c8_i8.c: Regenerate. + * generated/matmul_i8.c: Regenerate. + * generated/in_pack_i4.c: Regenerate. + * generated/pow_i4_i8.c: Regenerate. + * generated/minloc0_16_i2.c: Regenerate. + * generated/minloc1_8_r8.c: Regenerate. + * generated/maxloc0_16_i2.c: Regenerate. + * generated/exponent_r4.c: Regenerate. + * generated/spacing_r10.c: Regenerate. + * generated/matmul_c16.c: Regenerate. + * generated/pow_c4_i16.c: Regenerate. + * generated/maxval_r10.c: Regenerate. + * generated/count_4_l4.c: Regenerate. + * generated/shape_i16.c: Regenerate. + * generated/minval_i1.c: Regenerate. + * generated/maxloc1_4_i1.c: Regenerate. + * generated/matmul_r10.c: Regenerate. + * generated/minloc1_4_i8.c: Regenerate. + * generated/pow_r10_i8.c: Regenerate. + * generated/minloc0_8_r4.c: Regenerate. + * generated/in_unpack_c4.c: Regenerate. + * generated/matmul_l4.c: Regenerate. + * generated/product_i16.c: Regenerate. + * generated/minloc0_16_r16.c: Regenerate. + * generated/reshape_r8.c: Regenerate. + * generated/pow_r10_i16.c: Regenerate. + * generated/all_l4.c: Regenerate. + * generated/in_pack_c10.c: Regenerate. + * generated/minloc0_4_i4.c: Regenerate. + * generated/minloc0_8_i2.c: Regenerate. + * generated/matmul_i1.c: Regenerate. + * generated/reshape_c10.c: Regenerate. + * generated/minval_r4.c: Regenerate. + * generated/maxloc1_4_r4.c: Regenerate. + * generated/pow_r8_i16.c: Regenerate. + * generated/sum_i4.c: Regenerate. + * generated/maxval_r8.c: Regenerate. + * generated/count_16_l8.c: Regenerate. + * generated/transpose_c4.c: Regenerate. + * generated/eoshift1_4.c: Regenerate. + * generated/eoshift3_8.c: Regenerate. + * generated/minval_r16.c: Regenerate. + * generated/minloc1_4_i1.c: Regenerate. + * generated/minval_i2.c: Regenerate. + * generated/maxloc1_4_i2.c: Regenerate. + * generated/pow_i8_i16.c: Regenerate. + * generated/product_r8.c: Regenerate. + * generated/maxloc1_8_i8.c: Regenerate. + * generated/maxloc0_4_r8.c: Regenerate. + * generated/maxloc0_16_r16.c: Regenerate. + * generated/in_unpack_i4.c: Regenerate. + * generated/matmul_r4.c: Regenerate. + * generated/sum_c10.c: Regenerate. + * generated/minloc1_4_r16.c: Regenerate. + * generated/fraction_r8.c: Regenerate. + * generated/maxloc1_4_r16.c: Regenerate. + * generated/set_exponent_r4.c: Regenerate. + * generated/minloc0_8_r16.c: Regenerate. + * generated/in_unpack_c16.c: Regenerate. + * generated/reshape_c8.c: Regenerate. + * generated/maxloc0_8_r16.c: Regenerate. + * generated/nearest_r10.c: Regenerate. + * generated/maxloc0_8_i4.c: Regenerate. + * generated/pow_c4_i4.c: Regenerate. + * generated/matmul_i2.c: Regenerate. + * generated/minloc1_4_r4.c: Regenerate. + * generated/transpose_i16.c: Regenerate. + * generated/matmul_c10.c: Regenerate. + * generated/minloc0_16_i4.c: Regenerate. + * generated/maxloc0_16_i4.c: Regenerate. + * generated/pow_i8_i8.c: Regenerate. + * generated/nearest_r4.c: Regenerate. + * generated/minloc1_16_i8.c: Regenerate. + * generated/maxloc1_16_i8.c: Regenerate. + * generated/transpose_i4.c: Regenerate. + * generated/count_8_l4.c: Regenerate. + * generated/minloc1_4_i2.c: Regenerate. + * generated/matmul_l16.c: Regenerate. + * generated/maxloc1_8_i1.c: Regenerate. + * generated/minloc0_16_r10.c: Regenerate. + * generated/minloc1_8_i8.c: Regenerate. + * generated/minloc0_4_r8.c: Regenerate. + * generated/product_r16.c: Regenerate. + * generated/product_c8.c: Regenerate. + * generated/pow_r16_i16.c: Regenerate. + * generated/sum_r8.c: Regenerate. + * generated/pow_c16_i8.c: Regenerate. + * generated/in_pack_i16.c: Regenerate. + * generated/minloc0_8_i4.c: Regenerate. + * generated/matmul_c4.c: Regenerate. + * generated/minloc1_16_i16.c: Regenerate. + * generated/reshape_i8.c: Regenerate. + * generated/spacing_r8.c: Regenerate. + * generated/in_pack_c8.c: Regenerate. + * generated/maxloc1_8_r4.c: Regenerate. + * generated/minloc1_16_i1.c: Regenerate. + * generated/maxloc1_16_i1.c: Regenerate. + * generated/reshape_i16.c: Regenerate. + * generated/minval_r10.c: Regenerate. + * generated/pow_r4_i8.c: Regenerate. + * generated/minloc1_8_i1.c: Regenerate. + * generated/minval_i4.c: Regenerate. + * generated/maxloc1_4_i4.c: Regenerate. + * generated/maxloc1_8_i2.c: Regenerate. + * generated/maxval_i8.c: Regenerate. + * generated/eoshift3_16.c: Regenerate. + * generated/any_l8.c: Regenerate. + * generated/maxloc0_16_r10.c: Regenerate. + * generated/rrspacing_r4.c: Regenerate. + * generated/shape_i8.c: Regenerate. + * generated/maxloc0_8_r8.c: Regenerate. + * generated/minloc0_4_i16.c: Regenerate. + * generated/maxloc0_4_i16.c: Regenerate. + * generated/minloc1_4_r10.c: Regenerate. + * generated/minloc1_8_i16.c: Regenerate. + * generated/pow_c10_i8.c: Regenerate. + * generated/maxloc1_4_r10.c: Regenerate. + * generated/maxloc1_8_i16.c: Regenerate. + * generated/in_unpack_c10.c: Regenerate. + * generated/minloc0_8_r10.c: Regenerate. + * generated/maxloc0_8_r10.c: Regenerate. + * generated/minloc1_16_r4.c: Regenerate. + * generated/maxloc1_16_r4.c: Regenerate. + * generated/minloc0_16_r8.c: Regenerate. + * generated/pow_i16_i4.c: Regenerate. + * generated/product_i8.c: Regenerate. + * generated/maxloc0_16_r8.c: Regenerate. + * generated/sum_i16.c: Regenerate. + * generated/maxloc0_4_i8.c: Regenerate. + * generated/transpose_r8.c: Regenerate. + * generated/cshift1_8.c: Regenerate. + * generated/maxloc1_16_i16.c: Regenerate. + * generated/matmul_i4.c: Regenerate. + * generated/pow_c8_i4.c: Regenerate. + * generated/pow_i4_i4.c: Regenerate. + * generated/minloc1_8_r4.c: Regenerate. + * generated/sum_c8.c: Regenerate. + * generated/count_8_l16.c: Regenerate. + * generated/minloc1_16_i2.c: Regenerate. + * generated/maxloc1_16_i2.c: Regenerate. + * generated/in_pack_i8.c: Regenerate. + * generated/transpose_r16.c: Regenerate. + * generated/maxval_i16.c: Regenerate. + * generated/exponent_r8.c: Regenerate. + * generated/matmul_i16.c: Regenerate. + * generated/count_4_l8.c: Regenerate. + * generated/pow_c8_i16.c: Regenerate. + * generated/maxval_i1.c: Regenerate. + * generated/minloc1_4_i4.c: Regenerate. + * generated/minloc1_8_i2.c: Regenerate. + * generated/pow_c10_i16.c: Regenerate. + * generated/product_c16.c: Regenerate. + * generated/reshape_r4.c: Regenerate. + * generated/in_unpack_c8.c: Regenerate. + * generated/minloc0_8_r8.c: Regenerate. + * generated/matmul_l8.c: Regenerate. + * generated/product_r10.c: Regenerate. + * generated/set_exponent_r16.c: Regenerate. + * generated/cshift1_16.c: Regenerate. + * generated/product_i1.c: Regenerate. + * generated/all_l8.c: Regenerate. + * generated/maxloc0_4_i1.c: Regenerate. + * generated/rrspacing_r16.c: Regenerate. + * generated/minloc0_4_i8.c: Regenerate. + * generated/pow_r4_i16.c: Regenerate. + * generated/count_16_l4.c: Regenerate. + * generated/maxval_r4.c: Regenerate. + +2007-08-30 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/33225 + * io/write.c: Revert changes from patch of 2007-08-27. + * io/write_float.def: Remove file, reverting addition. + +2007-08-29 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * runtime/memory.c (internal_realloc, allocate, allocate_array, + deallocate): Remove functions. + * gfortran.map (_gfortran_allocate, _gfortran_allocate_array, + _gfortran_deallocate, _gfortran_internal_realloc): Remove symbols. + * libgfortran.h (error_codes): Add comment. + +2007-08-28 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/33055 + Revert previous patch. + +2007-08-27 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + * io/write.c (stdbool.h): Add include. (sign_t): Move typedef to + new file write_float.def. Include write_float.def. + (extract_real): Delete. (calculate_sign): Delete. + (calculate_exp): Delete. (calculate_G_format): Delete. + (output_float): Delete. (write_float): Delete. + * io/write_float.def (calculate_sign): Added. + (output_float): Refactored to be independent of kind and added to this + file for inclusion. (write_infnan): New function to write "Infinite" + or "NaN" depending on flags passed, independent of kind. + (CALCULATE_EXP): New macro to build kind specific functions. Use it. + (OUTPUT_FLOAT_FMT_G): New macro, likewise. Use it. + (DTOA, DTOAL): Macros to implement "decimal to ascii". + (WRITE_FLOAT): New macro for kind specific write_float functions. + (write_float): Revised function to determine kind and use WRITE_FLOAT + to implement kind specific output. + +2007-08-26 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/33055 + * io/inquire.c (inquire_via_unit): If inquiring by unit, check for + an error condition from the IOSTAT variable and set EXIST to false if + there was a bad unit number. + +2007-08-24 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/32972 + * libgfortran.h: Remove GFOR_POINTER_L8_TO_L4 macro. + Add GFOR_POINTER_TO_L1 macro. + * m4/iforeach.m4(`m'name`'rtype_qual`_'atype_code): + Change argument 'mask' to gfc_array_l1. Adjust prototype. + Change mask pointer to GFC_LOGICAL_1. Multiply strides + by kind of mask + * m4/ifunction.m4: Likewise. + * intrinsics/pack_generic.c(pack_internal): Likewise. + * intrinsics/unpack_generic.c(unpack_internal): Likewise. + * m4/matmull.m4: Switch to GFC_LOGICAL_1. Multiply strides by + kind of logical arguments a and b. + * generated/matmul_l16.c: Regenerated. + * generated/matmul_l4.c: Regenerated. + * generated/matmul_l8.c: Regenerated. + * generated/maxloc0_16_i1.c: Regenerated. + * generated/maxloc0_16_i16.c: Regenerated. + * generated/maxloc0_16_i2.c: Regenerated. + * generated/maxloc0_16_i4.c: Regenerated. + * generated/maxloc0_16_i8.c: Regenerated. + * generated/maxloc0_16_r10.c: Regenerated. + * generated/maxloc0_16_r16.c: Regenerated. + * generated/maxloc0_16_r4.c: Regenerated. + * generated/maxloc0_16_r8.c: Regenerated. + * generated/maxloc0_4_i1.c: Regenerated. + * generated/maxloc0_4_i16.c: Regenerated. + * generated/maxloc0_4_i2.c: Regenerated. + * generated/maxloc0_4_i4.c: Regenerated. + * generated/maxloc0_4_i8.c: Regenerated. + * generated/maxloc0_4_r10.c: Regenerated. + * generated/maxloc0_4_r16.c: Regenerated. + * generated/maxloc0_4_r4.c: Regenerated. + * generated/maxloc0_4_r8.c: Regenerated. + * generated/maxloc0_8_i1.c: Regenerated. + * generated/maxloc0_8_i16.c: Regenerated. + * generated/maxloc0_8_i2.c: Regenerated. + * generated/maxloc0_8_i4.c: Regenerated. + * generated/maxloc0_8_i8.c: Regenerated. + * generated/maxloc0_8_r10.c: Regenerated. + * generated/maxloc0_8_r16.c: Regenerated. + * generated/maxloc0_8_r4.c: Regenerated. + * generated/maxloc0_8_r8.c: Regenerated. + * generated/maxloc1_16_i1.c: Regenerated. + * generated/maxloc1_16_i16.c: Regenerated. + * generated/maxloc1_16_i2.c: Regenerated. + * generated/maxloc1_16_i4.c: Regenerated. + * generated/maxloc1_16_i8.c: Regenerated. + * generated/maxloc1_16_r10.c: Regenerated. + * generated/maxloc1_16_r16.c: Regenerated. + * generated/maxloc1_16_r4.c: Regenerated. + * generated/maxloc1_16_r8.c: Regenerated. + * generated/maxloc1_4_i1.c: Regenerated. + * generated/maxloc1_4_i16.c: Regenerated. + * generated/maxloc1_4_i2.c: Regenerated. + * generated/maxloc1_4_i4.c: Regenerated. + * generated/maxloc1_4_i8.c: Regenerated. + * generated/maxloc1_4_r10.c: Regenerated. + * generated/maxloc1_4_r16.c: Regenerated. + * generated/maxloc1_4_r4.c: Regenerated. + * generated/maxloc1_4_r8.c: Regenerated. + * generated/maxloc1_8_i1.c: Regenerated. + * generated/maxloc1_8_i16.c: Regenerated. + * generated/maxloc1_8_i2.c: Regenerated. + * generated/maxloc1_8_i4.c: Regenerated. + * generated/maxloc1_8_i8.c: Regenerated. + * generated/maxloc1_8_r10.c: Regenerated. + * generated/maxloc1_8_r16.c: Regenerated. + * generated/maxloc1_8_r4.c: Regenerated. + * generated/maxloc1_8_r8.c: Regenerated. + * generated/maxval_i1.c: Regenerated. + * generated/maxval_i16.c: Regenerated. + * generated/maxval_i2.c: Regenerated. + * generated/maxval_i4.c: Regenerated. + * generated/maxval_i8.c: Regenerated. + * generated/maxval_r10.c: Regenerated. + * generated/maxval_r16.c: Regenerated. + * generated/maxval_r4.c: Regenerated. + * generated/maxval_r8.c: Regenerated. + * generated/minloc0_16_i1.c: Regenerated. + * generated/minloc0_16_i16.c: Regenerated. + * generated/minloc0_16_i2.c: Regenerated. + * generated/minloc0_16_i4.c: Regenerated. + * generated/minloc0_16_i8.c: Regenerated. + * generated/minloc0_16_r10.c: Regenerated. + * generated/minloc0_16_r16.c: Regenerated. + * generated/minloc0_16_r4.c: Regenerated. + * generated/minloc0_16_r8.c: Regenerated. + * generated/minloc0_4_i1.c: Regenerated. + * generated/minloc0_4_i16.c: Regenerated. + * generated/minloc0_4_i2.c: Regenerated. + * generated/minloc0_4_i4.c: Regenerated. + * generated/minloc0_4_i8.c: Regenerated. + * generated/minloc0_4_r10.c: Regenerated. + * generated/minloc0_4_r16.c: Regenerated. + * generated/minloc0_4_r4.c: Regenerated. + * generated/minloc0_4_r8.c: Regenerated. + * generated/minloc0_8_i1.c: Regenerated. + * generated/minloc0_8_i16.c: Regenerated. + * generated/minloc0_8_i2.c: Regenerated. + * generated/minloc0_8_i4.c: Regenerated. + * generated/minloc0_8_i8.c: Regenerated. + * generated/minloc0_8_r10.c: Regenerated. + * generated/minloc0_8_r16.c: Regenerated. + * generated/minloc0_8_r4.c: Regenerated. + * generated/minloc0_8_r8.c: Regenerated. + * generated/minloc1_16_i1.c: Regenerated. + * generated/minloc1_16_i16.c: Regenerated. + * generated/minloc1_16_i2.c: Regenerated. + * generated/minloc1_16_i4.c: Regenerated. + * generated/minloc1_16_i8.c: Regenerated. + * generated/minloc1_16_r10.c: Regenerated. + * generated/minloc1_16_r16.c: Regenerated. + * generated/minloc1_16_r4.c: Regenerated. + * generated/minloc1_16_r8.c: Regenerated. + * generated/minloc1_4_i1.c: Regenerated. + * generated/minloc1_4_i16.c: Regenerated. + * generated/minloc1_4_i2.c: Regenerated. + * generated/minloc1_4_i4.c: Regenerated. + * generated/minloc1_4_i8.c: Regenerated. + * generated/minloc1_4_r10.c: Regenerated. + * generated/minloc1_4_r16.c: Regenerated. + * generated/minloc1_4_r4.c: Regenerated. + * generated/minloc1_4_r8.c: Regenerated. + * generated/minloc1_8_i1.c: Regenerated. + * generated/minloc1_8_i16.c: Regenerated. + * generated/minloc1_8_i2.c: Regenerated. + * generated/minloc1_8_i4.c: Regenerated. + * generated/minloc1_8_i8.c: Regenerated. + * generated/minloc1_8_r10.c: Regenerated. + * generated/minloc1_8_r16.c: Regenerated. + * generated/minloc1_8_r4.c: Regenerated. + * generated/minloc1_8_r8.c: Regenerated. + * generated/minval_i1.c: Regenerated. + * generated/minval_i16.c: Regenerated. + * generated/minval_i2.c: Regenerated. + * generated/minval_i4.c: Regenerated. + * generated/minval_i8.c: Regenerated. + * generated/minval_r10.c: Regenerated. + * generated/minval_r16.c: Regenerated. + * generated/minval_r4.c: Regenerated. + * generated/minval_r8.c: Regenerated. + * generated/product_c10.c: Regenerated. + * generated/product_c16.c: Regenerated. + * generated/product_c4.c: Regenerated. + * generated/product_c8.c: Regenerated. + * generated/product_i1.c: Regenerated. + * generated/product_i16.c: Regenerated. + * generated/product_i2.c: Regenerated. + * generated/product_i4.c: Regenerated. + * generated/product_i8.c: Regenerated. + * generated/product_r10.c: Regenerated. + * generated/product_r16.c: Regenerated. + * generated/product_r4.c: Regenerated. + * generated/product_r8.c: Regenerated. + * generated/sum_c10.c: Regenerated. + * generated/sum_c16.c: Regenerated. + * generated/sum_c4.c: Regenerated. + * generated/sum_c8.c: Regenerated. + * generated/sum_i1.c: Regenerated. + * generated/sum_i16.c: Regenerated. + * generated/sum_i2.c: Regenerated. + * generated/sum_i4.c: Regenerated. + * generated/sum_i8.c: Regenerated. + * generated/sum_r10.c: Regenerated. + * generated/sum_r16.c: Regenerated. + * generated/sum_r4.c: Regenerated. + * generated/sum_r8.c: Regenerated. + +2007-08-23 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR libfortran/23138 + * acinclude.m4 (LIBGFOR_CHECK_MINGW_SNPRINTF): New check. + * configure.ac: Use LIBGFOR_CHECK_MINGW_SNPRINTF. + * libgfortran.h: If HAVE_MINGW_SNPRINTF is true, use __mingw_snprintf + instead of snprintf. + * config.h.in: Regenerate. + * configure: Regenerate. + +2007-08-22 Bernhard Fischer <rep.dot.nop@gmail.com> + + * libgfortran/Makefile.am (AM_CPPFLAGS): Commentary typo fix. + +2007-08-17 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/33079 + * intrinsics/string_intrinsics.c (string_trim, string_minmax): Fix + the zero-length result case. + +2007-08-15 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/33077 + * intrinsics/random.c (random_seed_i8): Fix code logic. + +2007-08-13 Danny Smith <dannysmit@users.sourceforge.net> + + * acinclude.m4 (GTHREAD_USE_WEAK) Define to 0 for mingw32. + * configure: Regenerate. + +2007-08-12 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/30964 + PR fortran/33054 + * intrinsics/random.c (random_seed): Rename into random_seed_i4. + (random_seed_i8): New function. + * gfortran.map (GFORTRAN_1.0): Remove _gfortran_random_seed, + add _gfortran_random_seed_i4 and _gfortran_random_seed_i8. + * libgfortran.h (iexport_proto): Replace random_seed by + random_seed_i4 and random_seed_i8. + * runtime/main.c (init): Call the new random_seed_i4. + +2007-08-11 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + Tobias Burnus <burnus@gcc.gnu.org> + + PR fortran/31189 + * runtime/backtrace.c (show_backtrace): Skip _gfortrani_handler + when displaying backtrace. + * runtime/compile_options.c: Include <signal.h>. + (handler): New function. + (set_options): Set signal handlers for backtrace. + * libgfortran.h (handler): Add prototype. + +2007-08-11 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * intrinsics/string_intrinsics.c (compare_string): Return an int. + * libgfortran.h (compare_string): Likewise. + +2007-08-10 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/31270 + * runtime/error.c (runtime_error_at): Add a variable number of + arguments. + * libgfortran.h (runtime_error_at): Update prototype. + +2007-08-10 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/32933 + * intrinsics/associated.c: Change return type of associated into + a C int. + +2007-08-10 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/33039 + * io/list_read.c (find_nml_name): Check for a space after a namelist + name match. + +2007-08-09 Tobias Burnus <burnus@net-b.de> + + PR fortran/32987 + * io/format.c (next_char): Treat '\t' as ' ' in format specification. + +2007-08-06 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/30947 + * intrinsics/signal.c: Create specific versions of alarm_sub and + alarm_sub_int according to the integer kind of the last argument. + * gfortran.map (GFORTRAN_1.0): Remove _gfortran_alarm_sub and + _gfortran_alarm_sub_int, add _gfortran_alarm_sub_i4, + _gfortran_alarm_sub_i8, _gfortran_alarm_sub_int_i4 and + _gfortran_alarm_sub_int_i8. + +2007-08-06 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/29828 + * intrinsics/string_intrinsics.c (string_minmax): New function + and prototype. + * gfortran.map (GFORTRAN_1.0): Add _gfortran_string_minmax + +2007-08-05 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/31202 + * intrinsics/c99_functions.c (roundl): Provide fallback + implementation for systems without ceill. + * c99_protos.h (roundl): Define prototype in all cases. + +2007-08-03 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/32977 + * io/unix.c: If there is no vsnprintf, use vsprintf and issue + a fatal error when a buffer overrun occurs. + +2007-08-03 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/31202 + * intrinsics/c99_functions.c (roundl,lroundf,lround,lroundl, + llroundf,llround,llroundl): New functions. + * c99_protos.h (roundl,lroundf,lround,lroundl,llroundf,llround, + llroundl): New prototypes. + * configure.ac: Check for lroundf, lround, lroundl, llroundf, + llround and llroundl. + * configure: Regenerate. + * Makefile.in: Regenerate. + * config.h.in: Regenerate. + +2007-07-30 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * libgfortran.h: Include <stdarg.h>. + +2007-07-29 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/32858 + PR libfortran/30814 + * configure.ac: Added checks for presence of stdio.h and + stdarg.h. Test presence of vsnprintf(). + * configure: Regenerated. + * config.h.in: Regenerated. + * libgfortran.h: Include <stdio.h>. Add printf attribute to + prototype of runtime_error. Remove prototype for st_sprintf. + Add prototype for st_vprintf. + * runtime/main.c (store_exec_path): Replace st_sprintf by sprintf. + * runtime/error.c (st_sprintf): Remove. + (runtime_error): Rewrite as a variadic function. Call + st_vprintf(). + * intrinsics/pack_generic.c: Output extents of LHS and RHS for + bounds error. + * io/open.c (new_unit): Replace st_sprintf by sprintf. + * io/list_read.c (convert_integer): Likewise. + (parse_repeat): Likewise. + (read_logical): Likewise. + (read_character): Likewise. + (parse_real): Likewise. + (read_real): Likewise. + (check_type): Likewise. + (nml_parse_qualifyer): Likewise. + (nml_read_obj): Likewise. + (nml_get_ojb_data): Likewise. + * io/unix.c (init_error_stream): Remove. + (tempfile): Replace st_sprintf by sprintf. + (st_vprintf): New function. + (st_printf): Rewrite to call st_vprintf. + * io/transfer.c (require_type): Replace st_sprintf by sprintf. + * io/format.c (format_error): Likewise. + * io/write.c (nml_write_obj): Likewise. + +2007-07-27 Janne Blomqvist <jb@gcc.gnu.org> + + * io/transfer.c (st_set_nml_var_dim): Use index_type instead of + GFC_INTEGER_4 for array descriptor triplets. + +2007-07-27 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * io/unix.c (stream_ttyname): Mark argument as potentialy unused. + +2007-07-27 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/32035 + * runtime/select.c (select_string): Adjust prototype and function + so that the return value is an integer, not a pointer. + +2007-07-24 Tobias Burnus <burnus@net-b.de> + + * libgfortran.h: Add bounds_check to compile_options_t. + +2007-07-24 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/30814 + * libgfortran.h: Add bounds_check to compile_options_t. + * runtime/compile_options.c (set_options): Add handling + of compile_options.bounds_check. + * intrinsics/pack_generic.c (pack_internal): Also determine + the number of elements if compile_options.bounds_check is + true. Raise runtime error if a different array shape is + detected. + +2007-07-23 Christopher D. Rickett <crickett@lanl.gov> + + PR fortran/32600 + * intrinsics/iso_c_binding.c (c_funloc): Remove. + * intrinsics/iso_c_binding.h: Remove c_funloc. + * gfortran.map: Ditto. + +2007-07-22 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + * io/read.c (convert_real): Generate error only on EINVAL. + +2007-07-21 Christopher D. Rickett <crickett@lanl.gov> + + PR fortran/32627 + * libgfortran/intrinsics/iso_c_generated_procs.c: Add c_f_pointer + for character/string arguments. + * libgfortran/intrinsic/iso_c_binding.c (c_f_pointer_u0): Allow + the optional SHAPE arg to be any valid integer kind. + * libgfortran/gfortran.map: Add c_f_pointer_s0. + * libgfortran/mk-kinds-h.sh: Save smallest integer kind as default + character kind. + * libgfortran/intrinsics/iso_c_generated_procs.c: Add versions of + c_f_pointer for complex and logical types. + * libgfortran/gfortran.map: Add c_f_pointer versions for logical + and complex types. + +2007-07-19 Christopher D. Rickett <crickett@lanl.gov> + + PR fortran/32600 + * libgfortran/intrinsics/iso_c_binding.c: Remove C_LOC. + * libgfortran/intrinsics/iso_c_binding.h: Ditto. + * libgfortran/gfortran.map: Ditto. + +2007-07-15 Jerry DeLisle <jvdelisle@gcc.gnu.org> + Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/32611 + * runtime/compile_options.c (set_std): Remove. + (set_options): New function. + (init_compile_options): Add initialization for -fsign-zero option. + * gfortran.map (GFORTRAN_1.0): Rename _gfortran_set_std into + _gfortran_set_options. + * libgfortran.h (compile_options_t): Add sign_zero field. + * io/write.c (output_float): Use the sign bit of the value to determine + if a negative sign should be emitted for zero values. Do not emit the + negative sign for zero if -fno-sign-zero was set during compile. + +2007-07-14 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libgfortran/32752 + * io/unix.c (unix_stream): Move buffer pointer adjacent to + small_buffer. + * io/transfer.c (formatted_transfer_scalar): If stream I/O, set + bytes_used to zero. Fix off by one error in calculation of pos and + skips. Eliminate duplicate pending_spaces check. + +2007-07-15 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/32357 + * intrinsics/mvbits.c: Change prototype so that FROMPOS, LEN and + TOPOS arguments are C int. + +2007-07-09 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libgfortran/32702 + * io/unix.c (unix_stream): Restore buffer pointer and small_buffer. + (fd_alloc): If the number of bytes needed is greater than the default + BUFFER_SIZE, allocate a new buffer large enough. Free the old buffer + if necessary. (fd_sfree): Restore use of buffer pointer. + (fd_close): Likewise. (fd_open): Likewise. + (init_error_stream): Likewise. + +2007-07-09 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/32336 + * m4/matmul.m4: When the dimension of b is incorrect, + raise a runtime error instead of a failed assertion. + * generated/matmul_i1.c: Regenerated. + * generated/matmul_i2.c: Regenerated. + * generated/matmul_i4.c: Regenerated. + * generated/matmul_i8.c: Regenerated. + * generated/matmul_i16.c: Regenerated. + * generated/matmul_r4.c: Regenerated. + * generated/matmul_r8.c: Regenerated. + * generated/matmul_r10.c: Regenerated. + * generated/matmul_r16.c: Regenerated. + +2007-07-08 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libgfortran/32678 + * io/transfer.c (formatted_transfer_scalar): Don't allow + pending_spaces to go negative. + +2007-07-08 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/32217 + * intrinsics/unpack_generic.c: If the destination array is + empty, return early. + +2007-07-05 H.J. Lu <hongjiu.lu@intel.com> + + * aclocal.m4: Regenerated. + +2007-07-04 David Edelsohn <edelsohn@gnu.org> + + * configure.ac: SUBST CFLAGS. + * configure: Regenerate. + +2007-07-03 Janne Blomqvist <jb@gcc.gnu.org> + + * libgfortran.h: Mark internal_malloc_size as a malloc function. + * runtime/memory.c (internal_realloc_size): Remove. + (internal_realloc): Call realloc directly instead of + internal_realloc_size. + (allocate_size): Remove. + (allocate): Call malloc directly instead of allocate_size, mark as + malloc function. + +2007-07-02 Steven G. Kargl <kargl@gcc.gnu.org> + + Restore collateral damage from ISO C Binding merge. + +2007-06-29 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libgfortran/32456 + * io/unit.c (filename_from_unit): Don't use find_unit, instead search + for unit directly. + +2007-07-02 Steven G. Kargl <kargl@gcc.gnu.org> + + * Makefile.in: Regenerated with automake 1.9.6. + +2007-07-02 Steven G. Kargl <kargl@gcc.gnu.org> + + * Makefile.in: Remove extraneous kill.lo rule. + +2007-07-02 Janne Blomqvist <jb@gcc.gnu.org> + + PR fortran/32239 + * generated/pow_r*_i4.c: Removed. + +2007-07-01 Christopher D. Rickett <crickett@lanl.gov> + + * Makefile.in: Add support for iso_c_generated_procs.c and + iso_c_binding.c. + * Makefile.am: Ditto. + * intrinsics/iso_c_generated_procs.c: New file containing helper + functions. + * intrinsics/iso_c_binding.c: Ditto. + * intrinsics/iso_c_binding.h: New file + * gfortran.map: Include the __iso_c_binding_c_* functions. + * libgfortran.h: define GFC_NUM_RANK_BITS. + +2007-07-01 Janne Blomqvist <jb@gcc.gnu.org> + + PR fortran/32239 + * Makefile.am: Don't generate real**int4 pow functions. + * gfortran.map: Remove real**int4 pow symbols. + * Makefile.in: Regenerated. + +2007-07-01 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libgfortran/32554 + * io/write.c (output_float): Set edigits to a fixed size, avoiding + variation in field width calculation and eliminate buffer overrun. + +2007-07-01 Janne Blomqvist <jb@gcc.gnu.org> + + * runtime/memory.c (internal_realloc): Use index_type for size + argument instead of GFC_INTEGER_4. + (allocate_array): Likewise. + (allocate): Likewise, add ifdef around unnecessary check. + (internal_reallo64): Remove. + (allocate_array64): Remove. + (allocate64): Remove. + * gfortran.map: Remove symbols for 64-bit allocation functions. + +2007-06-29 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libgfortran/32456 + * io/unit.c (filename_from_unit): Don't use find_unit, instead search + for unit directly. + +2007-06-24 Adam Nemet <anemet@caviumnetworks.com> + + PR libfortran/32495 + * runtime/backtrace.c (local_strcasestr): Rename from strcasestr. + (show_backtrace): Rename strcasestr to local_strcasestr. + +2007-06-24 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libgfortran/32456 + * runtime/error.c (show_locus): Update to emit the unit number + and file name involved with the error. Use new function + filename_from_unit. + * libgfortran.h (filename_from_unit): Declare new function. + * io/unit.c (init_units): Set the unit file name for stdin, stdout, + and stderr for use later in error reporting. + (filename_from_unit): Add this new function. + +2007-06-24 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libgfortran/32446 + * io/write.c (output_float): Calculate ndigits correctly for large + numbered formats that must pad zeros before the decimal point. + +2007-06-15 Rainer Orth <ro@TechFak.Uni-Bielefeld.DE> + + PR libfortran/32345 + * runtime/backtrace.c (show_backtrace): Only use snprintf if + available. + +2007-06-10 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libgfortran/32235 + * io/transfer.c (st_read): Remove test for end of file condition. + (next_record_r): Add test for end of file condition. + +2007-06-02 Paolo Bonzini <bonzini@gnu.org> + + * configure: Regenerate. + +2007-05-28 Tobias Burnus <burnus@net-b.de> + + PR fortran/32124 + * runtime/memory.c (allocate_size): Use ERROR_ALLOCATION. + (allocate,allocate64): Use stat variable if present. + +2007-05-27 Janne Blomqvist <jb@gcc.gnu.org> + + * runtime/string.c (compare0): Use gfc_charlen_type instead of + int. + (fstrlen): Likewise. + (find_option): Likewise. + (fstrcpy): Use gfc_charlen_type instead of int, return length. + (cf_strcpy): Likewise. + * libgfortran.h: Change string prototypes to use gfc_charlen_type. + * io/open.c (new_unit): Use snprintf if available. + * io/list_read.c (nml_touch_nodes): Use memcpy instead of + strcpy/strcat. + (nml_read_obj): Likewise. + * io/transfer.c (st_set_nml_var): Likewise. + * io/write.c (output_float): Use snprintf if available. + (nml_write_obj) Use memcpy instead of strcpy/strcat. + +2007-05-26 Janne Blomqvist <jb@gcc.gnu.org> + + * io/unix.c (unix_stream): Rearrange struct members, remove + small_buffer. + (int_stream): New struct. + (fd_alloc): Always use existing buffer, never reallocate. + (fd_sfree): Remove check for buffer != small_buffer. + (fd_close): Likewise. + (mem_alloc_r_at): Change to use int_stream. + (mem_alloc_w_at): Likewise. + (mem_read): Likewise. + (mem_write): Likewise. + (mem_set): Likewise. + (mem_truncate): Likewise. + (mem_close): Likewise. + (mem_sfree): Likewise. + (empty_internal_buffer): Likewise. + (open_internal): Likewise. + +2007-05-25 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + * io/transfer.c (unformatted_read): Use size from front end + eliminating use of size_from_real_kind. + (unformatted_write): Ditto. + +2007-05-23 Steve Ellcey <sje@cup.hp.com> + + * Makefile.in: Regenerate. + * configure: Regenerate. + * aclocal.m4: Regenerate. + +2007-05-22 Tobias Burnus <burnus@net-b.de> + + * libgfortran.h: Mark stop_numeric as noreturn. + +2007-05-22 Tobias Burnus <burnus@net-b.de> + + PR libgfortran/31295 + * intrinsics/eoshift0.c (eoshift0): Silence uninitialized warning. + * intrinsics/eoshift2.c (eoshift2): Ditto. + +2007-05-18 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/31964 + * intrinsics/ishftc.c (ishftc4, ishftc8, ishftc16): Fix mask to handle + shift of bit-size number of bits. + +2007-05-17 Tobias Burnus <burnus@net-b.de> + + PR fortran/31917 + * runtime/environ.c (mark_range): Fix setting default convert unit. + +2007-05-15 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/31922 + * intrinsics/string_intrinsics.c (string_trim): Set result to null if + string length is zero. + +2007-05-15 Tobias Burnus <burnus@net-b.de> + + PR libfortran/31915 + * io/transfer.c (unformatted_read): Use proper size for real(10). + (unformatted_write): Ditto. + +2007-05-14 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/30723 + * runtime/memory.c (internal_malloc, internal_malloc64, + internal_free): Remove. + * runtime/error.c (os_error): Export function. + * intrinsics/move_alloc.c: Include stdlib.h. + (move_alloc): Call free instead of internal_free. + (move_alloc_c): Wrap long lines. + * libgfortran.h (os_error): Export prototype. + (internal_free): Remove prototype. + * gfortran.map (GFORTRAN_1.0): Remove _gfortran_internal_free, + _gfortran_internal_malloc and _gfortran_internal_malloc64. + Add _gfortran_os_error. + +2007-05-09 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/31880 + * io/unix.c (fd_alloc_r_at): Fix calculation of physical offset. + +2007-05-07 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR libfortran/31607 + * intrinsics/system.c (system_sub): Call flush_all_units. + * io/io.h (flush_all_units): Move prototype to libgfortran.h. + * libgfortran.h (flush_all_units): Add prototype. + +2007-05-06 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/31201 + * runtime/error.c (runtime_error_at): New function. + (generate_error): Export this function. + * gfortran.map: Add _gfortran_generate_error and + _gfortran_runtime_error_at. + * libgfortran.h: Add comment to reference error codes in front end. + (library_start): Locate prototype with library_end macro and add + a new comment. Add prototype for runtime_error_at. Export prototype + for generate_error. + * io/lock.c (library_start): Fix check for error condition. + * io/transfer.c (data_transfer_init): Add library check. + +2007-05-04 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/22359 + * io/intrinsics.c (fseek_sub): New. + * io/unix.c (fd_fseek): Change logical and physical offsets only + if seek succeeds. + * gfortran.map (fseek_sub): New. + +2007-05-04 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR libfortran/31210 + * io/transfer.c (transfer_character): Avoid passing a NULL + pointer as source to the transfer routines, if the string length + is zero. + +2007-04-28 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/31501 + * io/list_read.c (next_char): Fix whitespace. + * io/io.h: Remove prototypes and define macros for is_array_io, + is_stream_io, and is_internal_unit. + * io/unit.c (is_array_io), (is_internal_unit), (is_stream_io): Delete + these functions. + * io/transfer.c (read_sf): Change handling of internal_unit to make a + single call to salloc_r and use memcpy to transfer the data. + +2007-04-27 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/31532 + * io/file_pos.c (st_backspace): Set flags.position for end of file + condition and use new function update_position. + (st_endfile): Use new function update_position. + * io/io.h: Add prototype for new function. + * io/inquire.c (inquire_via_unit): If not direct access, set NEXTREC + to zero. + * io/unit.c (update_position): New function to update position info + used by inquire. + * io/transfer.c (next_record): Fix typo and use new function. + +2007-04-25 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR libfortran/31299 + * intrinsics/getlog.c: Use getpwuid and geteuid instead of + getlogin if they are available. + * configure.ac: Add checks for getpwuid and geteuid. + * configure: Regenerate. + * config.h.in: Regenerate. + +2007-04-25 Janne Blomqvist <jb@gcc.gnu.org> + + * configure: Regenerate using autoconf 2.59. + * Makefile.in: Likewise. + * config.h.in: Likewise. + +2007-04-24 Janne Blomqvist <jb@gcc.gnu.org> + + PR libfortran/27740 + * configure.ac: New test to determine if symbol versioning is + supported. + * Makefile.am: Use result of above test to add appropriate linker + flags. + * gfortran.map: New file. + * configure: Regenerated. + * Makefile.in: Regenerated. + * config.h.in: Regenerated. + +2007-04-23 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/31618 + * io/transfer.c (read_block_direct): Instead of calling us_read, + set dtp->u.p.current_unit->current_record = 0 so that pre_position + will read the record marker. + (data_transfer_init): For different error conditions, call + generate_error, then return. + +2007-04-19 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * runtime/main.c (please_free_exe_path_when_done): New variable. + (store_exe_path): Initialize character buffer, and mark whether + exe_path should be free'd by the library destructor function. + (cleanup): Only free exe_path if needed. + +2007-04-18 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + Tobias Burnus <burnus@net-b.de> + + PR libfortran/31286 + PR libfortran/31296 + * intrinsics/cshift0.c (cshift0): Initialize sstride[0] and rstride[0]. + * intrinsics/unpack_generic.c (unpack0, unpack0_char): Zero the + array structures we pass to unpack_internal. + +2007-04-14 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + * io/open.c (test_endfile): Revert changes for 31052, restoring this + function. + +2007-04-14 Steve Ellcey <sje@cup.hp.com> + + * Makefile.am: Add -I .. to ACLOCAL_AMFLAGS. Add libgfortran_la_LINK. + * Makefile.in: Regenerate. + +2007-04-11 Kai Tietz <kai.tietz@onevision.com> + + * configure: Regenerate. + +2007-04-06 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * intrinsics/cpu_time.c: Don't include headers already included + by libgfortran.h. Protect inclusion of sys/times.h. + * configure.ac: Remove unneeded checks for finit, stdio.h, + stddef.h, math.h and sys/params.h. + * config/fpu-aix.h: Don't include headers already included by + libgfortran.h. + * config/fpu-sysv.h: Likewise. + * io/write.c: Likewise. + * m4/minloc1.m4: Likewise. + * m4/maxloc1.m4: Likewise. + * m4/fraction.m4: Likewise. + * m4/set_exponent.m4: Likewise. + * m4/spacing.m4: Likewise. + * m4/minval.m4: Likewise. + * m4/maxval.m4: Likewise. + * m4/exponent.m4: Likewise. + * m4/nearest.m4: Likewise. + * m4/minloc0.m4: Likewise. + * m4/maxloc0.m4: Likewise. + * m4/rrspacing.m4: Likewise. + * runtime/main.c: Likewise. + * runtime/error.c: Likewise. + * intrinsics/system_clock.c: Likewise. + * intrinsics/etime.c: Likewise. + * intrinsics/stat.c: Likewise. + * intrinsics/date_and_time.c: Likewise. + * intrinsics/env.c: Likewise. + * intrinsics/kill.c: Likewise. + * intrinsics/getXid.c: Likewise. + * intrinsics/chmod.c: Likewise. + * intrinsics/args.c: Likewise. + * intrinsics/c99_functions.c: Likewise. + * generated/minval_r8.c: Regenerate. + * generated/maxloc1_4_r8.c: Regenerate. + * generated/minloc1_16_r16.c: Regenerate. + * generated/maxval_i2.c: Regenerate. + * generated/maxloc1_8_i4.c: Regenerate. + * generated/exponent_r16.c: Regenerate. + * generated/maxloc0_4_r4.c: Regenerate. + * generated/fraction_r16.c: Regenerate. + * generated/fraction_r4.c: Regenerate. + * generated/minloc0_4_r16.c: Regenerate. + * generated/minloc0_4_i1.c: Regenerate. + * generated/maxloc0_4_r16.c: Regenerate. + * generated/maxloc0_4_i2.c: Regenerate. + * generated/minloc1_8_r16.c: Regenerate. + * generated/maxloc1_8_r16.c: Regenerate. + * generated/set_exponent_r8.c: Regenerate. + * generated/maxloc0_8_i8.c: Regenerate. + * generated/minloc1_4_r8.c: Regenerate. + * generated/maxloc1_16_r16.c: Regenerate. + * generated/minloc1_16_i4.c: Regenerate. + * generated/maxloc1_16_i4.c: Regenerate. + * generated/minloc0_16_i8.c: Regenerate. + * generated/maxloc0_16_i8.c: Regenerate. + * generated/nearest_r8.c: Regenerate. + * generated/spacing_r16.c: Regenerate. + * generated/maxval_r16.c: Regenerate. + * generated/minloc1_8_i4.c: Regenerate. + * generated/minloc0_16_i16.c: Regenerate. + * generated/minloc0_4_r4.c: Regenerate. + * generated/set_exponent_r10.c: Regenerate. + * generated/rrspacing_r10.c: Regenerate. + * generated/minloc0_4_i2.c: Regenerate. + * generated/maxloc0_8_i1.c: Regenerate. + * generated/minloc0_8_i8.c: Regenerate. + * generated/spacing_r4.c: Regenerate. + * generated/minloc1_16_r10.c: Regenerate. + * generated/minloc0_16_i1.c: Regenerate. + * generated/maxloc0_16_i1.c: Regenerate. + * generated/maxloc1_8_r8.c: Regenerate. + * generated/minval_i16.c: Regenerate. + * generated/exponent_r10.c: Regenerate. + * generated/maxval_i4.c: Regenerate. + * generated/minval_i8.c: Regenerate. + * generated/maxloc1_4_i8.c: Regenerate. + * generated/fraction_r10.c: Regenerate. + * generated/maxloc0_16_i16.c: Regenerate. + * generated/maxloc0_8_r4.c: Regenerate. + * generated/rrspacing_r8.c: Regenerate. + * generated/minloc1_4_i16.c: Regenerate. + * generated/minloc0_4_r10.c: Regenerate. + * generated/maxloc1_4_i16.c: Regenerate. + * generated/minloc0_8_i16.c: Regenerate. + * generated/maxloc0_4_r10.c: Regenerate. + * generated/maxloc0_8_i16.c: Regenerate. + * generated/minloc1_8_r10.c: Regenerate. + * generated/minloc0_16_r4.c: Regenerate. + * generated/maxloc1_8_r10.c: Regenerate. + * generated/maxloc0_16_r4.c: Regenerate. + * generated/minloc1_16_r8.c: Regenerate. + * generated/minloc0_8_i1.c: Regenerate. + * generated/maxloc0_4_i4.c: Regenerate. + * generated/maxloc1_16_r8.c: Regenerate. + * generated/maxloc0_8_i2.c: Regenerate. + * generated/nearest_r16.c: Regenerate. + * generated/maxloc1_16_r10.c: Regenerate. + * generated/minloc0_16_i2.c: Regenerate. + * generated/minloc1_8_r8.c: Regenerate. + * generated/maxloc0_16_i2.c: Regenerate. + * generated/exponent_r4.c: Regenerate. + * generated/spacing_r10.c: Regenerate. + * generated/maxval_r10.c: Regenerate. + * generated/minval_i1.c: Regenerate. + * generated/maxloc1_4_i1.c: Regenerate. + * generated/minloc1_4_i8.c: Regenerate. + * generated/minloc0_8_r4.c: Regenerate. + * generated/minloc0_16_r16.c: Regenerate. + * generated/minloc0_4_i4.c: Regenerate. + * generated/minloc0_8_i2.c: Regenerate. + * generated/minval_r4.c: Regenerate. + * generated/maxloc1_4_r4.c: Regenerate. + * generated/maxval_r8.c: Regenerate. + * generated/minval_r16.c: Regenerate. + * generated/minloc1_4_i1.c: Regenerate. + * generated/minval_i2.c: Regenerate. + * generated/maxloc1_4_i2.c: Regenerate. + * generated/maxloc1_8_i8.c: Regenerate. + * generated/maxloc0_4_r8.c: Regenerate. + * generated/maxloc0_16_r16.c: Regenerate. + * generated/minloc1_4_r16.c: Regenerate. + * generated/fraction_r8.c: Regenerate. + * generated/maxloc1_4_r16.c: Regenerate. + * generated/set_exponent_r4.c: Regenerate. + * generated/minloc0_8_r16.c: Regenerate. + * generated/maxloc0_8_r16.c: Regenerate. + * generated/nearest_r10.c: Regenerate. + * generated/maxloc0_8_i4.c: Regenerate. + * generated/minloc1_4_r4.c: Regenerate. + * generated/minloc0_16_i4.c: Regenerate. + * generated/maxloc0_16_i4.c: Regenerate. + * generated/nearest_r4.c: Regenerate. + * generated/minloc1_16_i8.c: Regenerate. + * generated/maxloc1_16_i8.c: Regenerate. + * generated/minloc1_4_i2.c: Regenerate. + * generated/maxloc1_8_i1.c: Regenerate. + * generated/minloc0_16_r10.c: Regenerate. + * generated/minloc1_8_i8.c: Regenerate. + * generated/minloc0_4_r8.c: Regenerate. + * generated/minloc0_8_i4.c: Regenerate. + * generated/minloc1_16_i16.c: Regenerate. + * generated/spacing_r8.c: Regenerate. + * generated/maxloc1_8_r4.c: Regenerate. + * generated/minloc1_16_i1.c: Regenerate. + * generated/maxloc1_16_i1.c: Regenerate. + * generated/minval_r10.c: Regenerate. + * generated/minval_i4.c: Regenerate. + * generated/minloc1_8_i1.c: Regenerate. + * generated/maxloc1_4_i4.c: Regenerate. + * generated/maxloc1_8_i2.c: Regenerate. + * generated/maxval_i8.c: Regenerate. + * generated/maxloc0_16_r10.c: Regenerate. + * generated/rrspacing_r4.c: Regenerate. + * generated/minloc0_4_i16.c: Regenerate. + * generated/maxloc0_8_r8.c: Regenerate. + * generated/maxloc0_4_i16.c: Regenerate. + * generated/minloc1_4_r10.c: Regenerate. + * generated/minloc1_8_i16.c: Regenerate. + * generated/maxloc1_4_r10.c: Regenerate. + * generated/minloc0_8_r10.c: Regenerate. + * generated/maxloc1_8_i16.c: Regenerate. + * generated/maxloc0_8_r10.c: Regenerate. + * generated/minloc1_16_r4.c: Regenerate. + * generated/maxloc1_16_r4.c: Regenerate. + * generated/minloc0_16_r8.c: Regenerate. + * generated/maxloc0_16_r8.c: Regenerate. + * generated/maxloc0_4_i8.c: Regenerate. + * generated/maxloc1_16_i16.c: Regenerate. + * generated/minloc1_8_r4.c: Regenerate. + * generated/minloc1_16_i2.c: Regenerate. + * generated/maxloc1_16_i2.c: Regenerate. + * generated/maxval_i16.c: Regenerate. + * generated/exponent_r8.c: Regenerate. + * generated/minloc1_4_i4.c: Regenerate. + * generated/maxval_i1.c: Regenerate. + * generated/minloc1_8_i2.c: Regenerate. + * generated/minloc0_8_r8.c: Regenerate. + * generated/set_exponent_r16.c: Regenerate. + * generated/maxloc0_4_i1.c: Regenerate. + * generated/rrspacing_r16.c: Regenerate. + * generated/minloc0_4_i8.c: Regenerate. + * generated/maxval_r4.c: Regenerate. + * configure: Regenerate. + * config.h.in: Regenerate. + +2007-04-06 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/31395 + * io/format.c (parse_format_list): Fix parsing. + +2007-04-03 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/31304 + intrinsics/string_intrinsics.c (string_repeat): Remove. + +2007-04-01 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/31052 + * io/open.c (test_endfile): Delete this function. + (edit_modes): Delete call to test_endfile. + (new_unit): Likewise. + * io/io.h: Delete prototype for test_endfile. + * io/transfer.c (next_record_r): Remove use of test_endfile. + (st_read): Add test for end file condition and adjust status. + +2007-04-01 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/31366 + * io/transfer.c (read_block_direct): Do not generate error when reading + past EOF on a short record that is less than the RECL= specified. + +2007-04-01 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/31207 + * io/unit.c (close_unit_1): If there are bytes previously written from + ADVANCE="no", move to the end before closing. + +2007-03-31 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR libfortran/31335 + * intrinsics/stat.c: Only provide STAT and FSTAT library routines + if stat() and fstat() library functions are available. When lstat() + is not available, use stat() instead. + * configure.ac: Add checks for stat, fstat and lstat. + * configure: Regenerate. + * config.h.in: Regenerate. + +2007-03-27 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/31052 + * io/transfer.c (next_record_r): Do not call test_endfile if in + namelist mode. + +2007-03-25 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/31199 + * io/io.h: Add saved_pos to gfc_unit structure. + * io/open.c (new_unit): Initialize saved_pos. + * io/transfer.c (data_transfer_init): Set max_pos to value in + saved_pos. + (next_record_w): Fix whitespace. + (finalze_transfer): Calculate max_pos for ADVANCE="no" and save it for + later use. If not ADVANCE="no" set saved_pos to zero. + +2007-03-25 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/31196 + * intrinsics/reshape_generic.c (reshape_internal): Increment + correct variable. + +2007-03-22 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/31052 + * file_pos.c: Update Copyright year. + * io/open.c (test_endfile): Restore test_endfile to fix SPEC + regression. Update Copyright year. + * io/io.h: Same. + * io/unix.c (is_special): Add missing type for this function. + Update Copyright year. + * io/transfer.c (next_record_r): Restore test_endfile. + (st_read): Fix whitespace. Update Copyright year + +2007-03-20 Francois-Xavier Coudert <coudert@clipper.ens.fr> + + * configure.ac: Add missing check for gettimeofday. + * config.h.in: Renegerate. + * configure: Regenerate. + +2007-03-18 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/31052 + * io/file_position (st_rewind): Fix comments. Remove use of + test_endfile. Don't seek if already at 0 position. Use new is_special + function to set endfile state. + * io/open.c (test_endfile): Delete this function. + * io/io.h: Delete prototype for test_endfile. Add prototype + for is_special. + * io/unix.c (is_special): New function. Fix whitespace. + * io/transfer.c (next_record_r): Remove use of test_endfile. + +2007-03-16 David Edelsohn <edelsohn@gnu.org> + + * runtime/main.c: Include "config.h" first. + +2007-03-15 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/31099 + * io/file_pos.c (st_rewind): Don't set bytes_left to zero. + +2007-03-15 Francois-Xavier Coudert <coudert@clipper.ens.fr> + + * runtime/backtrace.c: New file. + * runtime/environ.c (variable_table): New GFORTRAN_ERROR_BACKTRACE + environment variable. + * runtime/compile_options.c (set_std): Add new argument. + * runtime/main.c (store_exe_path, full_exe_path): New functions. + * runtime/error.c (sys_exit): Add call to show_backtrace. + * libgfortran.h (options_t): New backtrace field. + (store_exe_path, full_exe_path, show_backtrace): New prototypes. + * configure.ac: Add checks for execinfo.h, execvp, pipe, dup2, + close, fdopen, strcasestr, getrlimit, backtrace, backtrace_symbols + and getppid. + * Makefile.am: Add runtime/backtrace.c. + * fmain.c (main): Add call to store_exe_path. + * Makefile.in: Renegerate. + * config.h.in: Renegerate. + * configure: Regenerate. + +2007-03-14 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/31051 + * io/transfer.c (formatted_transfer_scalar): Adjust position for + pending spaces when in writing mode. Clean up some formatting. + +2007-03-14 Thomas Koenig <Thomas.Koenig@online.de> + + PR libfortran/30690 + * all.m4: Quote everything, except for m4 macros. + * any.m4: Likewise. + * count.m4: Likewise. + * cshift1.m4: Likewise. + * eoshift1.m4: Likewise. + * eoshift3.m4: Likewise. + * exponent.m4: Likewise. + * fraction.m4: Likewise. + * in_pack.m4: Likewise. + * in_unpack.m4: Likewise. + * matmul.m4: Likewise. + * matmull.m4: Likewise. + * nearest.m4: Likewise. + * pow.m4: Likewise. + * product.m4: Likewise. + * reshape.m4: Likewise. + * rrspacing.m4: Likewise. + * set_exponent.m4: Likewise. + * shape.m4: Likewise. + * spacing.m4: Likewise. + * transpose.m4: Likewise. + +2007-03-14 Jakub Jelinek <jakub@redhat.com> + + * io/unix.c (regular_file): For ACTION_UNSPECIFIED retry with + O_RDONLY even if errno is EROFS. + +2007-03-09 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/31099 + * io/open.c (new_unit): Initialize bytes_left and recl_subrecord. + * io/transfer.c (next_record_w): Set bytes left to record length for + sequential unformatted I/O. + (next_record_r): Ditto. + (read_block_direct): Fix test for exceeding bytes_left. + +2007-03-08 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/30947 + * intrinsics/signal.c (alarm_sub_int): Avoid SEGFAULT with + integer arguments. + +2007-03-04 Thomas Koenig <Thomas.Koenig@online.de> + + PR libfortran/30981 + * m4/pow_m4: Use appropriate unsigned int type for u. + * generated/pow_c10_i16.c: Regenerated. + * generated/pow_c10_i4.c: Regenerated. + * generated/pow_c10_i8.c: Regenerated. + * generated/pow_c16_i16.c: Regenerated. + * generated/pow_c16_i4.c: Regenerated. + * generated/pow_c16_i8.c: Regenerated. + * generated/pow_c4_i16.c: Regenerated. + * generated/pow_c4_i4.c: Regenerated. + * generated/pow_c4_i8.c: Regenerated. + * generated/pow_c8_i16.c: Regenerated. + * generated/pow_c8_i4.c: Regenerated. + * generated/pow_c8_i8.c: Regenerated. + * generated/pow_i16_i16.c: Regenerated. + * generated/pow_i16_i4.c: Regenerated. + * generated/pow_i16_i8.c: Regenerated. + * generated/pow_i4_i16.c: Regenerated. + * generated/pow_i4_i4.c: Regenerated. + * generated/pow_i4_i8.c: Regenerated. + * generated/pow_i8_i16.c: Regenerated. + * generated/pow_i8_i4.c: Regenerated. + * generated/pow_i8_i8.c: Regenerated. + * generated/pow_r10_i16.c: Regenerated. + * generated/pow_r10_i4.c: Regenerated. + * generated/pow_r10_i8.c: Regenerated. + * generated/pow_r16_i16.c: Regenerated. + * generated/pow_r16_i4.c: Regenerated. + * generated/pow_r16_i8.c: Regenerated. + * generated/pow_r4_i16.c: Regenerated. + * generated/pow_r4_i4.c: Regenerated. + * generated/pow_r4_i8.c: Regenerated. + * generated/pow_r8_i16.c: Regenerated. + * generated/pow_r8_i4.c: Regenerated. + * generated/pow_r8_i8.c: Regenerated. + +2007-03-03 Francois-Xavier Coudert <coudert@clipper.ens.fr> + + PR libfortran/31001 + * intrinsics/pack_generic.c (pack_internal): Add special checks + for zero-sized arrays. + +2007-03-01 Brooks Moses <brooks.moses@codesourcery.com> + + * Makefile.am: Add dummy install-pdf target. + * Makefile.in: Regenerate + +2007-02-24 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/30918 + * io/listread.c (namelist_read): Eat comment line. + +2007-02-22 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/30910 + * io/write.c (output_float): Add condition of format F only for + special case rounding with zero precision. + +2007-02-19 Thomas Koenig <Thomas.Koenig@online.de> + + PR libfortran/30533 + PR libfortran/30765 + * Makefile.am: Add $(srcdir) too all files in generated/. + (i_maxloc0_c): Add maxloc0_4_i1.c, maxloc0_8_i1.c, + maxloc0_16_i1.c, maxloc0_4_i2.c, maxloc0_8_i2.c and + maxloc0_16_i2.c. + (i_maxloc1_c): Add maxloc1_4_i1.c, maxloc1_8_i1.c, + maxloc1_16_i1.c, maxloc1_4_i2.c, maxloc1_8_i2.c and + maxloc1_16_i2.c. + (i_maxval_c): Add maxval_i1.c and maxval_i2.c. + (i_minloc0_c): Add minloc0_4_i1.c, minloc0_8_i1.c, + minloc0_16_i1.c, minloc0_4_i2.c, minloc0_8_i2.c and + minloc0_16_i2.c. + (i_minloc_1.c): Add minloc1_4_i1.c, minloc1_8_i1.c, + minloc1_16_i1.c, minloc1_4_i2.c, minloc1_8_i2.c and + minloc1_16_i2.c. + (i_minval_c): Add minval_i1.c and minval_i2.c. + (i_sum_c): Add sum_i1.c and sum_i2.c. + (i_product_c): Add product_i1.c and product_i2.c. + (i_matmul_c): Add matmul_i1.c and matmul_i2.c. + (gfor_built_specific_src): Remove $(srcdir) from target. + (gfor_bulit_specific2_src): Likewise. + Makefile.in: Regenerated. + libgfortran.h: Add GFC_INTEGER_1_HUGE and GFC_INTEGER_2_HUGE. + Add gfc_array_i1 and gfc_array_i2. + * generated/matmul_i1.c: New file. + * generated/matmul_i2.c: New file. + * generated/maxloc0_16_i1.c: New file. + * generated/maxloc0_16_i2.c: New file. + * generated/maxloc0_4_i1.c: New file. + * generated/maxloc0_4_i2.c: New file. + * generated/maxloc0_8_i1.c: New file. + * generated/maxloc0_8_i2.c: New file. + * generated/maxloc1_16_i1.c: New file. + * generated/maxloc1_16_i2.c: New file. + * generated/maxloc1_4_i1.c: New file. + * generated/maxloc1_4_i2.c: New file. + * generated/maxloc1_8_i1.c: New file. + * generated/maxloc1_8_i2.c: New file. + * generated/maxval_i1.c: New file. + * generated/maxval_i2.c: New file. + * generated/minloc0_16_i1.c: New file. + * generated/minloc0_16_i2.c: New file. + * generated/minloc0_4_i1.c: New file. + * generated/minloc0_4_i2.c: New file. + * generated/minloc0_8_i1.c: New file. + * generated/minloc0_8_i2.c: New file. + * generated/minloc1_16_i1.c: New file. + * generated/minloc1_16_i2.c: New file. + * generated/minloc1_4_i1.c: New file. + * generated/minloc1_4_i2.c: New file. + * generated/minloc1_8_i1.c: New file. + * generated/minloc1_8_i2.c: New file. + * generated/minval_i1.c: New file. + * generated/minval_i2.c: New file. + * generated/product_i1.c: New file. + * generated/product_i2.c: New file. + * generated/sum_i1.c: New file. + * generated/sum_i2.c: New file. + +2007-02-16 Francois-Xavier Coudert <coudert@clipper.ens.fr> + + * runtime/memory.c (deallocate): Correct comment. + +2007-02-10 Thomas Koenig <Thomas.Koenig@online.de> + + * Makefile.am: Use $(M4) instead of m4. + * Makefile.in: Regenerate. + +2007-02-10 Thomas Koenig <Thomas.Koenig@online.de> + + * Makefile.am: Remove $(srcdir) from assorted targets + in maintainer mode. + * Makefile.in: Regenerate. + +2007-02-09 Thomas Koenig <Thomas.Koenig@online.de> + Tobias Burnus <burnus@net-b.de> + + PR fortran/30512 + * m4/iparm.m4: Use HUGE-1 for most negative integer. + * generated/maxloc1_8_i4.c: Regenerate. + * generated/maxloc0_8_i8.c: Regenerate. + * generated/maxloc1_16_i4.c: Regenerate. + * generated/maxloc0_16_i8.c: Regenerate. + * generated/maxval_i4.c: Regenerate. + * generated/maxloc1_4_i8.c: Regenerate. + * generated/maxloc0_16_i16.c: Regenerate. + * generated/maxloc1_4_i16.c: Regenerate. + * generated/maxloc0_8_i16.c: Regenerate. + * generated/maxloc0_4_i4.c: Regenerate. + * generated/maxloc1_8_i8.c: Regenerate. + * generated/maxloc0_8_i4.c: Regenerate. + * generated/maxloc0_16_i4.c: Regenerate. + * generated/maxloc1_16_i8.c: Regenerate. + * generated/maxloc1_4_i4.c: Regenerate. + * generated/maxval_i8.c: Regenerate. + * generated/maxloc0_4_i16.c: Regenerate. + * generated/maxloc1_8_i16.c: Regenerate. + * generated/maxloc0_4_i8.c: Regenerate. + * generated/maxloc1_16_i16.c: Regenerate. + * generated/maxval_i16.c: Regenerate. + +2007-02-04 Francois-Xavier Coudert <coudert@clipper.ens.fr> + + PR fortran/30611 + * intrinsics/string_intrinsics.c (string_repeat): Don't check + if ncopies is negative. + +2007-02-04 Francois-Xavier Coudert <coudert@clipper.ens.fr> + + PR libfortran/30007 + * libgfortran.h: Do not prefix symbol name with + __USER_LABEL_PREFIX__ when used in __attribute__((__alias__(...))). + +2007-02-02 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/30284 + PR fortran/30626 + * io/transfer.c (init_loop_spec, next_array_record): Change to + lbound rather than unity base. + +2007-01-21 Francois-Xavier Coudert <coudert@clipper.ens.fr> + + * runtime/error.c: Include sys/time.h before sys/resource.h. + +2007-01-21 Thomas Koenig <Thomas.Koenig@online.de> + + PR libfortran/30525 + * intrinsics/string_intrinsics.c(compare_string): Make + sure that comparisons are done unsigned. + +2007-01-21 Tobias Burnus <burnus@net-b.de> + + PR libfortran/30015 + * intrinsics/date_and_time.c (date_and_time): Fix case where time + can go backwards. + * configure.ac: Remove AC_TRY_RUN test for timezone in + gettimeofday. + * acinclude.m4: Ditto. + * configure: Regenerate. + * config.h.in: Regenerate. + +2007-01-20 Francois-Xavier Coudert <coudert@clipper.ens.fr> + + * m4/misc_specifics.m4: Add _gfortran prefix to specific names. + * m4/specific2.m4: Likewise. + * m4/specific.m4: Likewise. + * intrinsics/f2c_specifics.F90: Likewise. + * intrinsics/selected_int_kind.f90: Add _gfortran prefix. + * intrinsics/selected_real_kind.f90: Likewise. + * intrinsics/dprod_r8.f90: Likewise. + * Makefile.am: Add -fallow-leading-underscore to the + gfor_specific_src files, as well as selected_real_kind.F90 + and selected_int_kind.F90 + * Makefile.in: Regenerate. + * generated/_sqrt_c8.F90: Regenerate. + * generated/_sign_r16.F90: Regenerate. + * generated/_log_c16.F90: Regenerate. + * generated/_sin_c10.F90: Regenerate. + * generated/_tanh_r4.F90: Regenerate. + * generated/_tanh_r8.F90: Regenerate. + * generated/_log10_r10.F90: Regenerate. + * generated/_aimag_c4.F90: Regenerate. + * generated/_sign_r4.F90: Regenerate. + * generated/_aimag_c8.F90: Regenerate. + * generated/_sign_r8.F90: Regenerate. + * generated/_mod_i4.F90: Regenerate. + * generated/_cos_r16.F90: Regenerate. + * generated/_aint_r10.F90: Regenerate. + * generated/_mod_i8.F90: Regenerate. + * generated/_abs_i16.F90: Regenerate. + * generated/_sqrt_c10.F90: Regenerate. + * generated/_atan2_r4.F90: Regenerate. + * generated/_cos_c4.F90: Regenerate. + * generated/_atan_r16.F90: Regenerate. + * generated/_tanh_r10.F90: Regenerate. + * generated/_atan2_r8.F90: Regenerate. + * generated/_cos_c8.F90: Regenerate. + * generated/_exp_r4.F90: Regenerate. + * generated/_log_r10.F90: Regenerate. + * generated/_exp_r8.F90: Regenerate. + * generated/_abs_r4.F90: Regenerate. + * generated/_abs_r8.F90: Regenerate. + * generated/_sin_r16.F90: Regenerate. + * generated/_tan_r4.F90: Regenerate. + * generated/_tan_r8.F90: Regenerate. + * generated/_sign_i4.F90: Regenerate. + * generated/_sign_i8.F90: Regenerate. + * generated/_exp_c16.F90: Regenerate. + * generated/_sqrt_r16.F90: Regenerate. + * generated/_conjg_c4.F90: Regenerate. + * generated/_conjg_c8.F90: Regenerate. + * generated/_dim_r16.F90: Regenerate. + * generated/_mod_r10.F90: Regenerate. + * generated/_abs_c10.F90: Regenerate. + * generated/_conjg_c16.F90: Regenerate. + * generated/_tan_r16.F90: Regenerate. + * generated/_asinh_r10.F90: Regenerate. + * generated/_abs_i4.F90: Regenerate. + * generated/_abs_i8.F90: Regenerate. + * generated/_acos_r10.F90: Regenerate. + * generated/_exp_r10.F90: Regenerate. + * generated/_acosh_r16.F90: Regenerate. + * generated/_atan2_r16.F90: Regenerate. + * generated/_cos_c16.F90: Regenerate. + * generated/_mod_i16.F90: Regenerate. + * generated/_asin_r4.F90: Regenerate. + * generated/_anint_r16.F90: Regenerate. + * generated/_asin_r8.F90: Regenerate. + * generated/_aimag_c10.F90: Regenerate. + * generated/_exp_c4.F90: Regenerate. + * generated/_sinh_r10.F90: Regenerate. + * generated/_exp_c8.F90: Regenerate. + * generated/_log10_r4.F90: Regenerate. + * generated/_log10_r8.F90: Regenerate. + * generated/_abs_c4.F90: Regenerate. + * generated/_abs_r16.F90: Regenerate. + * generated/_abs_c8.F90: Regenerate. + * generated/_asin_r10.F90: Regenerate. + * generated/_sign_r10.F90: Regenerate. + * generated/_atanh_r16.F90: Regenerate. + * generated/_log_c10.F90: Regenerate. + * generated/_cosh_r16.F90: Regenerate. + * generated/_sin_c16.F90: Regenerate. + * generated/_cos_r10.F90: Regenerate. + * generated/_log10_r16.F90: Regenerate. + * generated/_aint_r16.F90: Regenerate. + * generated/_acos_r4.F90: Regenerate. + * generated/_acos_r8.F90: Regenerate. + * generated/_sqrt_c16.F90: Regenerate. + * generated/_acosh_r4.F90: Regenerate. + * generated/_atan_r10.F90: Regenerate. + * generated/_acosh_r8.F90: Regenerate. + * generated/_sign_i16.F90: Regenerate. + * generated/_tanh_r16.F90: Regenerate. + * generated/_log_r4.F90: Regenerate. + * generated/_log_r8.F90: Regenerate. + * generated/_sin_r4.F90: Regenerate. + * generated/_sin_r8.F90: Regenerate. + * generated/_log_r16.F90: Regenerate. + * generated/_sin_r10.F90: Regenerate. + * generated/_sqrt_r4.F90: Regenerate. + * generated/_exp_c10.F90: Regenerate. + * generated/_sqrt_r8.F90: Regenerate. + * generated/_asinh_r4.F90: Regenerate. + * generated/_sqrt_r10.F90: Regenerate. + * generated/_asinh_r8.F90: Regenerate. + * generated/_dim_r4.F90: Regenerate. + * generated/_dim_r8.F90: Regenerate. + * generated/_dim_r10.F90: Regenerate. + * generated/_cosh_r4.F90: Regenerate. + * generated/_conjg_c10.F90: Regenerate. + * generated/_tan_r10.F90: Regenerate. + * generated/_cosh_r8.F90: Regenerate. + * generated/_mod_r16.F90: Regenerate. + * generated/_abs_c16.F90: Regenerate. + * generated/_cos_r4.F90: Regenerate. + * generated/_asinh_r16.F90: Regenerate. + * generated/_cos_r8.F90: Regenerate. + * generated/_atanh_r4.F90: Regenerate. + * generated/_atanh_r8.F90: Regenerate. + * generated/_acos_r16.F90: Regenerate. + * generated/_anint_r4.F90: Regenerate. + * generated/_acosh_r10.F90: Regenerate. + * generated/_anint_r8.F90: Regenerate. + * generated/_exp_r16.F90: Regenerate. + * generated/_mod_r4.F90: Regenerate. + * generated/_cos_c10.F90: Regenerate. + * generated/_atan2_r10.F90: Regenerate. + * generated/_dim_i16.F90: Regenerate. + * generated/_mod_r8.F90: Regenerate. + * generated/_anint_r10.F90: Regenerate. + * generated/_aint_r4.F90: Regenerate. + * generated/_aint_r8.F90: Regenerate. + * generated/_dim_i4.F90: Regenerate. + * generated/_sinh_r4.F90: Regenerate. + * generated/_log_c4.F90: Regenerate. + * generated/_dim_i8.F90: Regenerate. + * generated/_sinh_r8.F90: Regenerate. + * generated/_log_c8.F90: Regenerate. + * generated/_sin_c4.F90: Regenerate. + * generated/_sin_c8.F90: Regenerate. + * generated/misc_specifics.F90: Regenerate. + * generated/_abs_r10.F90: Regenerate. + * generated/_aimag_c16.F90: Regenerate. + * generated/_atan_r4.F90: Regenerate. + * generated/_sinh_r16.F90: Regenerate. + * generated/_atan_r8.F90: Regenerate. + * generated/_atanh_r10.F90: Regenerate. + * generated/_cosh_r10.F90: Regenerate. + * generated/_sqrt_c4.F90: Regenerate. + * generated/_asin_r16.F90: Regenerate. + +2007-01-19 Francois-Xavier Coudert <coudert@clipper.ens.fr> + + PR libfortran/26893 + * acinclude.m4 (LIBGFOR_WORKING_GFORTRAN): New check. + * configure.ac: Add call to LIBGFOR_WORKING_GFORTRAN. + * configure: Regenerate. + * config.h.in: Regenerate because it was forgottent in the last + commit. + +2007-01-18 Francois-Xavier Coudert <coudert@clipper.ens.fr> + Tobias Burnus <burnus@net-b.de> + + PR libfortran/29649 + * runtime/environ.c (variable_table): New GFORTRAN_ERROR_DUMPCORE + environment variable. + * runtime/compile_options.c (set_std): Add new argument. + * runtime/error.c (sys_exit): Move from io/unix.c. Add coredump + functionality. + * libgfortran.h (options_t): New dump_core and backtrace members. + (sys_exit): Move prototype. + * io/unix.c (sys_exit): Move to runtime/error.c. + * configure.ac: Add check for getrlimit. + * configure: Regenerate. + +2007-01-17 Tom Tromey <tromey@redhat.com> + + PR libfortran/27107: + * aclocal.m4, configure, Makefile.in: Rebuilt. + * configure.ac: Enable automake dependency tracking. Update + minimum automake version. + +2007-01-17 Francois-Xavier Coudert <coudert@clipper.ens.fr> + + PR libfortran/27107 + * runtime/environ.c: Don't include io/io.h. + * runtime/string.c: Don't include io/io.h. + (compare0): Add cast to avoid warning. + * runtime/error.c: Don't include io/io.h. + (st_printf): Move to io/unix.c. + * intrinsics/flush.c: Delete, contents moved to io/intrinsics.c. + * intrinsics/fget.c: Likewise. + * intrinsics/ftell.c: Likewise. + * intrinsics/tty.c: Likewise. + * libgfortran.h (DEFAULT_RECL, notification_std, + get_unformatted_convert, IOPARM_*, st_parameter_common, unit_convert, + DEFAULT_TEMPDIR): New declarations. + * io/io.h (DEFAULT_RECL, notification_std, get_unformatted_convert, + IOPARM_*, st_parameter_common, unit_convert, DEFAULT_TEMPDIR): + Move to libgfortran.h. + * io/unix.c: Add io/unix.h content. + (st_printf): New function. + * io/intrinsics.c: New file. + * io/unix.h: Remove, contents moved into unix.c. + * libtool-version: Update library version to 3.0.0. + * configure.ac: Update library version to 0.3. + * Makefile.am (intrinsics/fget.c, intrinsics/flush.c, + intrinsics/ftell.c, intrinsics/tty.c, libgfortran.h): Remove targets. + * Makefile.in: Regenerate. + * configure: Regenerate. + +2007-01-12 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/30435 + * io/list_read.c (finish_separator): Don't call next_record. + (list_formatted_read_scalar): Clean up some comments and whitespace. + (nml_read_obj): Whitespace fix. + +2007-01-05 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/30162 + * io/unix.c (fd_flush): Don't seek if file is not seekable, defined as + s->file_length == -1. + (fd_alloc_w_at): Do not adjust file_length if file is not seekable. + (fd_seek): If not seekable, just return success. + (fd_truncate): If not seekable, no need to truncate. Return failure + if seek fails and the stream is not a pipe. + (fd_to_stream): Make test for non-seekable file more robust. + +2007-01-01 Steven G. Kargl <kargls@comcast.net> + + * ChangeLog: Copied to ... + * ChangeLog-2006: here. diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am index ba81c75f238..489f9ed4634 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -22,7 +22,7 @@ myexeclibdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR) libgfortranbegin_la_SOURCES = fmain.c libgfortranbegin_la_LDFLAGS = -static -## io.h conflicts with some a system header on some platforms, so +## io.h conflicts with a system header on some platforms, so ## use -iquote AM_CPPFLAGS = -iquote$(srcdir)/io -I$(srcdir)/$(MULTISRCTOP)../gcc \ -I$(srcdir)/$(MULTISRCTOP)../gcc/config \ @@ -60,6 +60,7 @@ intrinsics/cpu_time.c \ intrinsics/cshift0.c \ intrinsics/ctime.c \ intrinsics/date_and_time.c \ +intrinsics/dtime.c \ intrinsics/env.c \ intrinsics/eoshift0.c \ intrinsics/eoshift2.c \ @@ -120,25 +121,25 @@ runtime/string.c \ runtime/select.c i_all_c= \ +$(srcdir)/generated/all_l1.c \ +$(srcdir)/generated/all_l2.c \ $(srcdir)/generated/all_l4.c \ $(srcdir)/generated/all_l8.c \ $(srcdir)/generated/all_l16.c i_any_c= \ +$(srcdir)/generated/any_l1.c \ +$(srcdir)/generated/any_l2.c \ $(srcdir)/generated/any_l4.c \ $(srcdir)/generated/any_l8.c \ $(srcdir)/generated/any_l16.c i_count_c= \ -$(srcdir)/generated/count_4_l4.c \ -$(srcdir)/generated/count_8_l4.c \ -$(srcdir)/generated/count_16_l4.c \ -$(srcdir)/generated/count_4_l8.c \ -$(srcdir)/generated/count_8_l8.c \ -$(srcdir)/generated/count_16_l8.c \ -$(srcdir)/generated/count_4_l16.c \ -$(srcdir)/generated/count_8_l16.c \ -$(srcdir)/generated/count_16_l16.c +$(srcdir)/generated/count_1_l.c \ +$(srcdir)/generated/count_2_l.c \ +$(srcdir)/generated/count_4_l.c \ +$(srcdir)/generated/count_8_l.c \ +$(srcdir)/generated/count_16_l.c i_maxloc0_c= \ $(srcdir)/generated/maxloc0_4_i1.c \ @@ -462,7 +463,7 @@ $(srcdir)/generated/pow_c16_i16.c m4_files= m4/iparm.m4 m4/ifunction.m4 m4/iforeach.m4 m4/all.m4 \ m4/any.m4 m4/count.m4 m4/maxloc0.m4 m4/maxloc1.m4 m4/maxval.m4 \ m4/minloc0.m4 m4/minloc1.m4 m4/minval.m4 m4/product.m4 m4/sum.m4 \ - m4/matmul.m4 m4/matmull.m4 \ + m4/matmul.m4 m4/matmull.m4 m4/ifunction_logical.m4 \ m4/ctrig.m4 m4/cexp.m4 m4/chyp.m4 m4/mtype.m4 \ m4/specific.m4 m4/specific2.m4 m4/head.m4 m4/shape.m4 m4/reshape.m4 \ m4/transpose.m4 m4/eoshift1.m4 m4/eoshift3.m4 m4/exponent.m4 \ @@ -645,12 +646,45 @@ selected_real_kind.lo selected_int_kind.lo: AM_FCFLAGS += -fallow-leading-unders BUILT_SOURCES=$(gfor_built_src) $(gfor_built_specific_src) \ $(gfor_built_specific2_src) $(gfor_misc_specifics) -libgfortran_la_SOURCES = $(gfor_src) $(gfor_built_src) $(gfor_io_src) \ + +prereq_SRC = $(gfor_src) $(gfor_built_src) $(gfor_io_src) \ $(gfor_helper_src) $(gfor_io_headers) $(gfor_specific_src) +if onestep +# dummy sources for libtool +BUILT_SOURCES+=libgfortran_c.c libgfortran_f.f90 +libgfortran_c.c libgfortran_f.f90 libgfortran_F.F90: + echo > $@ +# overrides for libtool perusing the dummy sources +libgfortran_c.o: $(filter %.c,$(prereq_SRC)) + $(COMPILE) -c $^ -o $@ -combine + +libgfortran_c.lo: $(filter %.c,$(prereq_SRC)) + $(LTCOMPILE) -c -o $@ $^ -combine + +#libgfortran_f.o: $(filter %.f %.f90,$(prereq_SRC)) +# $(FCCOMPILE) -c $^ -o $@ -combine + +#libgfortran_f.lo: $(filter %.f %.f90,$(prereq_SRC)) +# $(LTFCCOMPILE) -c -o $@ $^ -combine +# not currently used: +#libgfortran_F.o: $(filter %.F %.F90,$(prereq_SRC)) +# $(PPFCCOMPILE) -c $^ -o $@ -combine +# +#libgfortran_F.lo: +# $(LTPPFCCOMPILE) -c -o $@ $^ -combine + +libgfortran_la_SOURCES = libgfortran_c.c $(filter-out %.c,$(prereq_SRC)) + +else +libgfortran_la_SOURCES = $(prereq_SRC) + +endif + I_M4_DEPS=m4/iparm.m4 I_M4_DEPS0=$(I_M4_DEPS) m4/iforeach.m4 I_M4_DEPS1=$(I_M4_DEPS) m4/ifunction.m4 +I_M4_DEPS2=$(I_M4_DEPS) m4/ifunction_logical.m4 kinds.h: $(srcdir)/mk-kinds-h.sh $(SHELL) $(srcdir)/mk-kinds-h.sh '$(FCCOMPILE)' > $@ || rm $@ @@ -674,13 +708,13 @@ fpu-target.h: $(srcdir)/$(FPU_HOST_HEADER) ## so we only include them in maintainer mode if MAINTAINER_MODE -$(i_all_c): m4/all.m4 $(I_M4_DEPS1) +$(i_all_c): m4/all.m4 $(I_M4_DEPS2) $(M4) -Dfile=$@ -I$(srcdir)/m4 all.m4 > $@ -$(i_any_c): m4/any.m4 $(I_M4_DEPS1) +$(i_any_c): m4/any.m4 $(I_M4_DEPS2) $(M4) -Dfile=$@ -I$(srcdir)/m4 any.m4 > $@ -$(i_count_c): m4/count.m4 $(I_M4_DEPS1) +$(i_count_c): m4/count.m4 $(I_M4_DEPS2) $(M4) -Dfile=$@ -I$(srcdir)/m4 count.m4 > $@ $(i_maxloc0_c): m4/maxloc0.m4 $(I_M4_DEPS0) diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index 90715d4c3f5..07feb5deddb 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -37,6 +37,9 @@ POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ target_triplet = @target@ + +# dummy sources for libtool +@onestep_TRUE@am__append_1 = libgfortran_c.c libgfortran_f.f90 DIST_COMMON = $(am__configure_deps) $(srcdir)/../config.guess \ $(srcdir)/../config.sub $(srcdir)/../depcomp \ $(srcdir)/../install-sh $(srcdir)/../ltmain.sh \ @@ -50,8 +53,8 @@ am__aclocal_m4_deps = $(top_srcdir)/../config/depstand.m4 \ $(top_srcdir)/../config/multi.m4 \ $(top_srcdir)/../config/stdint.m4 \ $(top_srcdir)/../ltoptions.m4 $(top_srcdir)/../ltsugar.m4 \ - $(top_srcdir)/../ltversion.m4 $(top_srcdir)/acinclude.m4 \ - $(top_srcdir)/../config/acx.m4 \ + $(top_srcdir)/../ltversion.m4 $(top_srcdir)/../lt~obsolete.m4 \ + $(top_srcdir)/acinclude.m4 $(top_srcdir)/../config/acx.m4 \ $(top_srcdir)/../config/no-executables.m4 \ $(top_srcdir)/../libtool.m4 $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ @@ -73,13 +76,455 @@ myexeclibLTLIBRARIES_INSTALL = $(INSTALL) toolexeclibLTLIBRARIES_INSTALL = $(INSTALL) LTLIBRARIES = $(myexeclib_LTLIBRARIES) $(toolexeclib_LTLIBRARIES) libgfortran_la_LIBADD = +am__libgfortran_la_SOURCES_DIST = runtime/backtrace.c \ + runtime/compile_options.c runtime/environ.c runtime/error.c \ + runtime/fpu.c runtime/main.c runtime/memory.c runtime/pause.c \ + runtime/stop.c runtime/string.c runtime/select.c \ + $(srcdir)/generated/all_l1.c $(srcdir)/generated/all_l2.c \ + $(srcdir)/generated/all_l4.c $(srcdir)/generated/all_l8.c \ + $(srcdir)/generated/all_l16.c $(srcdir)/generated/any_l1.c \ + $(srcdir)/generated/any_l2.c $(srcdir)/generated/any_l4.c \ + $(srcdir)/generated/any_l8.c $(srcdir)/generated/any_l16.c \ + $(srcdir)/generated/count_1_l.c \ + $(srcdir)/generated/count_2_l.c \ + $(srcdir)/generated/count_4_l.c \ + $(srcdir)/generated/count_8_l.c \ + $(srcdir)/generated/count_16_l.c \ + $(srcdir)/generated/maxloc0_4_i1.c \ + $(srcdir)/generated/maxloc0_8_i1.c \ + $(srcdir)/generated/maxloc0_16_i1.c \ + $(srcdir)/generated/maxloc0_4_i2.c \ + $(srcdir)/generated/maxloc0_8_i2.c \ + $(srcdir)/generated/maxloc0_16_i2.c \ + $(srcdir)/generated/maxloc0_4_i4.c \ + $(srcdir)/generated/maxloc0_8_i4.c \ + $(srcdir)/generated/maxloc0_16_i4.c \ + $(srcdir)/generated/maxloc0_4_i8.c \ + $(srcdir)/generated/maxloc0_8_i8.c \ + $(srcdir)/generated/maxloc0_16_i8.c \ + $(srcdir)/generated/maxloc0_4_i16.c \ + $(srcdir)/generated/maxloc0_8_i16.c \ + $(srcdir)/generated/maxloc0_16_i16.c \ + $(srcdir)/generated/maxloc0_4_r4.c \ + $(srcdir)/generated/maxloc0_8_r4.c \ + $(srcdir)/generated/maxloc0_16_r4.c \ + $(srcdir)/generated/maxloc0_4_r8.c \ + $(srcdir)/generated/maxloc0_8_r8.c \ + $(srcdir)/generated/maxloc0_16_r8.c \ + $(srcdir)/generated/maxloc0_4_r10.c \ + $(srcdir)/generated/maxloc0_8_r10.c \ + $(srcdir)/generated/maxloc0_16_r10.c \ + $(srcdir)/generated/maxloc0_4_r16.c \ + $(srcdir)/generated/maxloc0_8_r16.c \ + $(srcdir)/generated/maxloc0_16_r16.c \ + $(srcdir)/generated/maxloc1_4_i1.c \ + $(srcdir)/generated/maxloc1_8_i1.c \ + $(srcdir)/generated/maxloc1_16_i1.c \ + $(srcdir)/generated/maxloc1_4_i2.c \ + $(srcdir)/generated/maxloc1_8_i2.c \ + $(srcdir)/generated/maxloc1_16_i2.c \ + $(srcdir)/generated/maxloc1_4_i4.c \ + $(srcdir)/generated/maxloc1_8_i4.c \ + $(srcdir)/generated/maxloc1_16_i4.c \ + $(srcdir)/generated/maxloc1_4_i8.c \ + $(srcdir)/generated/maxloc1_8_i8.c \ + $(srcdir)/generated/maxloc1_16_i8.c \ + $(srcdir)/generated/maxloc1_4_i16.c \ + $(srcdir)/generated/maxloc1_8_i16.c \ + $(srcdir)/generated/maxloc1_16_i16.c \ + $(srcdir)/generated/maxloc1_4_r4.c \ + $(srcdir)/generated/maxloc1_8_r4.c \ + $(srcdir)/generated/maxloc1_16_r4.c \ + $(srcdir)/generated/maxloc1_4_r8.c \ + $(srcdir)/generated/maxloc1_8_r8.c \ + $(srcdir)/generated/maxloc1_16_r8.c \ + $(srcdir)/generated/maxloc1_4_r10.c \ + $(srcdir)/generated/maxloc1_8_r10.c \ + $(srcdir)/generated/maxloc1_16_r10.c \ + $(srcdir)/generated/maxloc1_4_r16.c \ + $(srcdir)/generated/maxloc1_8_r16.c \ + $(srcdir)/generated/maxloc1_16_r16.c \ + $(srcdir)/generated/maxval_i1.c \ + $(srcdir)/generated/maxval_i2.c \ + $(srcdir)/generated/maxval_i4.c \ + $(srcdir)/generated/maxval_i8.c \ + $(srcdir)/generated/maxval_i16.c \ + $(srcdir)/generated/maxval_r4.c \ + $(srcdir)/generated/maxval_r8.c \ + $(srcdir)/generated/maxval_r10.c \ + $(srcdir)/generated/maxval_r16.c \ + $(srcdir)/generated/minloc0_4_i1.c \ + $(srcdir)/generated/minloc0_8_i1.c \ + $(srcdir)/generated/minloc0_16_i1.c \ + $(srcdir)/generated/minloc0_4_i2.c \ + $(srcdir)/generated/minloc0_8_i2.c \ + $(srcdir)/generated/minloc0_16_i2.c \ + $(srcdir)/generated/minloc0_4_i4.c \ + $(srcdir)/generated/minloc0_8_i4.c \ + $(srcdir)/generated/minloc0_16_i4.c \ + $(srcdir)/generated/minloc0_4_i8.c \ + $(srcdir)/generated/minloc0_8_i8.c \ + $(srcdir)/generated/minloc0_16_i8.c \ + $(srcdir)/generated/minloc0_4_i16.c \ + $(srcdir)/generated/minloc0_8_i16.c \ + $(srcdir)/generated/minloc0_16_i16.c \ + $(srcdir)/generated/minloc0_4_r4.c \ + $(srcdir)/generated/minloc0_8_r4.c \ + $(srcdir)/generated/minloc0_16_r4.c \ + $(srcdir)/generated/minloc0_4_r8.c \ + $(srcdir)/generated/minloc0_8_r8.c \ + $(srcdir)/generated/minloc0_16_r8.c \ + $(srcdir)/generated/minloc0_4_r10.c \ + $(srcdir)/generated/minloc0_8_r10.c \ + $(srcdir)/generated/minloc0_16_r10.c \ + $(srcdir)/generated/minloc0_4_r16.c \ + $(srcdir)/generated/minloc0_8_r16.c \ + $(srcdir)/generated/minloc0_16_r16.c \ + $(srcdir)/generated/minloc1_4_i1.c \ + $(srcdir)/generated/minloc1_8_i1.c \ + $(srcdir)/generated/minloc1_16_i1.c \ + $(srcdir)/generated/minloc1_4_i2.c \ + $(srcdir)/generated/minloc1_8_i2.c \ + $(srcdir)/generated/minloc1_16_i2.c \ + $(srcdir)/generated/minloc1_4_i4.c \ + $(srcdir)/generated/minloc1_8_i4.c \ + $(srcdir)/generated/minloc1_16_i4.c \ + $(srcdir)/generated/minloc1_4_i8.c \ + $(srcdir)/generated/minloc1_8_i8.c \ + $(srcdir)/generated/minloc1_16_i8.c \ + $(srcdir)/generated/minloc1_4_i16.c \ + $(srcdir)/generated/minloc1_8_i16.c \ + $(srcdir)/generated/minloc1_16_i16.c \ + $(srcdir)/generated/minloc1_4_r4.c \ + $(srcdir)/generated/minloc1_8_r4.c \ + $(srcdir)/generated/minloc1_16_r4.c \ + $(srcdir)/generated/minloc1_4_r8.c \ + $(srcdir)/generated/minloc1_8_r8.c \ + $(srcdir)/generated/minloc1_16_r8.c \ + $(srcdir)/generated/minloc1_4_r10.c \ + $(srcdir)/generated/minloc1_8_r10.c \ + $(srcdir)/generated/minloc1_16_r10.c \ + $(srcdir)/generated/minloc1_4_r16.c \ + $(srcdir)/generated/minloc1_8_r16.c \ + $(srcdir)/generated/minloc1_16_r16.c \ + $(srcdir)/generated/minval_i1.c \ + $(srcdir)/generated/minval_i2.c \ + $(srcdir)/generated/minval_i4.c \ + $(srcdir)/generated/minval_i8.c \ + $(srcdir)/generated/minval_i16.c \ + $(srcdir)/generated/minval_r4.c \ + $(srcdir)/generated/minval_r8.c \ + $(srcdir)/generated/minval_r10.c \ + $(srcdir)/generated/minval_r16.c \ + $(srcdir)/generated/product_i1.c \ + $(srcdir)/generated/product_i2.c \ + $(srcdir)/generated/product_i4.c \ + $(srcdir)/generated/product_i8.c \ + $(srcdir)/generated/product_i16.c \ + $(srcdir)/generated/product_r4.c \ + $(srcdir)/generated/product_r8.c \ + $(srcdir)/generated/product_r10.c \ + $(srcdir)/generated/product_r16.c \ + $(srcdir)/generated/product_c4.c \ + $(srcdir)/generated/product_c8.c \ + $(srcdir)/generated/product_c10.c \ + $(srcdir)/generated/product_c16.c $(srcdir)/generated/sum_i1.c \ + $(srcdir)/generated/sum_i2.c $(srcdir)/generated/sum_i4.c \ + $(srcdir)/generated/sum_i8.c $(srcdir)/generated/sum_i16.c \ + $(srcdir)/generated/sum_r4.c $(srcdir)/generated/sum_r8.c \ + $(srcdir)/generated/sum_r10.c $(srcdir)/generated/sum_r16.c \ + $(srcdir)/generated/sum_c4.c $(srcdir)/generated/sum_c8.c \ + $(srcdir)/generated/sum_c10.c $(srcdir)/generated/sum_c16.c \ + $(srcdir)/generated/matmul_i1.c \ + $(srcdir)/generated/matmul_i2.c \ + $(srcdir)/generated/matmul_i4.c \ + $(srcdir)/generated/matmul_i8.c \ + $(srcdir)/generated/matmul_i16.c \ + $(srcdir)/generated/matmul_r4.c \ + $(srcdir)/generated/matmul_r8.c \ + $(srcdir)/generated/matmul_r10.c \ + $(srcdir)/generated/matmul_r16.c \ + $(srcdir)/generated/matmul_c4.c \ + $(srcdir)/generated/matmul_c8.c \ + $(srcdir)/generated/matmul_c10.c \ + $(srcdir)/generated/matmul_c16.c \ + $(srcdir)/generated/matmul_l4.c \ + $(srcdir)/generated/matmul_l8.c \ + $(srcdir)/generated/matmul_l16.c \ + $(srcdir)/generated/transpose_i4.c \ + $(srcdir)/generated/transpose_i8.c \ + $(srcdir)/generated/transpose_i16.c \ + $(srcdir)/generated/transpose_r4.c \ + $(srcdir)/generated/transpose_r8.c \ + $(srcdir)/generated/transpose_r10.c \ + $(srcdir)/generated/transpose_r16.c \ + $(srcdir)/generated/transpose_c4.c \ + $(srcdir)/generated/transpose_c8.c \ + $(srcdir)/generated/transpose_c10.c \ + $(srcdir)/generated/transpose_c16.c \ + $(srcdir)/generated/shape_i4.c $(srcdir)/generated/shape_i8.c \ + $(srcdir)/generated/shape_i16.c \ + $(srcdir)/generated/eoshift1_4.c \ + $(srcdir)/generated/eoshift1_8.c \ + $(srcdir)/generated/eoshift1_16.c \ + $(srcdir)/generated/eoshift3_4.c \ + $(srcdir)/generated/eoshift3_8.c \ + $(srcdir)/generated/eoshift3_16.c \ + $(srcdir)/generated/cshift1_4.c \ + $(srcdir)/generated/cshift1_8.c \ + $(srcdir)/generated/cshift1_16.c \ + $(srcdir)/generated/reshape_i4.c \ + $(srcdir)/generated/reshape_i8.c \ + $(srcdir)/generated/reshape_i16.c \ + $(srcdir)/generated/reshape_r4.c \ + $(srcdir)/generated/reshape_r8.c \ + $(srcdir)/generated/reshape_r10.c \ + $(srcdir)/generated/reshape_r16.c \ + $(srcdir)/generated/reshape_c4.c \ + $(srcdir)/generated/reshape_c8.c \ + $(srcdir)/generated/reshape_c10.c \ + $(srcdir)/generated/reshape_c16.c \ + $(srcdir)/generated/in_pack_i4.c \ + $(srcdir)/generated/in_pack_i8.c \ + $(srcdir)/generated/in_pack_i16.c \ + $(srcdir)/generated/in_pack_c4.c \ + $(srcdir)/generated/in_pack_c8.c \ + $(srcdir)/generated/in_pack_c10.c \ + $(srcdir)/generated/in_pack_c16.c \ + $(srcdir)/generated/in_unpack_i4.c \ + $(srcdir)/generated/in_unpack_i8.c \ + $(srcdir)/generated/in_unpack_i16.c \ + $(srcdir)/generated/in_unpack_c4.c \ + $(srcdir)/generated/in_unpack_c8.c \ + $(srcdir)/generated/in_unpack_c10.c \ + $(srcdir)/generated/in_unpack_c16.c \ + $(srcdir)/generated/exponent_r4.c \ + $(srcdir)/generated/exponent_r8.c \ + $(srcdir)/generated/exponent_r10.c \ + $(srcdir)/generated/exponent_r16.c \ + $(srcdir)/generated/fraction_r4.c \ + $(srcdir)/generated/fraction_r8.c \ + $(srcdir)/generated/fraction_r10.c \ + $(srcdir)/generated/fraction_r16.c \ + $(srcdir)/generated/nearest_r4.c \ + $(srcdir)/generated/nearest_r8.c \ + $(srcdir)/generated/nearest_r10.c \ + $(srcdir)/generated/nearest_r16.c \ + $(srcdir)/generated/set_exponent_r4.c \ + $(srcdir)/generated/set_exponent_r8.c \ + $(srcdir)/generated/set_exponent_r10.c \ + $(srcdir)/generated/set_exponent_r16.c \ + $(srcdir)/generated/pow_i4_i4.c \ + $(srcdir)/generated/pow_i8_i4.c \ + $(srcdir)/generated/pow_i16_i4.c \ + $(srcdir)/generated/pow_c4_i4.c \ + $(srcdir)/generated/pow_c8_i4.c \ + $(srcdir)/generated/pow_c10_i4.c \ + $(srcdir)/generated/pow_c16_i4.c \ + $(srcdir)/generated/pow_i4_i8.c \ + $(srcdir)/generated/pow_i8_i8.c \ + $(srcdir)/generated/pow_i16_i8.c \ + $(srcdir)/generated/pow_r4_i8.c \ + $(srcdir)/generated/pow_r8_i8.c \ + $(srcdir)/generated/pow_r10_i8.c \ + $(srcdir)/generated/pow_r16_i8.c \ + $(srcdir)/generated/pow_c4_i8.c \ + $(srcdir)/generated/pow_c8_i8.c \ + $(srcdir)/generated/pow_c10_i8.c \ + $(srcdir)/generated/pow_c16_i8.c \ + $(srcdir)/generated/pow_i4_i16.c \ + $(srcdir)/generated/pow_i8_i16.c \ + $(srcdir)/generated/pow_i16_i16.c \ + $(srcdir)/generated/pow_r4_i16.c \ + $(srcdir)/generated/pow_r8_i16.c \ + $(srcdir)/generated/pow_r10_i16.c \ + $(srcdir)/generated/pow_r16_i16.c \ + $(srcdir)/generated/pow_c4_i16.c \ + $(srcdir)/generated/pow_c8_i16.c \ + $(srcdir)/generated/pow_c10_i16.c \ + $(srcdir)/generated/pow_c16_i16.c \ + $(srcdir)/generated/rrspacing_r4.c \ + $(srcdir)/generated/rrspacing_r8.c \ + $(srcdir)/generated/rrspacing_r10.c \ + $(srcdir)/generated/rrspacing_r16.c \ + $(srcdir)/generated/spacing_r4.c \ + $(srcdir)/generated/spacing_r8.c \ + $(srcdir)/generated/spacing_r10.c \ + $(srcdir)/generated/spacing_r16.c selected_int_kind.inc \ + selected_real_kind.inc kinds.h kinds.inc c99_protos.inc \ + fpu-target.h io/close.c io/file_pos.c io/format.c io/inquire.c \ + io/intrinsics.c io/list_read.c io/lock.c io/open.c io/read.c \ + io/size_from_kind.c io/transfer.c io/unit.c io/unix.c \ + io/write.c intrinsics/associated.c intrinsics/abort.c \ + intrinsics/access.c intrinsics/args.c \ + intrinsics/c99_functions.c intrinsics/chdir.c \ + intrinsics/chmod.c intrinsics/clock.c intrinsics/cpu_time.c \ + intrinsics/cshift0.c intrinsics/ctime.c \ + intrinsics/date_and_time.c intrinsics/dtime.c intrinsics/env.c \ + intrinsics/eoshift0.c intrinsics/eoshift2.c intrinsics/etime.c \ + intrinsics/exit.c intrinsics/fnum.c intrinsics/gerror.c \ + intrinsics/getcwd.c intrinsics/getlog.c intrinsics/getXid.c \ + intrinsics/hostnm.c intrinsics/ierrno.c intrinsics/ishftc.c \ + intrinsics/iso_c_generated_procs.c intrinsics/iso_c_binding.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/spread_generic.c intrinsics/string_intrinsics.c \ + intrinsics/system.c intrinsics/rand.c intrinsics/random.c \ + intrinsics/rename.c intrinsics/reshape_generic.c \ + intrinsics/reshape_packed.c intrinsics/selected_int_kind.f90 \ + intrinsics/selected_real_kind.f90 intrinsics/stat.c \ + intrinsics/symlnk.c intrinsics/system_clock.c \ + intrinsics/time.c intrinsics/transpose_generic.c \ + intrinsics/umask.c intrinsics/unlink.c \ + intrinsics/unpack_generic.c runtime/in_pack_generic.c \ + runtime/in_unpack_generic.c io/io.h \ + $(srcdir)/generated/_abs_c4.F90 \ + $(srcdir)/generated/_abs_c8.F90 \ + $(srcdir)/generated/_abs_c10.F90 \ + $(srcdir)/generated/_abs_c16.F90 \ + $(srcdir)/generated/_abs_i4.F90 \ + $(srcdir)/generated/_abs_i8.F90 \ + $(srcdir)/generated/_abs_i16.F90 \ + $(srcdir)/generated/_abs_r4.F90 \ + $(srcdir)/generated/_abs_r8.F90 \ + $(srcdir)/generated/_abs_r10.F90 \ + $(srcdir)/generated/_abs_r16.F90 \ + $(srcdir)/generated/_aimag_c4.F90 \ + $(srcdir)/generated/_aimag_c8.F90 \ + $(srcdir)/generated/_aimag_c10.F90 \ + $(srcdir)/generated/_aimag_c16.F90 \ + $(srcdir)/generated/_exp_r4.F90 \ + $(srcdir)/generated/_exp_r8.F90 \ + $(srcdir)/generated/_exp_r10.F90 \ + $(srcdir)/generated/_exp_r16.F90 \ + $(srcdir)/generated/_exp_c4.F90 \ + $(srcdir)/generated/_exp_c8.F90 \ + $(srcdir)/generated/_exp_c10.F90 \ + $(srcdir)/generated/_exp_c16.F90 \ + $(srcdir)/generated/_log_r4.F90 \ + $(srcdir)/generated/_log_r8.F90 \ + $(srcdir)/generated/_log_r10.F90 \ + $(srcdir)/generated/_log_r16.F90 \ + $(srcdir)/generated/_log_c4.F90 \ + $(srcdir)/generated/_log_c8.F90 \ + $(srcdir)/generated/_log_c10.F90 \ + $(srcdir)/generated/_log_c16.F90 \ + $(srcdir)/generated/_log10_r4.F90 \ + $(srcdir)/generated/_log10_r8.F90 \ + $(srcdir)/generated/_log10_r10.F90 \ + $(srcdir)/generated/_log10_r16.F90 \ + $(srcdir)/generated/_sqrt_r4.F90 \ + $(srcdir)/generated/_sqrt_r8.F90 \ + $(srcdir)/generated/_sqrt_r10.F90 \ + $(srcdir)/generated/_sqrt_r16.F90 \ + $(srcdir)/generated/_sqrt_c4.F90 \ + $(srcdir)/generated/_sqrt_c8.F90 \ + $(srcdir)/generated/_sqrt_c10.F90 \ + $(srcdir)/generated/_sqrt_c16.F90 \ + $(srcdir)/generated/_asin_r4.F90 \ + $(srcdir)/generated/_asin_r8.F90 \ + $(srcdir)/generated/_asin_r10.F90 \ + $(srcdir)/generated/_asin_r16.F90 \ + $(srcdir)/generated/_asinh_r4.F90 \ + $(srcdir)/generated/_asinh_r8.F90 \ + $(srcdir)/generated/_asinh_r10.F90 \ + $(srcdir)/generated/_asinh_r16.F90 \ + $(srcdir)/generated/_acos_r4.F90 \ + $(srcdir)/generated/_acos_r8.F90 \ + $(srcdir)/generated/_acos_r10.F90 \ + $(srcdir)/generated/_acos_r16.F90 \ + $(srcdir)/generated/_acosh_r4.F90 \ + $(srcdir)/generated/_acosh_r8.F90 \ + $(srcdir)/generated/_acosh_r10.F90 \ + $(srcdir)/generated/_acosh_r16.F90 \ + $(srcdir)/generated/_atan_r4.F90 \ + $(srcdir)/generated/_atan_r8.F90 \ + $(srcdir)/generated/_atan_r10.F90 \ + $(srcdir)/generated/_atan_r16.F90 \ + $(srcdir)/generated/_atanh_r4.F90 \ + $(srcdir)/generated/_atanh_r8.F90 \ + $(srcdir)/generated/_atanh_r10.F90 \ + $(srcdir)/generated/_atanh_r16.F90 \ + $(srcdir)/generated/_sin_r4.F90 \ + $(srcdir)/generated/_sin_r8.F90 \ + $(srcdir)/generated/_sin_r10.F90 \ + $(srcdir)/generated/_sin_r16.F90 \ + $(srcdir)/generated/_sin_c4.F90 \ + $(srcdir)/generated/_sin_c8.F90 \ + $(srcdir)/generated/_sin_c10.F90 \ + $(srcdir)/generated/_sin_c16.F90 \ + $(srcdir)/generated/_cos_r4.F90 \ + $(srcdir)/generated/_cos_r8.F90 \ + $(srcdir)/generated/_cos_r10.F90 \ + $(srcdir)/generated/_cos_r16.F90 \ + $(srcdir)/generated/_cos_c4.F90 \ + $(srcdir)/generated/_cos_c8.F90 \ + $(srcdir)/generated/_cos_c10.F90 \ + $(srcdir)/generated/_cos_c16.F90 \ + $(srcdir)/generated/_tan_r4.F90 \ + $(srcdir)/generated/_tan_r8.F90 \ + $(srcdir)/generated/_tan_r10.F90 \ + $(srcdir)/generated/_tan_r16.F90 \ + $(srcdir)/generated/_sinh_r4.F90 \ + $(srcdir)/generated/_sinh_r8.F90 \ + $(srcdir)/generated/_sinh_r10.F90 \ + $(srcdir)/generated/_sinh_r16.F90 \ + $(srcdir)/generated/_cosh_r4.F90 \ + $(srcdir)/generated/_cosh_r8.F90 \ + $(srcdir)/generated/_cosh_r10.F90 \ + $(srcdir)/generated/_cosh_r16.F90 \ + $(srcdir)/generated/_tanh_r4.F90 \ + $(srcdir)/generated/_tanh_r8.F90 \ + $(srcdir)/generated/_tanh_r10.F90 \ + $(srcdir)/generated/_tanh_r16.F90 \ + $(srcdir)/generated/_conjg_c4.F90 \ + $(srcdir)/generated/_conjg_c8.F90 \ + $(srcdir)/generated/_conjg_c10.F90 \ + $(srcdir)/generated/_conjg_c16.F90 \ + $(srcdir)/generated/_aint_r4.F90 \ + $(srcdir)/generated/_aint_r8.F90 \ + $(srcdir)/generated/_aint_r10.F90 \ + $(srcdir)/generated/_aint_r16.F90 \ + $(srcdir)/generated/_anint_r4.F90 \ + $(srcdir)/generated/_anint_r8.F90 \ + $(srcdir)/generated/_anint_r10.F90 \ + $(srcdir)/generated/_anint_r16.F90 \ + $(srcdir)/generated/_sign_i4.F90 \ + $(srcdir)/generated/_sign_i8.F90 \ + $(srcdir)/generated/_sign_i16.F90 \ + $(srcdir)/generated/_sign_r4.F90 \ + $(srcdir)/generated/_sign_r8.F90 \ + $(srcdir)/generated/_sign_r10.F90 \ + $(srcdir)/generated/_sign_r16.F90 \ + $(srcdir)/generated/_dim_i4.F90 \ + $(srcdir)/generated/_dim_i8.F90 \ + $(srcdir)/generated/_dim_i16.F90 \ + $(srcdir)/generated/_dim_r4.F90 \ + $(srcdir)/generated/_dim_r8.F90 \ + $(srcdir)/generated/_dim_r10.F90 \ + $(srcdir)/generated/_dim_r16.F90 \ + $(srcdir)/generated/_atan2_r4.F90 \ + $(srcdir)/generated/_atan2_r8.F90 \ + $(srcdir)/generated/_atan2_r10.F90 \ + $(srcdir)/generated/_atan2_r16.F90 \ + $(srcdir)/generated/_mod_i4.F90 \ + $(srcdir)/generated/_mod_i8.F90 \ + $(srcdir)/generated/_mod_i16.F90 \ + $(srcdir)/generated/_mod_r4.F90 \ + $(srcdir)/generated/_mod_r8.F90 \ + $(srcdir)/generated/_mod_r10.F90 \ + $(srcdir)/generated/_mod_r16.F90 \ + $(srcdir)/generated/misc_specifics.F90 intrinsics/dprod_r8.f90 \ + intrinsics/f2c_specifics.F90 libgfortran_c.c $(filter-out \ + %.c,$(prereq_SRC)) am__objects_1 = backtrace.lo compile_options.lo environ.lo error.lo \ fpu.lo main.lo memory.lo pause.lo stop.lo string.lo select.lo -am__objects_2 = all_l4.lo all_l8.lo all_l16.lo -am__objects_3 = any_l4.lo any_l8.lo any_l16.lo -am__objects_4 = count_4_l4.lo count_8_l4.lo count_16_l4.lo \ - count_4_l8.lo count_8_l8.lo count_16_l8.lo count_4_l16.lo \ - count_8_l16.lo count_16_l16.lo +am__objects_2 = all_l1.lo all_l2.lo all_l4.lo all_l8.lo all_l16.lo +am__objects_3 = any_l1.lo any_l2.lo any_l4.lo any_l8.lo any_l16.lo +am__objects_4 = count_1_l.lo count_2_l.lo count_4_l.lo count_8_l.lo \ + count_16_l.lo am__objects_5 = maxloc0_4_i1.lo maxloc0_8_i1.lo maxloc0_16_i1.lo \ maxloc0_4_i2.lo maxloc0_8_i2.lo maxloc0_16_i2.lo \ maxloc0_4_i4.lo maxloc0_8_i4.lo maxloc0_16_i4.lo \ @@ -185,9 +630,9 @@ am__objects_31 = close.lo file_pos.lo format.lo inquire.lo \ size_from_kind.lo transfer.lo unit.lo unix.lo write.lo am__objects_32 = associated.lo abort.lo access.lo args.lo \ c99_functions.lo chdir.lo chmod.lo clock.lo cpu_time.lo \ - cshift0.lo ctime.lo date_and_time.lo env.lo eoshift0.lo \ - eoshift2.lo etime.lo exit.lo fnum.lo gerror.lo getcwd.lo \ - getlog.lo getXid.lo hostnm.lo ierrno.lo ishftc.lo \ + cshift0.lo ctime.lo date_and_time.lo dtime.lo env.lo \ + eoshift0.lo eoshift2.lo etime.lo exit.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 \ @@ -230,9 +675,10 @@ am__objects_35 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \ am__objects_36 = misc_specifics.lo am__objects_37 = $(am__objects_34) $(am__objects_35) $(am__objects_36) \ dprod_r8.lo f2c_specifics.lo -am_libgfortran_la_OBJECTS = $(am__objects_1) $(am__objects_30) \ - $(am__objects_31) $(am__objects_32) $(am__objects_33) \ - $(am__objects_37) +am__objects_38 = $(am__objects_1) $(am__objects_30) $(am__objects_31) \ + $(am__objects_32) $(am__objects_33) $(am__objects_37) +@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_38) +@onestep_TRUE@am_libgfortran_la_OBJECTS = libgfortran_c.lo libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS) libgfortranbegin_la_LIBADD = am_libgfortranbegin_la_OBJECTS = fmain.lo @@ -259,7 +705,7 @@ LINK = $(LIBTOOL) --tag=CC --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ FCCOMPILE = $(FC) $(AM_FCFLAGS) $(FCFLAGS) LTFCCOMPILE = $(LIBTOOL) --mode=compile $(FC) $(AM_FCFLAGS) $(FCFLAGS) SOURCES = $(libgfortran_la_SOURCES) $(libgfortranbegin_la_SOURCES) -DIST_SOURCES = $(libgfortran_la_SOURCES) \ +DIST_SOURCES = $(am__libgfortran_la_SOURCES_DIST) \ $(libgfortranbegin_la_SOURCES) MULTISRCTOP = MULTIBUILDTOP = @@ -343,9 +789,13 @@ SET_MAKE = @SET_MAKE@ SHELL = @SHELL@ STRIP = @STRIP@ VERSION = @VERSION@ +ac_ct_AR = @ac_ct_AR@ +ac_ct_AS = @ac_ct_AS@ ac_ct_CC = @ac_ct_CC@ ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ ac_ct_FC = @ac_ct_FC@ +ac_ct_RANLIB = @ac_ct_RANLIB@ +ac_ct_STRIP = @ac_ct_STRIP@ am__fastdepCC_FALSE = @am__fastdepCC_FALSE@ am__fastdepCC_TRUE = @am__fastdepCC_TRUE@ am__include = @am__include@ @@ -362,9 +812,6 @@ build_os = @build_os@ build_subdir = @build_subdir@ build_vendor = @build_vendor@ datadir = @datadir@ -datarootdir = @datarootdir@ -docdir = @docdir@ -dvidir = @dvidir@ enable_shared = @enable_shared@ enable_static = @enable_static@ exec_prefix = @exec_prefix@ @@ -375,23 +822,22 @@ host_cpu = @host_cpu@ host_os = @host_os@ host_subdir = @host_subdir@ host_vendor = @host_vendor@ -htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ -localedir = @localedir@ localstatedir = @localstatedir@ lt_ECHO = @lt_ECHO@ mandir = @mandir@ mkdir_p = @mkdir_p@ multi_basedir = @multi_basedir@ oldincludedir = @oldincludedir@ -pdfdir = @pdfdir@ +onestep = @onestep@ +onestep_FALSE = @onestep_FALSE@ +onestep_TRUE = @onestep_TRUE@ prefix = @prefix@ program_transform_name = @program_transform_name@ -psdir = @psdir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ sysconfdir = @sysconfdir@ @@ -450,6 +896,7 @@ intrinsics/cpu_time.c \ intrinsics/cshift0.c \ intrinsics/ctime.c \ intrinsics/date_and_time.c \ +intrinsics/dtime.c \ intrinsics/env.c \ intrinsics/eoshift0.c \ intrinsics/eoshift2.c \ @@ -510,25 +957,25 @@ runtime/string.c \ runtime/select.c i_all_c = \ +$(srcdir)/generated/all_l1.c \ +$(srcdir)/generated/all_l2.c \ $(srcdir)/generated/all_l4.c \ $(srcdir)/generated/all_l8.c \ $(srcdir)/generated/all_l16.c i_any_c = \ +$(srcdir)/generated/any_l1.c \ +$(srcdir)/generated/any_l2.c \ $(srcdir)/generated/any_l4.c \ $(srcdir)/generated/any_l8.c \ $(srcdir)/generated/any_l16.c i_count_c = \ -$(srcdir)/generated/count_4_l4.c \ -$(srcdir)/generated/count_8_l4.c \ -$(srcdir)/generated/count_16_l4.c \ -$(srcdir)/generated/count_4_l8.c \ -$(srcdir)/generated/count_8_l8.c \ -$(srcdir)/generated/count_16_l8.c \ -$(srcdir)/generated/count_4_l16.c \ -$(srcdir)/generated/count_8_l16.c \ -$(srcdir)/generated/count_16_l16.c +$(srcdir)/generated/count_1_l.c \ +$(srcdir)/generated/count_2_l.c \ +$(srcdir)/generated/count_4_l.c \ +$(srcdir)/generated/count_8_l.c \ +$(srcdir)/generated/count_16_l.c i_maxloc0_c = \ $(srcdir)/generated/maxloc0_4_i1.c \ @@ -852,7 +1299,7 @@ $(srcdir)/generated/pow_c16_i16.c m4_files = m4/iparm.m4 m4/ifunction.m4 m4/iforeach.m4 m4/all.m4 \ m4/any.m4 m4/count.m4 m4/maxloc0.m4 m4/maxloc1.m4 m4/maxval.m4 \ m4/minloc0.m4 m4/minloc1.m4 m4/minval.m4 m4/product.m4 m4/sum.m4 \ - m4/matmul.m4 m4/matmull.m4 \ + m4/matmul.m4 m4/matmull.m4 m4/ifunction_logical.m4 \ m4/ctrig.m4 m4/cexp.m4 m4/chyp.m4 m4/mtype.m4 \ m4/specific.m4 m4/specific2.m4 m4/head.m4 m4/shape.m4 m4/reshape.m4 \ m4/transpose.m4 m4/eoshift1.m4 m4/eoshift3.m4 m4/exponent.m4 \ @@ -1020,14 +1467,29 @@ intrinsics/dprod_r8.f90 \ intrinsics/f2c_specifics.F90 BUILT_SOURCES = $(gfor_built_src) $(gfor_built_specific_src) \ - $(gfor_built_specific2_src) $(gfor_misc_specifics) - -libgfortran_la_SOURCES = $(gfor_src) $(gfor_built_src) $(gfor_io_src) \ + $(gfor_built_specific2_src) $(gfor_misc_specifics) \ + $(am__append_1) +prereq_SRC = $(gfor_src) $(gfor_built_src) $(gfor_io_src) \ $(gfor_helper_src) $(gfor_io_headers) $(gfor_specific_src) +@onestep_FALSE@libgfortran_la_SOURCES = $(prereq_SRC) + +#libgfortran_f.o: $(filter %.f %.f90,$(prereq_SRC)) +# $(FCCOMPILE) -c $^ -o $@ -combine + +#libgfortran_f.lo: $(filter %.f %.f90,$(prereq_SRC)) +# $(LTFCCOMPILE) -c -o $@ $^ -combine +# not currently used: +#libgfortran_F.o: $(filter %.F %.F90,$(prereq_SRC)) +# $(PPFCCOMPILE) -c $^ -o $@ -combine +# +#libgfortran_F.lo: +# $(LTPPFCCOMPILE) -c -o $@ $^ -combine +@onestep_TRUE@libgfortran_la_SOURCES = libgfortran_c.c $(filter-out %.c,$(prereq_SRC)) I_M4_DEPS = m4/iparm.m4 I_M4_DEPS0 = $(I_M4_DEPS) m4/iforeach.m4 I_M4_DEPS1 = $(I_M4_DEPS) m4/ifunction.m4 +I_M4_DEPS2 = $(I_M4_DEPS) m4/ifunction_logical.m4 EXTRA_DIST = $(m4_files) all: $(BUILT_SOURCES) config.h $(MAKE) $(AM_MAKEFLAGS) all-am @@ -1151,10 +1613,14 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/abort.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/access.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/all_l1.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/all_l16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/all_l2.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/all_l4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/all_l8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/any_l1.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/any_l16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/any_l2.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/any_l4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/any_l8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/args.Plo@am__quote@ @@ -1166,15 +1632,11 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/clock.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/close.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/compile_options.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/count_16_l16.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/count_16_l4.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/count_16_l8.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/count_4_l16.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/count_4_l4.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/count_4_l8.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/count_8_l16.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/count_8_l4.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/count_8_l8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/count_16_l.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/count_1_l.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/count_2_l.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/count_4_l.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/count_8_l.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/cpu_time.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/cshift0.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/cshift1_16.Plo@am__quote@ @@ -1182,6 +1644,7 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/cshift1_8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ctime.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/date_and_time.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/dtime.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/env.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/environ.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/eoshift0.Plo@am__quote@ @@ -1236,6 +1699,7 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iso_c_binding.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/iso_c_generated_procs.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/kill.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libgfortran_c.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/link.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/list_read.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/lock.Plo@am__quote@ @@ -2036,6 +2500,20 @@ select.lo: runtime/select.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 select.lo `test -f 'runtime/select.c' || echo '$(srcdir)/'`runtime/select.c +all_l1.lo: $(srcdir)/generated/all_l1.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT all_l1.lo -MD -MP -MF "$(DEPDIR)/all_l1.Tpo" -c -o all_l1.lo `test -f '$(srcdir)/generated/all_l1.c' || echo '$(srcdir)/'`$(srcdir)/generated/all_l1.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/all_l1.Tpo" "$(DEPDIR)/all_l1.Plo"; else rm -f "$(DEPDIR)/all_l1.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/all_l1.c' object='all_l1.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 all_l1.lo `test -f '$(srcdir)/generated/all_l1.c' || echo '$(srcdir)/'`$(srcdir)/generated/all_l1.c + +all_l2.lo: $(srcdir)/generated/all_l2.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT all_l2.lo -MD -MP -MF "$(DEPDIR)/all_l2.Tpo" -c -o all_l2.lo `test -f '$(srcdir)/generated/all_l2.c' || echo '$(srcdir)/'`$(srcdir)/generated/all_l2.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/all_l2.Tpo" "$(DEPDIR)/all_l2.Plo"; else rm -f "$(DEPDIR)/all_l2.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/all_l2.c' object='all_l2.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 all_l2.lo `test -f '$(srcdir)/generated/all_l2.c' || echo '$(srcdir)/'`$(srcdir)/generated/all_l2.c + all_l4.lo: $(srcdir)/generated/all_l4.c @am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT all_l4.lo -MD -MP -MF "$(DEPDIR)/all_l4.Tpo" -c -o all_l4.lo `test -f '$(srcdir)/generated/all_l4.c' || echo '$(srcdir)/'`$(srcdir)/generated/all_l4.c; \ @am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/all_l4.Tpo" "$(DEPDIR)/all_l4.Plo"; else rm -f "$(DEPDIR)/all_l4.Tpo"; exit 1; fi @@ -2057,6 +2535,20 @@ all_l16.lo: $(srcdir)/generated/all_l16.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 all_l16.lo `test -f '$(srcdir)/generated/all_l16.c' || echo '$(srcdir)/'`$(srcdir)/generated/all_l16.c +any_l1.lo: $(srcdir)/generated/any_l1.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT any_l1.lo -MD -MP -MF "$(DEPDIR)/any_l1.Tpo" -c -o any_l1.lo `test -f '$(srcdir)/generated/any_l1.c' || echo '$(srcdir)/'`$(srcdir)/generated/any_l1.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/any_l1.Tpo" "$(DEPDIR)/any_l1.Plo"; else rm -f "$(DEPDIR)/any_l1.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/any_l1.c' object='any_l1.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 any_l1.lo `test -f '$(srcdir)/generated/any_l1.c' || echo '$(srcdir)/'`$(srcdir)/generated/any_l1.c + +any_l2.lo: $(srcdir)/generated/any_l2.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT any_l2.lo -MD -MP -MF "$(DEPDIR)/any_l2.Tpo" -c -o any_l2.lo `test -f '$(srcdir)/generated/any_l2.c' || echo '$(srcdir)/'`$(srcdir)/generated/any_l2.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/any_l2.Tpo" "$(DEPDIR)/any_l2.Plo"; else rm -f "$(DEPDIR)/any_l2.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/any_l2.c' object='any_l2.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 any_l2.lo `test -f '$(srcdir)/generated/any_l2.c' || echo '$(srcdir)/'`$(srcdir)/generated/any_l2.c + any_l4.lo: $(srcdir)/generated/any_l4.c @am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT any_l4.lo -MD -MP -MF "$(DEPDIR)/any_l4.Tpo" -c -o any_l4.lo `test -f '$(srcdir)/generated/any_l4.c' || echo '$(srcdir)/'`$(srcdir)/generated/any_l4.c; \ @am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/any_l4.Tpo" "$(DEPDIR)/any_l4.Plo"; else rm -f "$(DEPDIR)/any_l4.Tpo"; exit 1; fi @@ -2078,68 +2570,40 @@ any_l16.lo: $(srcdir)/generated/any_l16.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 any_l16.lo `test -f '$(srcdir)/generated/any_l16.c' || echo '$(srcdir)/'`$(srcdir)/generated/any_l16.c -count_4_l4.lo: $(srcdir)/generated/count_4_l4.c -@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT count_4_l4.lo -MD -MP -MF "$(DEPDIR)/count_4_l4.Tpo" -c -o count_4_l4.lo `test -f '$(srcdir)/generated/count_4_l4.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_4_l4.c; \ -@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/count_4_l4.Tpo" "$(DEPDIR)/count_4_l4.Plo"; else rm -f "$(DEPDIR)/count_4_l4.Tpo"; exit 1; fi -@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/count_4_l4.c' object='count_4_l4.lo' libtool=yes @AMDEPBACKSLASH@ +count_1_l.lo: $(srcdir)/generated/count_1_l.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT count_1_l.lo -MD -MP -MF "$(DEPDIR)/count_1_l.Tpo" -c -o count_1_l.lo `test -f '$(srcdir)/generated/count_1_l.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_1_l.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/count_1_l.Tpo" "$(DEPDIR)/count_1_l.Plo"; else rm -f "$(DEPDIR)/count_1_l.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/count_1_l.c' object='count_1_l.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 count_4_l4.lo `test -f '$(srcdir)/generated/count_4_l4.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_4_l4.c +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o count_1_l.lo `test -f '$(srcdir)/generated/count_1_l.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_1_l.c -count_8_l4.lo: $(srcdir)/generated/count_8_l4.c -@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT count_8_l4.lo -MD -MP -MF "$(DEPDIR)/count_8_l4.Tpo" -c -o count_8_l4.lo `test -f '$(srcdir)/generated/count_8_l4.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_8_l4.c; \ -@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/count_8_l4.Tpo" "$(DEPDIR)/count_8_l4.Plo"; else rm -f "$(DEPDIR)/count_8_l4.Tpo"; exit 1; fi -@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/count_8_l4.c' object='count_8_l4.lo' libtool=yes @AMDEPBACKSLASH@ +count_2_l.lo: $(srcdir)/generated/count_2_l.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT count_2_l.lo -MD -MP -MF "$(DEPDIR)/count_2_l.Tpo" -c -o count_2_l.lo `test -f '$(srcdir)/generated/count_2_l.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_2_l.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/count_2_l.Tpo" "$(DEPDIR)/count_2_l.Plo"; else rm -f "$(DEPDIR)/count_2_l.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/count_2_l.c' object='count_2_l.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 count_8_l4.lo `test -f '$(srcdir)/generated/count_8_l4.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_8_l4.c +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o count_2_l.lo `test -f '$(srcdir)/generated/count_2_l.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_2_l.c -count_16_l4.lo: $(srcdir)/generated/count_16_l4.c -@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT count_16_l4.lo -MD -MP -MF "$(DEPDIR)/count_16_l4.Tpo" -c -o count_16_l4.lo `test -f '$(srcdir)/generated/count_16_l4.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_16_l4.c; \ -@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/count_16_l4.Tpo" "$(DEPDIR)/count_16_l4.Plo"; else rm -f "$(DEPDIR)/count_16_l4.Tpo"; exit 1; fi -@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/count_16_l4.c' object='count_16_l4.lo' libtool=yes @AMDEPBACKSLASH@ +count_4_l.lo: $(srcdir)/generated/count_4_l.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT count_4_l.lo -MD -MP -MF "$(DEPDIR)/count_4_l.Tpo" -c -o count_4_l.lo `test -f '$(srcdir)/generated/count_4_l.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_4_l.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/count_4_l.Tpo" "$(DEPDIR)/count_4_l.Plo"; else rm -f "$(DEPDIR)/count_4_l.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/count_4_l.c' object='count_4_l.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 count_16_l4.lo `test -f '$(srcdir)/generated/count_16_l4.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_16_l4.c +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o count_4_l.lo `test -f '$(srcdir)/generated/count_4_l.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_4_l.c -count_4_l8.lo: $(srcdir)/generated/count_4_l8.c -@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT count_4_l8.lo -MD -MP -MF "$(DEPDIR)/count_4_l8.Tpo" -c -o count_4_l8.lo `test -f '$(srcdir)/generated/count_4_l8.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_4_l8.c; \ -@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/count_4_l8.Tpo" "$(DEPDIR)/count_4_l8.Plo"; else rm -f "$(DEPDIR)/count_4_l8.Tpo"; exit 1; fi -@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/count_4_l8.c' object='count_4_l8.lo' libtool=yes @AMDEPBACKSLASH@ +count_8_l.lo: $(srcdir)/generated/count_8_l.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT count_8_l.lo -MD -MP -MF "$(DEPDIR)/count_8_l.Tpo" -c -o count_8_l.lo `test -f '$(srcdir)/generated/count_8_l.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_8_l.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/count_8_l.Tpo" "$(DEPDIR)/count_8_l.Plo"; else rm -f "$(DEPDIR)/count_8_l.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/count_8_l.c' object='count_8_l.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 count_4_l8.lo `test -f '$(srcdir)/generated/count_4_l8.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_4_l8.c +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o count_8_l.lo `test -f '$(srcdir)/generated/count_8_l.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_8_l.c -count_8_l8.lo: $(srcdir)/generated/count_8_l8.c -@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT count_8_l8.lo -MD -MP -MF "$(DEPDIR)/count_8_l8.Tpo" -c -o count_8_l8.lo `test -f '$(srcdir)/generated/count_8_l8.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_8_l8.c; \ -@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/count_8_l8.Tpo" "$(DEPDIR)/count_8_l8.Plo"; else rm -f "$(DEPDIR)/count_8_l8.Tpo"; exit 1; fi -@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/count_8_l8.c' object='count_8_l8.lo' libtool=yes @AMDEPBACKSLASH@ +count_16_l.lo: $(srcdir)/generated/count_16_l.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT count_16_l.lo -MD -MP -MF "$(DEPDIR)/count_16_l.Tpo" -c -o count_16_l.lo `test -f '$(srcdir)/generated/count_16_l.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_16_l.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/count_16_l.Tpo" "$(DEPDIR)/count_16_l.Plo"; else rm -f "$(DEPDIR)/count_16_l.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/count_16_l.c' object='count_16_l.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 count_8_l8.lo `test -f '$(srcdir)/generated/count_8_l8.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_8_l8.c - -count_16_l8.lo: $(srcdir)/generated/count_16_l8.c -@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT count_16_l8.lo -MD -MP -MF "$(DEPDIR)/count_16_l8.Tpo" -c -o count_16_l8.lo `test -f '$(srcdir)/generated/count_16_l8.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_16_l8.c; \ -@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/count_16_l8.Tpo" "$(DEPDIR)/count_16_l8.Plo"; else rm -f "$(DEPDIR)/count_16_l8.Tpo"; exit 1; fi -@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/count_16_l8.c' object='count_16_l8.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 count_16_l8.lo `test -f '$(srcdir)/generated/count_16_l8.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_16_l8.c - -count_4_l16.lo: $(srcdir)/generated/count_4_l16.c -@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT count_4_l16.lo -MD -MP -MF "$(DEPDIR)/count_4_l16.Tpo" -c -o count_4_l16.lo `test -f '$(srcdir)/generated/count_4_l16.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_4_l16.c; \ -@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/count_4_l16.Tpo" "$(DEPDIR)/count_4_l16.Plo"; else rm -f "$(DEPDIR)/count_4_l16.Tpo"; exit 1; fi -@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/count_4_l16.c' object='count_4_l16.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 count_4_l16.lo `test -f '$(srcdir)/generated/count_4_l16.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_4_l16.c - -count_8_l16.lo: $(srcdir)/generated/count_8_l16.c -@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT count_8_l16.lo -MD -MP -MF "$(DEPDIR)/count_8_l16.Tpo" -c -o count_8_l16.lo `test -f '$(srcdir)/generated/count_8_l16.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_8_l16.c; \ -@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/count_8_l16.Tpo" "$(DEPDIR)/count_8_l16.Plo"; else rm -f "$(DEPDIR)/count_8_l16.Tpo"; exit 1; fi -@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/count_8_l16.c' object='count_8_l16.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 count_8_l16.lo `test -f '$(srcdir)/generated/count_8_l16.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_8_l16.c - -count_16_l16.lo: $(srcdir)/generated/count_16_l16.c -@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT count_16_l16.lo -MD -MP -MF "$(DEPDIR)/count_16_l16.Tpo" -c -o count_16_l16.lo `test -f '$(srcdir)/generated/count_16_l16.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_16_l16.c; \ -@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/count_16_l16.Tpo" "$(DEPDIR)/count_16_l16.Plo"; else rm -f "$(DEPDIR)/count_16_l16.Tpo"; exit 1; fi -@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/count_16_l16.c' object='count_16_l16.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 count_16_l16.lo `test -f '$(srcdir)/generated/count_16_l16.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_16_l16.c +@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o count_16_l.lo `test -f '$(srcdir)/generated/count_16_l.c' || echo '$(srcdir)/'`$(srcdir)/generated/count_16_l.c maxloc0_4_i1.lo: $(srcdir)/generated/maxloc0_4_i1.c @am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT maxloc0_4_i1.lo -MD -MP -MF "$(DEPDIR)/maxloc0_4_i1.Tpo" -c -o maxloc0_4_i1.lo `test -f '$(srcdir)/generated/maxloc0_4_i1.c' || echo '$(srcdir)/'`$(srcdir)/generated/maxloc0_4_i1.c; \ @@ -4206,6 +4670,13 @@ date_and_time.lo: intrinsics/date_and_time.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 date_and_time.lo `test -f 'intrinsics/date_and_time.c' || echo '$(srcdir)/'`intrinsics/date_and_time.c +dtime.lo: intrinsics/dtime.c +@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT dtime.lo -MD -MP -MF "$(DEPDIR)/dtime.Tpo" -c -o dtime.lo `test -f 'intrinsics/dtime.c' || echo '$(srcdir)/'`intrinsics/dtime.c; \ +@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/dtime.Tpo" "$(DEPDIR)/dtime.Plo"; else rm -f "$(DEPDIR)/dtime.Tpo"; exit 1; fi +@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='intrinsics/dtime.c' object='dtime.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 dtime.lo `test -f 'intrinsics/dtime.c' || echo '$(srcdir)/'`intrinsics/dtime.c + env.lo: intrinsics/env.c @am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT env.lo -MD -MP -MF "$(DEPDIR)/env.Tpo" -c -o env.lo `test -f 'intrinsics/env.c' || echo '$(srcdir)/'`intrinsics/env.c; \ @am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/env.Tpo" "$(DEPDIR)/env.Plo"; else rm -f "$(DEPDIR)/env.Tpo"; exit 1; fi @@ -4850,6 +5321,14 @@ $(patsubst %.c,%.lo,$(notdir $(i_matmull_c))): AM_CFLAGS += -funroll-loops # Add the -fallow-leading-underscore option when needed $(patsubst %.F90,%.lo,$(patsubst %.f90,%.lo,$(notdir $(gfor_specific_src)))): AM_FCFLAGS += -fallow-leading-underscore selected_real_kind.lo selected_int_kind.lo: AM_FCFLAGS += -fallow-leading-underscore +@onestep_TRUE@libgfortran_c.c libgfortran_f.f90 libgfortran_F.F90: +@onestep_TRUE@ echo > $@ +# overrides for libtool perusing the dummy sources +@onestep_TRUE@libgfortran_c.o: $(filter %.c,$(prereq_SRC)) +@onestep_TRUE@ $(COMPILE) -c $^ -o $@ -combine + +@onestep_TRUE@libgfortran_c.lo: $(filter %.c,$(prereq_SRC)) +@onestep_TRUE@ $(LTCOMPILE) -c -o $@ $^ -combine kinds.h: $(srcdir)/mk-kinds-h.sh $(SHELL) $(srcdir)/mk-kinds-h.sh '$(FCCOMPILE)' > $@ || rm $@ @@ -4869,13 +5348,13 @@ selected_real_kind.inc: $(srcdir)/mk-srk-inc.sh fpu-target.h: $(srcdir)/$(FPU_HOST_HEADER) cp $(srcdir)/$(FPU_HOST_HEADER) $@ -@MAINTAINER_MODE_TRUE@$(i_all_c): m4/all.m4 $(I_M4_DEPS1) +@MAINTAINER_MODE_TRUE@$(i_all_c): m4/all.m4 $(I_M4_DEPS2) @MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 all.m4 > $@ -@MAINTAINER_MODE_TRUE@$(i_any_c): m4/any.m4 $(I_M4_DEPS1) +@MAINTAINER_MODE_TRUE@$(i_any_c): m4/any.m4 $(I_M4_DEPS2) @MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 any.m4 > $@ -@MAINTAINER_MODE_TRUE@$(i_count_c): m4/count.m4 $(I_M4_DEPS1) +@MAINTAINER_MODE_TRUE@$(i_count_c): m4/count.m4 $(I_M4_DEPS2) @MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 count.m4 > $@ @MAINTAINER_MODE_TRUE@$(i_maxloc0_c): m4/maxloc0.m4 $(I_M4_DEPS0) diff --git a/libgfortran/acinclude.m4 b/libgfortran/acinclude.m4 index 1660b6e75e6..6cc10408d96 100644 --- a/libgfortran/acinclude.m4 +++ b/libgfortran/acinclude.m4 @@ -27,26 +27,6 @@ AC_DEFUN([AC_LIBTOOL_DLOPEN]) AC_DEFUN([AC_PROG_LD]) ]) -dnl Check whether the target is ILP32. -AC_DEFUN([LIBGFOR_TARGET_ILP32], [ - AC_CACHE_CHECK([whether the target is ILP32], target_ilp32, [ - save_CFLAGS="$CFLAGS" - CFLAGS="-O2" - AC_TRY_LINK(,[ -if (sizeof(int) == 4 && sizeof(long) == 4 && sizeof(void *) == 4) - ; -else - undefined_function (); - ], - target_ilp32=yes, - target_ilp32=no) - CFLAGS="$save_CFLAGS"]) - if test $target_ilp32 = yes; then - AC_DEFINE(TARGET_ILP32, 1, - [Define to 1 if the target is ILP32.]) - fi - ]) - dnl Check whether the target supports hidden visibility. AC_DEFUN([LIBGFOR_CHECK_ATTRIBUTE_VISIBILITY], [ AC_CACHE_CHECK([whether the target supports hidden visibility], @@ -128,7 +108,7 @@ AC_DEFUN([LIBGFOR_GTHREAD_WEAK], [ [Define to 1 if the target supports #pragma weak]) fi case "$host" in - *-*-darwin* | *-*-hpux* | *-*-cygwin*) + *-*-darwin* | *-*-hpux* | *-*-cygwin* | *-*-mingw* ) AC_DEFINE(GTHREAD_USE_WEAK, 0, [Define to 0 if the target shouldn't use #pragma weak]) ;; @@ -386,3 +366,19 @@ AC_DEFUN([LIBGFOR_CHECK_FPSETMASK], [ AC_DEFINE(HAVE_FPSETMASK, 1, [Define if you have fpsetmask.]) fi ]) + +dnl Check whether we have a mingw that provides a __mingw_snprintf function +AC_DEFUN([LIBGFOR_CHECK_MINGW_SNPRINTF], [ + AC_CACHE_CHECK([whether __mingw_snprintf is present], have_mingw_snprintf, [ + AC_TRY_LINK([ +#include <stdio.h> +extern int __mingw_snprintf (char *, size_t, const char *, ...); +],[ +__mingw_snprintf (NULL, 0, "%d\n", 1); +], + eval "have_mingw_snprintf=yes", eval "have_mingw_snprintf=no") + ]) + if test x"$have_mingw_snprintf" = xyes; then + AC_DEFINE(HAVE_MINGW_SNPRINTF, 1, [Define if you have __mingw_snprintf.]) + fi +]) diff --git a/libgfortran/c99_protos.h b/libgfortran/c99_protos.h index 369299dc77d..59cbe4cac14 100644 --- a/libgfortran/c99_protos.h +++ b/libgfortran/c99_protos.h @@ -1,5 +1,5 @@ /* Declarations of various C99 functions - Copyright (C) 2004, 2006 Free Software Foundation, Inc. + Copyright (C) 2004, 2006, 2007 Free Software Foundation, Inc. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -200,6 +200,43 @@ extern double round(double); extern float roundf(float); #endif +#if !defined(HAVE_ROUNDL) +#define HAVE_ROUNDL 1 +extern long double roundl(long double); +#endif + + + +#if !defined(HAVE_LROUNDF) && defined(HAVE_ROUNDF) +#define HAVE_LROUNDF 1 +long int lroundf (float); +#endif + +#if !defined(HAVE_LROUND) && defined(HAVE_ROUND) +#define HAVE_LROUND 1 +long int lround (double); +#endif + +#if !defined(HAVE_LROUNDL) && defined(HAVE_ROUNDL) +#define HAVE_LROUNDL 1 +long int lroundl (long double); +#endif + +#if !defined(HAVE_LLROUNDF) && defined(HAVE_ROUNDF) +#define HAVE_LLROUNDF 1 +long long int llroundf (float); +#endif + +#if !defined(HAVE_LLROUND) && defined(HAVE_ROUND) +#define HAVE_LLROUND 1 +long long int llround (double); +#endif + +#if !defined(HAVE_LLROUNDL) && defined(HAVE_ROUNDL) +#define HAVE_LLROUNDL 1 +long long int llroundl (long double); +#endif + /* Wrappers for systems without the various C99 single precision Bessel functions. */ @@ -465,5 +502,27 @@ extern long double complex ctanl (long double complex); #endif +/* Gamma-related prototypes. */ +#if !defined(HAVE_TGAMMA) +#define HAVE_TGAMMA 1 +extern double tgamma (double); +#endif + +#if !defined(HAVE_LGAMMA) +#define HAVE_LGAMMA 1 +extern double lgamma (double); +#endif + +#if defined(HAVE_TGAMMA) && !defined(HAVE_TGAMMAF) +#define HAVE_TGAMMAF 1 +extern float tgammaf (float); +#endif + +#if defined(HAVE_LGAMMA) && !defined(HAVE_LGAMMAF) +#define HAVE_LGAMMAF 1 +extern float lgammaf (float); +#endif + + #endif /* C99_PROTOS_H */ diff --git a/libgfortran/config.h.in b/libgfortran/config.h.in index 205aca30c07..72d46d9e365 100644 --- a/libgfortran/config.h.in +++ b/libgfortran/config.h.in @@ -270,6 +270,12 @@ /* Define to 1 if you have the `ctime' function. */ #undef HAVE_CTIME +/* Define to 1 if you have the <dlfcn.h> header file. */ +#undef HAVE_DLFCN_H + +/* Define to 1 if you have the `dup' function. */ +#undef HAVE_DUP + /* Define to 1 if you have the `dup2' function. */ #undef HAVE_DUP2 @@ -381,6 +387,9 @@ /* Define to 1 if you have the `ftruncate' function. */ #undef HAVE_FTRUNCATE +/* Define to 1 if you have the `getcwd' function. */ +#undef HAVE_GETCWD + /* libc includes geteuid */ #undef HAVE_GETEUID @@ -474,9 +483,27 @@ /* libm includes ldexpl */ #undef HAVE_LDEXPL +/* libm includes lgamma */ +#undef HAVE_LGAMMA + +/* libm includes lgammaf */ +#undef HAVE_LGAMMAF + +/* libm includes lgammal */ +#undef HAVE_LGAMMAL + /* Define to 1 if you have the `link' function. */ #undef HAVE_LINK +/* libm includes llround */ +#undef HAVE_LLROUND + +/* libm includes llroundf */ +#undef HAVE_LLROUNDF + +/* libm includes llroundl */ +#undef HAVE_LLROUNDL + /* libm includes log */ #undef HAVE_LOG @@ -495,12 +522,24 @@ /* libm includes logl */ #undef HAVE_LOGL +/* libm includes lround */ +#undef HAVE_LROUND + +/* libm includes lroundf */ +#undef HAVE_LROUNDF + +/* libm includes lroundl */ +#undef HAVE_LROUNDL + /* Define to 1 if you have the `lstat' function. */ #undef HAVE_LSTAT /* Define to 1 if you have the <memory.h> header file. */ #undef HAVE_MEMORY_H +/* Define if you have __mingw_snprintf. */ +#undef HAVE_MINGW_SNPRINTF + /* Define to 1 if you have the `mkstemp' function. */ #undef HAVE_MKSTEMP @@ -594,9 +633,15 @@ /* Define to 1 if you have the `stat' function. */ #undef HAVE_STAT +/* Define to 1 if you have the <stdarg.h> header file. */ +#undef HAVE_STDARG_H + /* Define to 1 if you have the <stdint.h> header file. */ #undef HAVE_STDINT_H +/* Define to 1 if you have the <stdio.h> header file. */ +#undef HAVE_STDIO_H + /* Define to 1 if you have the <stdlib.h> header file. */ #undef HAVE_STDLIB_H @@ -669,6 +714,15 @@ /* libm includes tanl */ #undef HAVE_TANL +/* libm includes tgamma */ +#undef HAVE_TGAMMA + +/* libm includes tgammaf */ +#undef HAVE_TGAMMAF + +/* libm includes tgammal */ +#undef HAVE_TGAMMAL + /* Define to 1 if you have the `time' function. */ #undef HAVE_TIME @@ -696,6 +750,9 @@ /* Define if target can unlink open files. */ #undef HAVE_UNLINK_OPEN_FILE +/* Define to 1 if you have the `vsnprintf' function. */ +#undef HAVE_VSNPRINTF + /* Define to 1 if you have the `wait' function. */ #undef HAVE_WAIT @@ -729,6 +786,10 @@ /* libm includes ynl */ #undef HAVE_YNL +/* Define to the sub-directory in which libtool stores uninstalled libraries. + */ +#undef LT_OBJDIR + /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT @@ -765,9 +826,6 @@ /* Define to 1 if the target supports #pragma weak */ #undef SUPPORTS_WEAK -/* Define to 1 if the target is ILP32. */ -#undef TARGET_ILP32 - /* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */ #undef TIME_WITH_SYS_TIME diff --git a/libgfortran/config/fpu-387.h b/libgfortran/config/fpu-387.h index 5678ade3f6a..f96f7156619 100644 --- a/libgfortran/config/fpu-387.h +++ b/libgfortran/config/fpu-387.h @@ -1,5 +1,5 @@ /* FPU-related code for x86 and x86_64 processors. - Copyright 2005 Free Software Foundation, Inc. + Copyright 2005, 2007 Free Software Foundation, Inc. Contributed by Francois-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,79 +28,68 @@ 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. */ -#define SSE (1 << 25) +#ifndef __x86_64__ +#include "cpuid.h" +#endif static int has_sse (void) { -#ifdef __x86_64__ - return 1; -#else +#ifndef __x86_64__ unsigned int eax, ebx, ecx, edx; - /* See if we can use cpuid. */ - asm volatile ("pushfl; pushfl; popl %0; movl %0,%1; xorl %2,%0;" - "pushl %0; popfl; pushfl; popl %0; popfl" - : "=&r" (eax), "=&r" (ebx) - : "i" (0x00200000)); - - if (((eax ^ ebx) & 0x00200000) == 0) - return 0; - - /* Check the highest input value for eax. */ - asm volatile ("xchgl %%ebx, %1; cpuid; xchgl %%ebx, %1" - : "=a" (eax), "=r" (ebx), "=c" (ecx), "=d" (edx) - : "0" (0)); - - if (eax == 0) + if (!__get_cpuid (1, &eax, &ebx, &ecx, &edx)) return 0; - asm volatile ("xchgl %%ebx, %1; cpuid; xchgl %%ebx, %1" - : "=a" (eax), "=r" (ebx), "=c" (ecx), "=d" (edx) - : "0" (1)); - - if (edx & SSE) - return 1; - - return 0; + return edx & bit_SSE; +#else + return 1; #endif } -void set_fpu (void) -{ - unsigned short cw; - unsigned int cw_sse; - - /* i387 -- see linux <fpu_control.h> header file for details. */ +/* i387 -- see linux <fpu_control.h> header file for details. */ #define _FPU_MASK_IM 0x01 #define _FPU_MASK_DM 0x02 #define _FPU_MASK_ZM 0x04 #define _FPU_MASK_OM 0x08 #define _FPU_MASK_UM 0x10 #define _FPU_MASK_PM 0x20 + +void set_fpu (void) +{ + unsigned short cw; + asm volatile ("fnstcw %0" : "=m" (cw)); - cw |= _FPU_MASK_IM | _FPU_MASK_DM | _FPU_MASK_ZM | _FPU_MASK_OM | _FPU_MASK_UM | _FPU_MASK_PM; + + cw |= (_FPU_MASK_IM | _FPU_MASK_DM | _FPU_MASK_ZM | _FPU_MASK_OM + | _FPU_MASK_UM | _FPU_MASK_PM); + if (options.fpe & GFC_FPE_INVALID) cw &= ~_FPU_MASK_IM; if (options.fpe & GFC_FPE_DENORMAL) cw &= ~_FPU_MASK_DM; if (options.fpe & GFC_FPE_ZERO) cw &= ~_FPU_MASK_ZM; if (options.fpe & GFC_FPE_OVERFLOW) cw &= ~_FPU_MASK_OM; if (options.fpe & GFC_FPE_UNDERFLOW) cw &= ~_FPU_MASK_UM; if (options.fpe & GFC_FPE_PRECISION) cw &= ~_FPU_MASK_PM; + asm volatile ("fldcw %0" : : "m" (cw)); if (has_sse()) { - /* SSE */ + unsigned int cw_sse; + asm volatile ("stmxcsr %0" : "=m" (cw_sse)); - cw_sse &= 0xFFFF0000; + + cw_sse &= 0xffff0000; cw_sse |= (_FPU_MASK_IM | _FPU_MASK_DM | _FPU_MASK_ZM | _FPU_MASK_OM | _FPU_MASK_UM | _FPU_MASK_PM ) << 7; + if (options.fpe & GFC_FPE_INVALID) cw_sse &= ~(_FPU_MASK_IM << 7); if (options.fpe & GFC_FPE_DENORMAL) cw_sse &= ~(_FPU_MASK_DM << 7); if (options.fpe & GFC_FPE_ZERO) cw_sse &= ~(_FPU_MASK_ZM << 7); if (options.fpe & GFC_FPE_OVERFLOW) cw_sse &= ~(_FPU_MASK_OM << 7); if (options.fpe & GFC_FPE_UNDERFLOW) cw_sse &= ~(_FPU_MASK_UM << 7); if (options.fpe & GFC_FPE_PRECISION) cw_sse &= ~(_FPU_MASK_PM << 7); + asm volatile ("ldmxcsr %0" : : "m" (cw_sse)); } } diff --git a/libgfortran/config/fpu-aix.h b/libgfortran/config/fpu-aix.h index 7669fd857bf..82d9c7d25be 100644 --- a/libgfortran/config/fpu-aix.h +++ b/libgfortran/config/fpu-aix.h @@ -1,5 +1,5 @@ /* AIX FPU-related code. - Copyright 2005 Free Software Foundation, Inc. + Copyright 2005, 2007 Free Software Foundation, Inc. Contributed by Francois-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/config/fpu-generic.h b/libgfortran/config/fpu-generic.h index 9e043d74895..89f5b83d3d6 100644 --- a/libgfortran/config/fpu-generic.h +++ b/libgfortran/config/fpu-generic.h @@ -1,5 +1,5 @@ /* Fallback FPU-related code (for systems not otherwise supported). - Copyright 2005 Free Software Foundation, Inc. + Copyright 2005, 2007 Free Software Foundation, Inc. Contributed by Francois-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/config/fpu-glibc.h b/libgfortran/config/fpu-glibc.h index 8b0801a96b6..27809676fad 100644 --- a/libgfortran/config/fpu-glibc.h +++ b/libgfortran/config/fpu-glibc.h @@ -1,5 +1,5 @@ /* FPU-related code for systems with GNU libc. - Copyright 2005 Free Software Foundation, Inc. + Copyright 2005, 2007 Free Software Foundation, Inc. Contributed by Francois-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/config/fpu-sysv.h b/libgfortran/config/fpu-sysv.h index b08df141e23..622e5ea73b1 100644 --- a/libgfortran/config/fpu-sysv.h +++ b/libgfortran/config/fpu-sysv.h @@ -1,5 +1,5 @@ /* SysV FPU-related code (for systems not otherwise supported). - Copyright 2005 Free Software Foundation, Inc. + Copyright 2005, 2007 Free Software Foundation, Inc. Contributed by Francois-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/configure b/libgfortran/configure index ca967e479d5..4622d5e3848 100755 --- a/libgfortran/configure +++ b/libgfortran/configure @@ -457,7 +457,7 @@ ac_includes_default="\ # include <unistd.h> #endif" -ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS build build_cpu build_vendor build_os build_libsubdir build_subdir host_subdir target_subdir host host_cpu host_vendor host_os target target_cpu target_vendor target_os INSTALL_PROGRAM INSTALL_SCRIPT INSTALL_DATA CYGPATH_W PACKAGE VERSION ACLOCAL AUTOCONF AUTOMAKE AUTOHEADER MAKEINFO install_sh STRIP ac_ct_STRIP INSTALL_STRIP_PROGRAM mkdir_p AWK SET_MAKE am__leading_dot AMTAR am__tar am__untar MAINTAINER_MODE_TRUE MAINTAINER_MODE_FALSE MAINT multi_basedir toolexecdir toolexeclibdir CC ac_ct_CC EXEEXT OBJEXT DEPDIR am__include am__quote AMDEP_TRUE AMDEP_FALSE AMDEPBACKSLASH CCDEPMODE am__fastdepCC_TRUE am__fastdepCC_FALSE AM_FCFLAGS AM_CFLAGS CFLAGS LIBGFOR_USE_SYMVER_TRUE LIBGFOR_USE_SYMVER_FALSE AS ac_ct_AS AR ac_ct_AR RANLIB ac_ct_RANLIB LIBTOOL SED EGREP FGREP GREP LD DUMPBIN ac_ct_DUMPBIN NM LN_S lt_ECHO CPP CPPFLAGS enable_shared enable_static FC FCFLAGS LDFLAGS ac_ct_FC extra_ldflags_libgfortran FPU_HOST_HEADER LIBOBJS LTLIBOBJS' +ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS build build_cpu build_vendor build_os build_libsubdir build_subdir host_subdir target_subdir onestep_TRUE onestep_FALSE onestep host host_cpu host_vendor host_os target target_cpu target_vendor target_os INSTALL_PROGRAM INSTALL_SCRIPT INSTALL_DATA CYGPATH_W PACKAGE VERSION ACLOCAL AUTOCONF AUTOMAKE AUTOHEADER MAKEINFO install_sh STRIP ac_ct_STRIP INSTALL_STRIP_PROGRAM mkdir_p AWK SET_MAKE am__leading_dot AMTAR am__tar am__untar MAINTAINER_MODE_TRUE MAINTAINER_MODE_FALSE MAINT multi_basedir toolexecdir toolexeclibdir CC ac_ct_CC EXEEXT OBJEXT DEPDIR am__include am__quote AMDEP_TRUE AMDEP_FALSE AMDEPBACKSLASH CCDEPMODE am__fastdepCC_TRUE am__fastdepCC_FALSE AM_FCFLAGS AM_CFLAGS CFLAGS LIBGFOR_USE_SYMVER_TRUE LIBGFOR_USE_SYMVER_FALSE AS ac_ct_AS AR ac_ct_AR RANLIB ac_ct_RANLIB LIBTOOL SED EGREP FGREP GREP LD DUMPBIN ac_ct_DUMPBIN NM LN_S lt_ECHO CPP CPPFLAGS enable_shared enable_static FC FCFLAGS LDFLAGS ac_ct_FC extra_ldflags_libgfortran FPU_HOST_HEADER LIBOBJS LTLIBOBJS' ac_subst_files='' # Initialize some variables set by options. @@ -867,13 +867,13 @@ echo X"$0" | /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` srcdir=$ac_confdir - if test ! -r $srcdir/$ac_unique_file; then + if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi -if test ! -r $srcdir/$ac_unique_file; then +if test ! -r "$srcdir/$ac_unique_file"; then if test "$ac_srcdir_defaulted" = yes; then { echo "$as_me: error: cannot find sources ($ac_unique_file) in $ac_confdir or .." >&2 { (exit 1); exit 1; }; } @@ -882,7 +882,7 @@ if test ! -r $srcdir/$ac_unique_file; then { (exit 1); exit 1; }; } fi fi -(cd $srcdir && test -r ./$ac_unique_file) 2>/dev/null || +(cd $srcdir && test -r "./$ac_unique_file") 2>/dev/null || { echo "$as_me: error: sources are in $srcdir, but \`cd $srcdir' does not work" >&2 { (exit 1); exit 1; }; } srcdir=`echo "$srcdir" | sed 's%\([^\\/]\)[\\/]*$%\1%'` @@ -1001,6 +1001,7 @@ Optional Features: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-version-specific-runtime-libs Specify that runtime libraries should be installed in a compiler-specific directory + --enable-intermodule build the library in one step --enable-maintainer-mode enable make rules and dependencies not useful (and sometimes confusing) to the casual installer --enable-multilib build many library versions (default) @@ -1609,6 +1610,32 @@ fi; echo "$as_me:$LINENO: result: $version_specific_libs" >&5 echo "${ECHO_T}$version_specific_libs" >&6 +# Build with intermodule optimisations +echo "$as_me:$LINENO: checking for --enable-intermodule" >&5 +echo $ECHO_N "checking for --enable-intermodule... $ECHO_C" >&6 +# Check whether --enable-intermodule or --disable-intermodule was given. +if test "${enable_intermodule+set}" = set; then + enableval="$enable_intermodule" + case "$enable_intermodule" in + yes) onestep="-onestep";; + *) onestep="";; +esac +else + onestep="" +fi; +echo "$as_me:$LINENO: result: $enable_intermodule" >&5 +echo "${ECHO_T}$enable_intermodule" >&6 + + +if test x$onestep = x-onestep; then + onestep_TRUE= + onestep_FALSE='#' +else + onestep_TRUE='#' + onestep_FALSE= +fi + + # Gets build, host, target, *_vendor, *_cpu, *_os, etc. # @@ -3359,6 +3386,7 @@ fi + # Check for symbol versioning (copied from libssp). echo "$as_me:$LINENO: checking whether symbol versioning is supported" >&5 echo $ECHO_N "checking whether symbol versioning is supported... $ECHO_C" >&6 @@ -4320,13 +4348,13 @@ if test "${lt_cv_nm_interface+set}" = set; then else lt_cv_nm_interface="BSD nm" echo "int some_variable = 0;" > conftest.$ac_ext - (eval echo "\"\$as_me:4323: $ac_compile\"" >&5) + (eval echo "\"\$as_me:4351: $ac_compile\"" >&5) (eval "$ac_compile" 2>conftest.err) cat conftest.err >&5 - (eval echo "\"\$as_me:4326: $NM \\\"conftest.$ac_objext\\\"\"" >&5) + (eval echo "\"\$as_me:4354: $NM \\\"conftest.$ac_objext\\\"\"" >&5) (eval "$NM \"conftest.$ac_objext\"" 2>conftest.err > conftest.out) cat conftest.err >&5 - (eval echo "\"\$as_me:4329: output\"" >&5) + (eval echo "\"\$as_me:4357: output\"" >&5) cat conftest.out >&5 if $GREP 'External.*some_variable' conftest.out > /dev/null; then lt_cv_nm_interface="MS dumpbin" @@ -4593,7 +4621,7 @@ lt_cv_deplibs_check_method='unknown' # whether `pass_all' will *always* work, you probably want this one. case $host_os in -aix4* | aix5*) +aix[4-9]*) lt_cv_deplibs_check_method=pass_all ;; @@ -5381,7 +5409,7 @@ ia64-*-hpux*) ;; *-*-irix6*) # Find out which ABI we are using. - echo '#line 5384 "configure"' > conftest.$ac_ext + echo '#line 5412 "configure"' > conftest.$ac_ext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>&5 ac_status=$? @@ -6486,11 +6514,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:6489: $lt_compile\"" >&5) + (eval echo "\"\$as_me:6517: $lt_compile\"" >&5) (eval "$lt_compile" 2>conftest.err) ac_status=$? cat conftest.err >&5 - echo "$as_me:6493: \$? = $ac_status" >&5 + echo "$as_me:6521: \$? = $ac_status" >&5 if (exit $ac_status) && test -s "$ac_outfile"; then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings other than the usual output. @@ -6808,11 +6836,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:6811: $lt_compile\"" >&5) + (eval echo "\"\$as_me:6839: $lt_compile\"" >&5) (eval "$lt_compile" 2>conftest.err) ac_status=$? cat conftest.err >&5 - echo "$as_me:6815: \$? = $ac_status" >&5 + echo "$as_me:6843: \$? = $ac_status" >&5 if (exit $ac_status) && test -s "$ac_outfile"; then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings other than the usual output. @@ -6913,11 +6941,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:6916: $lt_compile\"" >&5) + (eval echo "\"\$as_me:6944: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 - echo "$as_me:6920: \$? = $ac_status" >&5 + echo "$as_me:6948: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized @@ -6968,11 +6996,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:6971: $lt_compile\"" >&5) + (eval echo "\"\$as_me:6999: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 - echo "$as_me:6975: \$? = $ac_status" >&5 + echo "$as_me:7003: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized @@ -7116,7 +7144,7 @@ echo $ECHO_N "checking whether the $compiler linker ($LD) supports shared librar # See if GNU ld supports shared libraries. case $host_os in - aix3* | aix4* | aix5*) + aix[3-9]*) # On AIX/PPC, the GNU linker is very broken if test "$host_cpu" != ia64; then ld_shlibs=no @@ -7350,7 +7378,7 @@ _LT_EOF fi ;; - aix4* | aix5*) + aix[4-9]*) if test "$host_cpu" = ia64; then # On IA64, the linker does run time linking by default, so we don't # have to do anything special. @@ -7370,7 +7398,7 @@ _LT_EOF # Test if we are trying to use run time linking or normal # AIX style linking. If -brtl is somewhere in LDFLAGS, we # need to do runtime linking. - case $host_os in aix4.[23]|aix4.[23].*|aix5*) + case $host_os in aix4.[23]|aix4.[23].*|aix[5-9]*) for ld_flag in $LDFLAGS; do if (test $ld_flag = "-brtl" || test $ld_flag = "-Wl,-brtl"); then aix_use_runtimelinking=yes @@ -8445,7 +8473,7 @@ aix3*) soname_spec='${libname}${release}${shared_ext}$major' ;; -aix4* | aix5*) +aix[4-9]*) version_type=linux need_lib_prefix=no need_version=no @@ -9820,7 +9848,7 @@ else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 lt_status=$lt_dlunknown cat > conftest.$ac_ext <<_LT_EOF -#line 9823 "configure" +#line 9851 "configure" #include "confdefs.h" #if HAVE_DLFCN_H @@ -9920,7 +9948,7 @@ else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 lt_status=$lt_dlunknown cat > conftest.$ac_ext <<_LT_EOF -#line 9923 "configure" +#line 9951 "configure" #include "confdefs.h" #if HAVE_DLFCN_H @@ -10103,7 +10131,7 @@ echo $ECHO_N "checking whether to build shared libraries... $ECHO_C" >&6 fi ;; - aix4* | aix5*) + aix[4-9]*) if test "$host_cpu" != ia64 && test "$aix_use_runtimelinking" = no ; then test "$enable_shared" = yes && enable_static=no fi @@ -10250,7 +10278,7 @@ fi # Provide some information about the compiler. -echo "$as_me:10253:" \ +echo "$as_me:10281:" \ "checking for Fortran compiler version" >&5 ac_compiler=`set X $ac_compile; echo $2` { (eval echo "$as_me:$LINENO: \"$ac_compiler --version </dev/null >&5\"") >&5 @@ -10486,7 +10514,7 @@ fi # Provide some information about the compiler. -echo "$as_me:10489:" \ +echo "$as_me:10517:" \ "checking for Fortran compiler version" >&5 ac_compiler=`set X $ac_compile; echo $2` { (eval echo "$as_me:$LINENO: \"$ac_compiler --version </dev/null >&5\"") >&5 @@ -10754,7 +10782,7 @@ echo $ECHO_N "checking whether to build shared libraries... $ECHO_C" >&6 postinstall_cmds='$RANLIB $lib' fi ;; - aix4* | aix5*) + aix[4-9]*) if test "$host_cpu" != ia64 && test "$aix_use_runtimelinking" = no ; then test "$enable_shared" = yes && enable_static=no fi @@ -11202,11 +11230,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:11205: $lt_compile\"" >&5) + (eval echo "\"\$as_me:11233: $lt_compile\"" >&5) (eval "$lt_compile" 2>conftest.err) ac_status=$? cat conftest.err >&5 - echo "$as_me:11209: \$? = $ac_status" >&5 + echo "$as_me:11237: \$? = $ac_status" >&5 if (exit $ac_status) && test -s "$ac_outfile"; then # The compiler can only warn and ignore the option if not recognized # So say no if there are warnings other than the usual output. @@ -11301,11 +11329,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:11304: $lt_compile\"" >&5) + (eval echo "\"\$as_me:11332: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 - echo "$as_me:11308: \$? = $ac_status" >&5 + echo "$as_me:11336: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized @@ -11353,11 +11381,11 @@ else -e 's:.*FLAGS}\{0,1\} :&$lt_compiler_flag :; t' \ -e 's: [^ ]*conftest\.: $lt_compiler_flag&:; t' \ -e 's:$: $lt_compiler_flag:'` - (eval echo "\"\$as_me:11356: $lt_compile\"" >&5) + (eval echo "\"\$as_me:11384: $lt_compile\"" >&5) (eval "$lt_compile" 2>out/conftest.err) ac_status=$? cat out/conftest.err >&5 - echo "$as_me:11360: \$? = $ac_status" >&5 + echo "$as_me:11388: \$? = $ac_status" >&5 if (exit $ac_status) && test -s out/conftest2.$ac_objext then # The compiler can only warn and ignore the option if not recognized @@ -11498,7 +11526,7 @@ echo $ECHO_N "checking whether the $compiler linker ($LD) supports shared librar # See if GNU ld supports shared libraries. case $host_os in - aix3* | aix4* | aix5*) + aix[3-9]*) # On AIX/PPC, the GNU linker is very broken if test "$host_cpu" != ia64; then ld_shlibs_FC=no @@ -11732,7 +11760,7 @@ _LT_EOF fi ;; - aix4* | aix5*) + aix[4-9]*) if test "$host_cpu" = ia64; then # On IA64, the linker does run time linking by default, so we don't # have to do anything special. @@ -11752,7 +11780,7 @@ _LT_EOF # Test if we are trying to use run time linking or normal # AIX style linking. If -brtl is somewhere in LDFLAGS, we # need to do runtime linking. - case $host_os in aix4.[23]|aix4.[23].*|aix5*) + case $host_os in aix4.[23]|aix4.[23].*|aix[5-9]*) for ld_flag in $LDFLAGS; do if (test $ld_flag = "-brtl" || test $ld_flag = "-Wl,-brtl"); then aix_use_runtimelinking=yes @@ -12654,7 +12682,7 @@ aix3*) soname_spec='${libname}${release}${shared_ext}$major' ;; -aix4* | aix5*) +aix[4-9]*) version_type=linux need_lib_prefix=no need_version=no @@ -14077,7 +14105,9 @@ fi -for ac_header in stdlib.h string.h unistd.h signal.h + + +for ac_header in stdio.h stdlib.h string.h unistd.h signal.h stdarg.h do as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` if eval "test \"\${$as_ac_Header+set}\" = set"; then @@ -18477,7 +18507,10 @@ done -for ac_func in gettimeofday stat fstat lstat getpwuid + + + +for ac_func in gettimeofday stat fstat lstat getpwuid vsnprintf dup getcwd do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 @@ -26310,6 +26343,468 @@ _ACEOF fi +echo "$as_me:$LINENO: checking for lroundf in -lm" >&5 +echo $ECHO_N "checking for lroundf in -lm... $ECHO_C" >&6 +if test "${ac_cv_lib_m_lroundf+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lm $LIBS" +if test x$gcc_no_link = xyes; then + { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5 +echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;} + { (exit 1); exit 1; }; } +fi +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char lroundf (); +int +main () +{ +lroundf (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_m_lroundf=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_m_lroundf=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +echo "$as_me:$LINENO: result: $ac_cv_lib_m_lroundf" >&5 +echo "${ECHO_T}$ac_cv_lib_m_lroundf" >&6 +if test $ac_cv_lib_m_lroundf = yes; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_LROUNDF 1 +_ACEOF + +fi + +echo "$as_me:$LINENO: checking for lround in -lm" >&5 +echo $ECHO_N "checking for lround in -lm... $ECHO_C" >&6 +if test "${ac_cv_lib_m_lround+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lm $LIBS" +if test x$gcc_no_link = xyes; then + { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5 +echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;} + { (exit 1); exit 1; }; } +fi +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char lround (); +int +main () +{ +lround (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_m_lround=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_m_lround=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +echo "$as_me:$LINENO: result: $ac_cv_lib_m_lround" >&5 +echo "${ECHO_T}$ac_cv_lib_m_lround" >&6 +if test $ac_cv_lib_m_lround = yes; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_LROUND 1 +_ACEOF + +fi + +echo "$as_me:$LINENO: checking for lroundl in -lm" >&5 +echo $ECHO_N "checking for lroundl in -lm... $ECHO_C" >&6 +if test "${ac_cv_lib_m_lroundl+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lm $LIBS" +if test x$gcc_no_link = xyes; then + { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5 +echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;} + { (exit 1); exit 1; }; } +fi +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char lroundl (); +int +main () +{ +lroundl (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_m_lroundl=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_m_lroundl=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +echo "$as_me:$LINENO: result: $ac_cv_lib_m_lroundl" >&5 +echo "${ECHO_T}$ac_cv_lib_m_lroundl" >&6 +if test $ac_cv_lib_m_lroundl = yes; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_LROUNDL 1 +_ACEOF + +fi + +echo "$as_me:$LINENO: checking for llroundf in -lm" >&5 +echo $ECHO_N "checking for llroundf in -lm... $ECHO_C" >&6 +if test "${ac_cv_lib_m_llroundf+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lm $LIBS" +if test x$gcc_no_link = xyes; then + { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5 +echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;} + { (exit 1); exit 1; }; } +fi +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char llroundf (); +int +main () +{ +llroundf (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_m_llroundf=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_m_llroundf=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +echo "$as_me:$LINENO: result: $ac_cv_lib_m_llroundf" >&5 +echo "${ECHO_T}$ac_cv_lib_m_llroundf" >&6 +if test $ac_cv_lib_m_llroundf = yes; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_LLROUNDF 1 +_ACEOF + +fi + +echo "$as_me:$LINENO: checking for llround in -lm" >&5 +echo $ECHO_N "checking for llround in -lm... $ECHO_C" >&6 +if test "${ac_cv_lib_m_llround+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lm $LIBS" +if test x$gcc_no_link = xyes; then + { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5 +echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;} + { (exit 1); exit 1; }; } +fi +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char llround (); +int +main () +{ +llround (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_m_llround=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_m_llround=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +echo "$as_me:$LINENO: result: $ac_cv_lib_m_llround" >&5 +echo "${ECHO_T}$ac_cv_lib_m_llround" >&6 +if test $ac_cv_lib_m_llround = yes; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_LLROUND 1 +_ACEOF + +fi + +echo "$as_me:$LINENO: checking for llroundl in -lm" >&5 +echo $ECHO_N "checking for llroundl in -lm... $ECHO_C" >&6 +if test "${ac_cv_lib_m_llroundl+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lm $LIBS" +if test x$gcc_no_link = xyes; then + { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5 +echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;} + { (exit 1); exit 1; }; } +fi +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char llroundl (); +int +main () +{ +llroundl (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_m_llroundl=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_m_llroundl=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +echo "$as_me:$LINENO: result: $ac_cv_lib_m_llroundl" >&5 +echo "${ECHO_T}$ac_cv_lib_m_llroundl" >&6 +if test $ac_cv_lib_m_llroundl = yes; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_LLROUNDL 1 +_ACEOF + +fi + echo "$as_me:$LINENO: checking for scalbnf in -lm" >&5 echo $ECHO_N "checking for scalbnf in -lm... $ECHO_C" >&6 if test "${ac_cv_lib_m_scalbnf+set}" = set; then @@ -30930,6 +31425,468 @@ _ACEOF fi +echo "$as_me:$LINENO: checking for tgamma in -lm" >&5 +echo $ECHO_N "checking for tgamma in -lm... $ECHO_C" >&6 +if test "${ac_cv_lib_m_tgamma+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lm $LIBS" +if test x$gcc_no_link = xyes; then + { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5 +echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;} + { (exit 1); exit 1; }; } +fi +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char tgamma (); +int +main () +{ +tgamma (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_m_tgamma=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_m_tgamma=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +echo "$as_me:$LINENO: result: $ac_cv_lib_m_tgamma" >&5 +echo "${ECHO_T}$ac_cv_lib_m_tgamma" >&6 +if test $ac_cv_lib_m_tgamma = yes; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_TGAMMA 1 +_ACEOF + +fi + +echo "$as_me:$LINENO: checking for tgammaf in -lm" >&5 +echo $ECHO_N "checking for tgammaf in -lm... $ECHO_C" >&6 +if test "${ac_cv_lib_m_tgammaf+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lm $LIBS" +if test x$gcc_no_link = xyes; then + { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5 +echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;} + { (exit 1); exit 1; }; } +fi +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char tgammaf (); +int +main () +{ +tgammaf (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_m_tgammaf=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_m_tgammaf=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +echo "$as_me:$LINENO: result: $ac_cv_lib_m_tgammaf" >&5 +echo "${ECHO_T}$ac_cv_lib_m_tgammaf" >&6 +if test $ac_cv_lib_m_tgammaf = yes; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_TGAMMAF 1 +_ACEOF + +fi + +echo "$as_me:$LINENO: checking for tgammal in -lm" >&5 +echo $ECHO_N "checking for tgammal in -lm... $ECHO_C" >&6 +if test "${ac_cv_lib_m_tgammal+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lm $LIBS" +if test x$gcc_no_link = xyes; then + { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5 +echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;} + { (exit 1); exit 1; }; } +fi +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char tgammal (); +int +main () +{ +tgammal (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_m_tgammal=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_m_tgammal=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +echo "$as_me:$LINENO: result: $ac_cv_lib_m_tgammal" >&5 +echo "${ECHO_T}$ac_cv_lib_m_tgammal" >&6 +if test $ac_cv_lib_m_tgammal = yes; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_TGAMMAL 1 +_ACEOF + +fi + +echo "$as_me:$LINENO: checking for lgamma in -lm" >&5 +echo $ECHO_N "checking for lgamma in -lm... $ECHO_C" >&6 +if test "${ac_cv_lib_m_lgamma+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lm $LIBS" +if test x$gcc_no_link = xyes; then + { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5 +echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;} + { (exit 1); exit 1; }; } +fi +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char lgamma (); +int +main () +{ +lgamma (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_m_lgamma=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_m_lgamma=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +echo "$as_me:$LINENO: result: $ac_cv_lib_m_lgamma" >&5 +echo "${ECHO_T}$ac_cv_lib_m_lgamma" >&6 +if test $ac_cv_lib_m_lgamma = yes; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_LGAMMA 1 +_ACEOF + +fi + +echo "$as_me:$LINENO: checking for lgammaf in -lm" >&5 +echo $ECHO_N "checking for lgammaf in -lm... $ECHO_C" >&6 +if test "${ac_cv_lib_m_lgammaf+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lm $LIBS" +if test x$gcc_no_link = xyes; then + { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5 +echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;} + { (exit 1); exit 1; }; } +fi +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char lgammaf (); +int +main () +{ +lgammaf (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_m_lgammaf=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_m_lgammaf=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +echo "$as_me:$LINENO: result: $ac_cv_lib_m_lgammaf" >&5 +echo "${ECHO_T}$ac_cv_lib_m_lgammaf" >&6 +if test $ac_cv_lib_m_lgammaf = yes; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_LGAMMAF 1 +_ACEOF + +fi + +echo "$as_me:$LINENO: checking for lgammal in -lm" >&5 +echo $ECHO_N "checking for lgammal in -lm... $ECHO_C" >&6 +if test "${ac_cv_lib_m_lgammal+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lm $LIBS" +if test x$gcc_no_link = xyes; then + { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5 +echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;} + { (exit 1); exit 1; }; } +fi +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char lgammal (); +int +main () +{ +lgammal (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_m_lgammal=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_lib_m_lgammal=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +echo "$as_me:$LINENO: result: $ac_cv_lib_m_lgammal" >&5 +echo "${ECHO_T}$ac_cv_lib_m_lgammal" >&6 +if test $ac_cv_lib_m_lgammal = yes; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_LGAMMAL 1 +_ACEOF + +fi + # On AIX, clog is present in libm as __clog echo "$as_me:$LINENO: checking for __clog in -lm" >&5 @@ -31331,6 +32288,83 @@ _ACEOF fi +# Check whether __mingw_snprintf() is present + + echo "$as_me:$LINENO: checking whether __mingw_snprintf is present" >&5 +echo $ECHO_N "checking whether __mingw_snprintf is present... $ECHO_C" >&6 +if test "${have_mingw_snprintf+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + + if test x$gcc_no_link = xyes; then + { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5 +echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;} + { (exit 1); exit 1; }; } +fi +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +#include <stdio.h> +extern int __mingw_snprintf (char *, size_t, const char *, ...); + +int +main () +{ + +__mingw_snprintf (NULL, 0, "%d\n", 1); + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "have_mingw_snprintf=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "have_mingw_snprintf=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + +fi +echo "$as_me:$LINENO: result: $have_mingw_snprintf" >&5 +echo "${ECHO_T}$have_mingw_snprintf" >&6 + if test x"$have_mingw_snprintf" = xyes; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_MINGW_SNPRINTF 1 +_ACEOF + + fi + + # Check for GNU libc feenableexcept echo "$as_me:$LINENO: checking for feenableexcept in -lm" >&5 echo $ECHO_N "checking for feenableexcept in -lm... $ECHO_C" >&6 @@ -31705,86 +32739,6 @@ echo "$as_me: FPU dependent file will be ${fpu_host}.h" >&6;} FPU_HOST_HEADER=config/${fpu_host}.h -# Attempt to assert that the target is of common type in case we don't -# have C99 integer types at all. - - echo "$as_me:$LINENO: checking whether the target is ILP32" >&5 -echo $ECHO_N "checking whether the target is ILP32... $ECHO_C" >&6 -if test "${target_ilp32+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - - save_CFLAGS="$CFLAGS" - CFLAGS="-O2" - if test x$gcc_no_link = xyes; then - { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5 -echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;} - { (exit 1); exit 1; }; } -fi -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - -int -main () -{ - -if (sizeof(int) == 4 && sizeof(long) == 4 && sizeof(void *) == 4) - ; -else - undefined_function (); - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - target_ilp32=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -target_ilp32=no -fi -rm -f conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext - CFLAGS="$save_CFLAGS" -fi -echo "$as_me:$LINENO: result: $target_ilp32" >&5 -echo "${ECHO_T}$target_ilp32" >&6 - if test $target_ilp32 = yes; then - -cat >>confdefs.h <<\_ACEOF -#define TARGET_ILP32 1 -_ACEOF - - fi - - # Check out attribute support. echo "$as_me:$LINENO: checking whether the target supports hidden visibility" >&5 @@ -32147,7 +33101,7 @@ _ACEOF fi case "$host" in - *-*-darwin* | *-*-hpux* | *-*-cygwin*) + *-*-darwin* | *-*-hpux* | *-*-cygwin* | *-*-mingw* ) cat >>confdefs.h <<\_ACEOF #define GTHREAD_USE_WEAK 0 @@ -32479,6 +33433,13 @@ LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs +if test -z "${onestep_TRUE}" && test -z "${onestep_FALSE}"; then + { { echo "$as_me:$LINENO: error: conditional \"onestep\" was never defined. +Usually this means the macro was only invoked conditionally." >&5 +echo "$as_me: error: conditional \"onestep\" was never defined. +Usually this means the macro was only invoked conditionally." >&2;} + { (exit 1); exit 1; }; } +fi if test -z "${MAINTAINER_MODE_TRUE}" && test -z "${MAINTAINER_MODE_FALSE}"; then { { echo "$as_me:$LINENO: error: conditional \"MAINTAINER_MODE\" was never defined. Usually this means the macro was only invoked conditionally." >&5 @@ -33412,6 +34373,9 @@ s,@build_libsubdir@,$build_libsubdir,;t t s,@build_subdir@,$build_subdir,;t t s,@host_subdir@,$host_subdir,;t t s,@target_subdir@,$target_subdir,;t t +s,@onestep_TRUE@,$onestep_TRUE,;t t +s,@onestep_FALSE@,$onestep_FALSE,;t t +s,@onestep@,$onestep,;t t s,@host@,$host,;t t s,@host_cpu@,$host_cpu,;t t s,@host_vendor@,$host_vendor,;t t diff --git a/libgfortran/configure.ac b/libgfortran/configure.ac index 9e1572fa674..a1caf3b47eb 100644 --- a/libgfortran/configure.ac +++ b/libgfortran/configure.ac @@ -21,6 +21,18 @@ AC_ARG_ENABLE(version-specific-runtime-libs, [version_specific_libs=no]) AC_MSG_RESULT($version_specific_libs) +# Build with intermodule optimisations +AC_MSG_CHECKING([for --enable-intermodule]) +AC_ARG_ENABLE(intermodule, +[ --enable-intermodule build the library in one step], +[case "$enable_intermodule" in + yes) onestep="-onestep";; + *) onestep="";; +esac], +[onestep=""]) +AC_MSG_RESULT($enable_intermodule) +AM_CONDITIONAL(onestep,[test x$onestep = x-onestep]) +AC_SUBST(onestep) # Gets build, host, target, *_vendor, *_cpu, *_os, etc. # @@ -176,7 +188,7 @@ AC_TYPE_OFF_T # check header files AC_STDC_HEADERS AC_HEADER_TIME -AC_HAVE_HEADERS(stdlib.h string.h unistd.h signal.h) +AC_HAVE_HEADERS(stdio.h stdlib.h string.h unistd.h signal.h stdarg.h) AC_CHECK_HEADERS(time.h sys/time.h sys/times.h sys/resource.h) AC_CHECK_HEADERS(sys/types.h sys/stat.h sys/wait.h floatingpoint.h ieeefp.h) AC_CHECK_HEADERS(fenv.h fptrap.h float.h execinfo.h pwd.h) @@ -192,7 +204,7 @@ AC_CHECK_FUNCS(getrusage times mkstemp strtof strtold snprintf ftruncate chsize) AC_CHECK_FUNCS(chdir strerror getlogin gethostname kill link symlink perror) AC_CHECK_FUNCS(sleep time ttyname signal alarm ctime clock access fork execl) AC_CHECK_FUNCS(wait setmode execvp pipe dup2 close fdopen strcasestr getrlimit) -AC_CHECK_FUNCS(gettimeofday stat fstat lstat getpwuid) +AC_CHECK_FUNCS(gettimeofday stat fstat lstat getpwuid vsnprintf dup getcwd) # Check for glibc backtrace functions AC_CHECK_FUNCS(backtrace backtrace_symbols) @@ -301,6 +313,12 @@ AC_CHECK_LIB([m],[cpowl],[AC_DEFINE([HAVE_CPOWL],[1],[libm includes cpowl])]) AC_CHECK_LIB([m],[roundf],[AC_DEFINE([HAVE_ROUNDF],[1],[libm includes roundf])]) AC_CHECK_LIB([m],[round],[AC_DEFINE([HAVE_ROUND],[1],[libm includes round])]) AC_CHECK_LIB([m],[roundl],[AC_DEFINE([HAVE_ROUNDL],[1],[libm includes roundl])]) +AC_CHECK_LIB([m],[lroundf],[AC_DEFINE([HAVE_LROUNDF],[1],[libm includes lroundf])]) +AC_CHECK_LIB([m],[lround],[AC_DEFINE([HAVE_LROUND],[1],[libm includes lround])]) +AC_CHECK_LIB([m],[lroundl],[AC_DEFINE([HAVE_LROUNDL],[1],[libm includes lroundl])]) +AC_CHECK_LIB([m],[llroundf],[AC_DEFINE([HAVE_LLROUNDF],[1],[libm includes llroundf])]) +AC_CHECK_LIB([m],[llround],[AC_DEFINE([HAVE_LLROUND],[1],[libm includes llround])]) +AC_CHECK_LIB([m],[llroundl],[AC_DEFINE([HAVE_LLROUNDL],[1],[libm includes llroundl])]) AC_CHECK_LIB([m],[scalbnf],[AC_DEFINE([HAVE_SCALBNF],[1],[libm includes scalbnf])]) AC_CHECK_LIB([m],[scalbn],[AC_DEFINE([HAVE_SCALBN],[1],[libm includes scalbn])]) AC_CHECK_LIB([m],[scalbnl],[AC_DEFINE([HAVE_SCALBNL],[1],[libm includes scalbnl])]) @@ -361,6 +379,12 @@ AC_CHECK_LIB([m],[y1l],[AC_DEFINE([HAVE_Y1L],[1],[libm includes y1l])]) AC_CHECK_LIB([m],[ynf],[AC_DEFINE([HAVE_YNF],[1],[libm includes ynf])]) AC_CHECK_LIB([m],[yn],[AC_DEFINE([HAVE_YN],[1],[libm includes yn])]) AC_CHECK_LIB([m],[ynl],[AC_DEFINE([HAVE_YNL],[1],[libm includes ynl])]) +AC_CHECK_LIB([m],[tgamma],[AC_DEFINE([HAVE_TGAMMA],[1],[libm includes tgamma])]) +AC_CHECK_LIB([m],[tgammaf],[AC_DEFINE([HAVE_TGAMMAF],[1],[libm includes tgammaf])]) +AC_CHECK_LIB([m],[tgammal],[AC_DEFINE([HAVE_TGAMMAL],[1],[libm includes tgammal])]) +AC_CHECK_LIB([m],[lgamma],[AC_DEFINE([HAVE_LGAMMA],[1],[libm includes lgamma])]) +AC_CHECK_LIB([m],[lgammaf],[AC_DEFINE([HAVE_LGAMMAF],[1],[libm includes lgammaf])]) +AC_CHECK_LIB([m],[lgammal],[AC_DEFINE([HAVE_LGAMMAL],[1],[libm includes lgammal])]) # On AIX, clog is present in libm as __clog AC_CHECK_LIB([m],[__clog],[AC_DEFINE([HAVE_CLOG],[1],[libm includes clog])]) @@ -377,6 +401,9 @@ LIBGFOR_CHECK_FOR_BROKEN_FPCLASSIFY # Check whether the system has a working stat() LIBGFOR_CHECK_WORKING_STAT +# Check whether __mingw_snprintf() is present +LIBGFOR_CHECK_MINGW_SNPRINTF + # Check for GNU libc feenableexcept AC_CHECK_LIB([m],[feenableexcept],[have_feenableexcept=yes AC_DEFINE([HAVE_FEENABLEEXCEPT],[1],[libm includes feenableexcept])]) @@ -395,10 +422,6 @@ AC_MSG_NOTICE([FPU dependent file will be ${fpu_host}.h]) FPU_HOST_HEADER=config/${fpu_host}.h AC_SUBST(FPU_HOST_HEADER) -# Attempt to assert that the target is of common type in case we don't -# have C99 integer types at all. -LIBGFOR_TARGET_ILP32 - # Check out attribute support. LIBGFOR_CHECK_ATTRIBUTE_VISIBILITY LIBGFOR_CHECK_ATTRIBUTE_DLLEXPORT diff --git a/libgfortran/fmain.c b/libgfortran/fmain.c index 397f17bdcf5..1d6b45e111d 100644 --- a/libgfortran/fmain.c +++ b/libgfortran/fmain.c @@ -1,4 +1,3 @@ -#include "config.h" #include "libgfortran.h" /* The main Fortran program actually is a function, called MAIN__. diff --git a/libgfortran/generated/_abs_c10.F90 b/libgfortran/generated/_abs_c10.F90 index 791cd5bedf6..a95c35702dd 100644 --- a/libgfortran/generated/_abs_c10.F90 +++ b/libgfortran/generated/_abs_c10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_abs_c16.F90 b/libgfortran/generated/_abs_c16.F90 index ee94cb00c4e..439e254123d 100644 --- a/libgfortran/generated/_abs_c16.F90 +++ b/libgfortran/generated/_abs_c16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_abs_c4.F90 b/libgfortran/generated/_abs_c4.F90 index bc25d6e4a23..74709d170bf 100644 --- a/libgfortran/generated/_abs_c4.F90 +++ b/libgfortran/generated/_abs_c4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_abs_c8.F90 b/libgfortran/generated/_abs_c8.F90 index 4648dd12369..8b6e02a8373 100644 --- a/libgfortran/generated/_abs_c8.F90 +++ b/libgfortran/generated/_abs_c8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_abs_i16.F90 b/libgfortran/generated/_abs_i16.F90 index 72240c24fdf..2a9ca4cb179 100644 --- a/libgfortran/generated/_abs_i16.F90 +++ b/libgfortran/generated/_abs_i16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_abs_i4.F90 b/libgfortran/generated/_abs_i4.F90 index 5f3a1e85d8f..4bd886751f2 100644 --- a/libgfortran/generated/_abs_i4.F90 +++ b/libgfortran/generated/_abs_i4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_abs_i8.F90 b/libgfortran/generated/_abs_i8.F90 index 87f987092b1..ffbf2245f2d 100644 --- a/libgfortran/generated/_abs_i8.F90 +++ b/libgfortran/generated/_abs_i8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_abs_r10.F90 b/libgfortran/generated/_abs_r10.F90 index 4b070d3a99d..80b0a02483e 100644 --- a/libgfortran/generated/_abs_r10.F90 +++ b/libgfortran/generated/_abs_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_abs_r16.F90 b/libgfortran/generated/_abs_r16.F90 index 10edfba79cf..ff5da41bde7 100644 --- a/libgfortran/generated/_abs_r16.F90 +++ b/libgfortran/generated/_abs_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_abs_r4.F90 b/libgfortran/generated/_abs_r4.F90 index 02ebd43fd0e..b8aaa71973e 100644 --- a/libgfortran/generated/_abs_r4.F90 +++ b/libgfortran/generated/_abs_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_abs_r8.F90 b/libgfortran/generated/_abs_r8.F90 index 0d7b62057fc..250e9dd3511 100644 --- a/libgfortran/generated/_abs_r8.F90 +++ b/libgfortran/generated/_abs_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_acos_r10.F90 b/libgfortran/generated/_acos_r10.F90 index 4225572fa30..c41e260191f 100644 --- a/libgfortran/generated/_acos_r10.F90 +++ b/libgfortran/generated/_acos_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_acos_r16.F90 b/libgfortran/generated/_acos_r16.F90 index 90525beef35..0957cacab37 100644 --- a/libgfortran/generated/_acos_r16.F90 +++ b/libgfortran/generated/_acos_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_acos_r4.F90 b/libgfortran/generated/_acos_r4.F90 index 16478e4872f..83d873cf14a 100644 --- a/libgfortran/generated/_acos_r4.F90 +++ b/libgfortran/generated/_acos_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_acos_r8.F90 b/libgfortran/generated/_acos_r8.F90 index 5866b81121c..c7b6a1f5bb0 100644 --- a/libgfortran/generated/_acos_r8.F90 +++ b/libgfortran/generated/_acos_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_acosh_r10.F90 b/libgfortran/generated/_acosh_r10.F90 index 2f7c93d9952..fc8338ab0cf 100644 --- a/libgfortran/generated/_acosh_r10.F90 +++ b/libgfortran/generated/_acosh_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_acosh_r16.F90 b/libgfortran/generated/_acosh_r16.F90 index 010a42ecad0..55a2ed88b78 100644 --- a/libgfortran/generated/_acosh_r16.F90 +++ b/libgfortran/generated/_acosh_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_acosh_r4.F90 b/libgfortran/generated/_acosh_r4.F90 index f6c24839bc1..a55e216ddac 100644 --- a/libgfortran/generated/_acosh_r4.F90 +++ b/libgfortran/generated/_acosh_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_acosh_r8.F90 b/libgfortran/generated/_acosh_r8.F90 index e785507bb84..5d5fe7f4a06 100644 --- a/libgfortran/generated/_acosh_r8.F90 +++ b/libgfortran/generated/_acosh_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_aimag_c10.F90 b/libgfortran/generated/_aimag_c10.F90 index a406cff30a1..24b10911326 100644 --- a/libgfortran/generated/_aimag_c10.F90 +++ b/libgfortran/generated/_aimag_c10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_aimag_c16.F90 b/libgfortran/generated/_aimag_c16.F90 index 32858cfb4f1..98590caae10 100644 --- a/libgfortran/generated/_aimag_c16.F90 +++ b/libgfortran/generated/_aimag_c16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_aimag_c4.F90 b/libgfortran/generated/_aimag_c4.F90 index 118a742de38..b4abd01c294 100644 --- a/libgfortran/generated/_aimag_c4.F90 +++ b/libgfortran/generated/_aimag_c4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_aimag_c8.F90 b/libgfortran/generated/_aimag_c8.F90 index 112c6882d8e..75446bdf7ad 100644 --- a/libgfortran/generated/_aimag_c8.F90 +++ b/libgfortran/generated/_aimag_c8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_aint_r10.F90 b/libgfortran/generated/_aint_r10.F90 index 2853c0c6718..2bf39fc7968 100644 --- a/libgfortran/generated/_aint_r10.F90 +++ b/libgfortran/generated/_aint_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_aint_r16.F90 b/libgfortran/generated/_aint_r16.F90 index 5208c4e6a8a..0e7f46ea7f0 100644 --- a/libgfortran/generated/_aint_r16.F90 +++ b/libgfortran/generated/_aint_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_aint_r4.F90 b/libgfortran/generated/_aint_r4.F90 index 8318dd979da..477e831d495 100644 --- a/libgfortran/generated/_aint_r4.F90 +++ b/libgfortran/generated/_aint_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_aint_r8.F90 b/libgfortran/generated/_aint_r8.F90 index 9f2d712f179..8514bc6cb90 100644 --- a/libgfortran/generated/_aint_r8.F90 +++ b/libgfortran/generated/_aint_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_anint_r10.F90 b/libgfortran/generated/_anint_r10.F90 index 29d11b31fba..744e24273c9 100644 --- a/libgfortran/generated/_anint_r10.F90 +++ b/libgfortran/generated/_anint_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_anint_r16.F90 b/libgfortran/generated/_anint_r16.F90 index bc74dcca91b..7758142e87e 100644 --- a/libgfortran/generated/_anint_r16.F90 +++ b/libgfortran/generated/_anint_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_anint_r4.F90 b/libgfortran/generated/_anint_r4.F90 index f808b5dc9b4..f1824844e6b 100644 --- a/libgfortran/generated/_anint_r4.F90 +++ b/libgfortran/generated/_anint_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_anint_r8.F90 b/libgfortran/generated/_anint_r8.F90 index 33495dcde9f..c6a3544765b 100644 --- a/libgfortran/generated/_anint_r8.F90 +++ b/libgfortran/generated/_anint_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_asin_r10.F90 b/libgfortran/generated/_asin_r10.F90 index cccc6c3465e..c1342996585 100644 --- a/libgfortran/generated/_asin_r10.F90 +++ b/libgfortran/generated/_asin_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_asin_r16.F90 b/libgfortran/generated/_asin_r16.F90 index 6b6f26da6cb..7f3f322572f 100644 --- a/libgfortran/generated/_asin_r16.F90 +++ b/libgfortran/generated/_asin_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_asin_r4.F90 b/libgfortran/generated/_asin_r4.F90 index da9c5e23479..7acebfb2313 100644 --- a/libgfortran/generated/_asin_r4.F90 +++ b/libgfortran/generated/_asin_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_asin_r8.F90 b/libgfortran/generated/_asin_r8.F90 index 62910447a0f..60390278af1 100644 --- a/libgfortran/generated/_asin_r8.F90 +++ b/libgfortran/generated/_asin_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_asinh_r10.F90 b/libgfortran/generated/_asinh_r10.F90 index 24cf6b658bd..2e9bf432f0e 100644 --- a/libgfortran/generated/_asinh_r10.F90 +++ b/libgfortran/generated/_asinh_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_asinh_r16.F90 b/libgfortran/generated/_asinh_r16.F90 index 09a1f49c5aa..e6150405797 100644 --- a/libgfortran/generated/_asinh_r16.F90 +++ b/libgfortran/generated/_asinh_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_asinh_r4.F90 b/libgfortran/generated/_asinh_r4.F90 index f821bc75a9d..e09f8204ace 100644 --- a/libgfortran/generated/_asinh_r4.F90 +++ b/libgfortran/generated/_asinh_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_asinh_r8.F90 b/libgfortran/generated/_asinh_r8.F90 index ab3f70af082..8b50ec778e5 100644 --- a/libgfortran/generated/_asinh_r8.F90 +++ b/libgfortran/generated/_asinh_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_atan2_r10.F90 b/libgfortran/generated/_atan2_r10.F90 index d7ea3920f23..e225d43709c 100644 --- a/libgfortran/generated/_atan2_r10.F90 +++ b/libgfortran/generated/_atan2_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_atan2_r16.F90 b/libgfortran/generated/_atan2_r16.F90 index b2a6d60c0aa..2ea9aa43ede 100644 --- a/libgfortran/generated/_atan2_r16.F90 +++ b/libgfortran/generated/_atan2_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_atan2_r4.F90 b/libgfortran/generated/_atan2_r4.F90 index bfeb726ff1c..3d28cef641b 100644 --- a/libgfortran/generated/_atan2_r4.F90 +++ b/libgfortran/generated/_atan2_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_atan2_r8.F90 b/libgfortran/generated/_atan2_r8.F90 index ef83c9d2831..efc7657a263 100644 --- a/libgfortran/generated/_atan2_r8.F90 +++ b/libgfortran/generated/_atan2_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_atan_r10.F90 b/libgfortran/generated/_atan_r10.F90 index 282393391df..98560a1e955 100644 --- a/libgfortran/generated/_atan_r10.F90 +++ b/libgfortran/generated/_atan_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_atan_r16.F90 b/libgfortran/generated/_atan_r16.F90 index 5b4ccb37830..d3b7996e6f0 100644 --- a/libgfortran/generated/_atan_r16.F90 +++ b/libgfortran/generated/_atan_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_atan_r4.F90 b/libgfortran/generated/_atan_r4.F90 index 74dc979de6c..3b5e4b88efb 100644 --- a/libgfortran/generated/_atan_r4.F90 +++ b/libgfortran/generated/_atan_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_atan_r8.F90 b/libgfortran/generated/_atan_r8.F90 index 55b45bdc3d6..37deac4503c 100644 --- a/libgfortran/generated/_atan_r8.F90 +++ b/libgfortran/generated/_atan_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_atanh_r10.F90 b/libgfortran/generated/_atanh_r10.F90 index 9cee6dde758..702014a34b8 100644 --- a/libgfortran/generated/_atanh_r10.F90 +++ b/libgfortran/generated/_atanh_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_atanh_r16.F90 b/libgfortran/generated/_atanh_r16.F90 index 9322e6a3121..6292c05b410 100644 --- a/libgfortran/generated/_atanh_r16.F90 +++ b/libgfortran/generated/_atanh_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_atanh_r4.F90 b/libgfortran/generated/_atanh_r4.F90 index f08764a78c5..c084a59a588 100644 --- a/libgfortran/generated/_atanh_r4.F90 +++ b/libgfortran/generated/_atanh_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_atanh_r8.F90 b/libgfortran/generated/_atanh_r8.F90 index b3871086e48..2fbbee6d0e9 100644 --- a/libgfortran/generated/_atanh_r8.F90 +++ b/libgfortran/generated/_atanh_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_conjg_c10.F90 b/libgfortran/generated/_conjg_c10.F90 index df082e99a7a..cb94330410a 100644 --- a/libgfortran/generated/_conjg_c10.F90 +++ b/libgfortran/generated/_conjg_c10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_conjg_c16.F90 b/libgfortran/generated/_conjg_c16.F90 index 69565bdb104..5bd334f9392 100644 --- a/libgfortran/generated/_conjg_c16.F90 +++ b/libgfortran/generated/_conjg_c16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_conjg_c4.F90 b/libgfortran/generated/_conjg_c4.F90 index 5dadbec243f..e86ad545504 100644 --- a/libgfortran/generated/_conjg_c4.F90 +++ b/libgfortran/generated/_conjg_c4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_conjg_c8.F90 b/libgfortran/generated/_conjg_c8.F90 index bac101fa1ad..27017175168 100644 --- a/libgfortran/generated/_conjg_c8.F90 +++ b/libgfortran/generated/_conjg_c8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_cos_c10.F90 b/libgfortran/generated/_cos_c10.F90 index e926d862f16..09175364686 100644 --- a/libgfortran/generated/_cos_c10.F90 +++ b/libgfortran/generated/_cos_c10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_cos_c16.F90 b/libgfortran/generated/_cos_c16.F90 index f98ff0f9586..79a9fbd7f21 100644 --- a/libgfortran/generated/_cos_c16.F90 +++ b/libgfortran/generated/_cos_c16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_cos_c4.F90 b/libgfortran/generated/_cos_c4.F90 index 3e7e243e5b5..35280b90fb4 100644 --- a/libgfortran/generated/_cos_c4.F90 +++ b/libgfortran/generated/_cos_c4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_cos_c8.F90 b/libgfortran/generated/_cos_c8.F90 index 6a7d1fa07e6..2b1d1b460f3 100644 --- a/libgfortran/generated/_cos_c8.F90 +++ b/libgfortran/generated/_cos_c8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_cos_r10.F90 b/libgfortran/generated/_cos_r10.F90 index c68230ceb48..85612f75f0f 100644 --- a/libgfortran/generated/_cos_r10.F90 +++ b/libgfortran/generated/_cos_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_cos_r16.F90 b/libgfortran/generated/_cos_r16.F90 index e23e7e737fb..0764f5ec52f 100644 --- a/libgfortran/generated/_cos_r16.F90 +++ b/libgfortran/generated/_cos_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_cos_r4.F90 b/libgfortran/generated/_cos_r4.F90 index 6ae1eadf925..9f274c47eee 100644 --- a/libgfortran/generated/_cos_r4.F90 +++ b/libgfortran/generated/_cos_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_cos_r8.F90 b/libgfortran/generated/_cos_r8.F90 index 0addadc26cc..b489239fb3e 100644 --- a/libgfortran/generated/_cos_r8.F90 +++ b/libgfortran/generated/_cos_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_cosh_r10.F90 b/libgfortran/generated/_cosh_r10.F90 index c82329039e1..ff91eae692a 100644 --- a/libgfortran/generated/_cosh_r10.F90 +++ b/libgfortran/generated/_cosh_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_cosh_r16.F90 b/libgfortran/generated/_cosh_r16.F90 index cb20cd3af0e..b749b4235c6 100644 --- a/libgfortran/generated/_cosh_r16.F90 +++ b/libgfortran/generated/_cosh_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_cosh_r4.F90 b/libgfortran/generated/_cosh_r4.F90 index 6559d778e0e..cc42ca06bc1 100644 --- a/libgfortran/generated/_cosh_r4.F90 +++ b/libgfortran/generated/_cosh_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_cosh_r8.F90 b/libgfortran/generated/_cosh_r8.F90 index 00ff5842d26..08a1a8d22e1 100644 --- a/libgfortran/generated/_cosh_r8.F90 +++ b/libgfortran/generated/_cosh_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_dim_i16.F90 b/libgfortran/generated/_dim_i16.F90 index acfc3a4eabf..90f8e30002a 100644 --- a/libgfortran/generated/_dim_i16.F90 +++ b/libgfortran/generated/_dim_i16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_dim_i4.F90 b/libgfortran/generated/_dim_i4.F90 index 16ef060fbfc..ce0d79129b5 100644 --- a/libgfortran/generated/_dim_i4.F90 +++ b/libgfortran/generated/_dim_i4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_dim_i8.F90 b/libgfortran/generated/_dim_i8.F90 index 01ca82a967f..177bd36b98d 100644 --- a/libgfortran/generated/_dim_i8.F90 +++ b/libgfortran/generated/_dim_i8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_dim_r10.F90 b/libgfortran/generated/_dim_r10.F90 index 1d140004106..c38a43da6ca 100644 --- a/libgfortran/generated/_dim_r10.F90 +++ b/libgfortran/generated/_dim_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_dim_r16.F90 b/libgfortran/generated/_dim_r16.F90 index 1f435b3b555..93aedc59a07 100644 --- a/libgfortran/generated/_dim_r16.F90 +++ b/libgfortran/generated/_dim_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_dim_r4.F90 b/libgfortran/generated/_dim_r4.F90 index 0c4cd5d6b9a..43d5a3fe636 100644 --- a/libgfortran/generated/_dim_r4.F90 +++ b/libgfortran/generated/_dim_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_dim_r8.F90 b/libgfortran/generated/_dim_r8.F90 index f23b0cce1f9..9c0bb64b117 100644 --- a/libgfortran/generated/_dim_r8.F90 +++ b/libgfortran/generated/_dim_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_exp_c10.F90 b/libgfortran/generated/_exp_c10.F90 index 126f55c9536..740aaaa51af 100644 --- a/libgfortran/generated/_exp_c10.F90 +++ b/libgfortran/generated/_exp_c10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_exp_c16.F90 b/libgfortran/generated/_exp_c16.F90 index ad7d4dc7244..27d5264a69e 100644 --- a/libgfortran/generated/_exp_c16.F90 +++ b/libgfortran/generated/_exp_c16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_exp_c4.F90 b/libgfortran/generated/_exp_c4.F90 index 866820b33cc..d721e93fc78 100644 --- a/libgfortran/generated/_exp_c4.F90 +++ b/libgfortran/generated/_exp_c4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_exp_c8.F90 b/libgfortran/generated/_exp_c8.F90 index 2112ce861a0..bc235a62459 100644 --- a/libgfortran/generated/_exp_c8.F90 +++ b/libgfortran/generated/_exp_c8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_exp_r10.F90 b/libgfortran/generated/_exp_r10.F90 index 03e8fa02902..7d758c03df0 100644 --- a/libgfortran/generated/_exp_r10.F90 +++ b/libgfortran/generated/_exp_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_exp_r16.F90 b/libgfortran/generated/_exp_r16.F90 index a88733c91f4..01926174286 100644 --- a/libgfortran/generated/_exp_r16.F90 +++ b/libgfortran/generated/_exp_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_exp_r4.F90 b/libgfortran/generated/_exp_r4.F90 index 0d71d2e493b..70602e1af7f 100644 --- a/libgfortran/generated/_exp_r4.F90 +++ b/libgfortran/generated/_exp_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_exp_r8.F90 b/libgfortran/generated/_exp_r8.F90 index e0e2c8d057a..2c0cea7638a 100644 --- a/libgfortran/generated/_exp_r8.F90 +++ b/libgfortran/generated/_exp_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_log10_r10.F90 b/libgfortran/generated/_log10_r10.F90 index f293489eb18..0ca078d1e8e 100644 --- a/libgfortran/generated/_log10_r10.F90 +++ b/libgfortran/generated/_log10_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_log10_r16.F90 b/libgfortran/generated/_log10_r16.F90 index f690879953b..b3beed5d378 100644 --- a/libgfortran/generated/_log10_r16.F90 +++ b/libgfortran/generated/_log10_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_log10_r4.F90 b/libgfortran/generated/_log10_r4.F90 index bcadf2417ee..7a9438c0280 100644 --- a/libgfortran/generated/_log10_r4.F90 +++ b/libgfortran/generated/_log10_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_log10_r8.F90 b/libgfortran/generated/_log10_r8.F90 index 7d55ad703e7..79acb5d46ea 100644 --- a/libgfortran/generated/_log10_r8.F90 +++ b/libgfortran/generated/_log10_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_log_c10.F90 b/libgfortran/generated/_log_c10.F90 index 90e415bcd2e..df807e486b6 100644 --- a/libgfortran/generated/_log_c10.F90 +++ b/libgfortran/generated/_log_c10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_log_c16.F90 b/libgfortran/generated/_log_c16.F90 index d9db7cea035..7488d39d5b6 100644 --- a/libgfortran/generated/_log_c16.F90 +++ b/libgfortran/generated/_log_c16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_log_c4.F90 b/libgfortran/generated/_log_c4.F90 index 550ed1d6eed..791d1690151 100644 --- a/libgfortran/generated/_log_c4.F90 +++ b/libgfortran/generated/_log_c4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_log_c8.F90 b/libgfortran/generated/_log_c8.F90 index ee26dc21f15..931a999695e 100644 --- a/libgfortran/generated/_log_c8.F90 +++ b/libgfortran/generated/_log_c8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_log_r10.F90 b/libgfortran/generated/_log_r10.F90 index ca7d3374389..de3afdf2206 100644 --- a/libgfortran/generated/_log_r10.F90 +++ b/libgfortran/generated/_log_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_log_r16.F90 b/libgfortran/generated/_log_r16.F90 index 7bd4038a500..83c15b67273 100644 --- a/libgfortran/generated/_log_r16.F90 +++ b/libgfortran/generated/_log_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_log_r4.F90 b/libgfortran/generated/_log_r4.F90 index b4e6217bfe1..ad10a47edfb 100644 --- a/libgfortran/generated/_log_r4.F90 +++ b/libgfortran/generated/_log_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_log_r8.F90 b/libgfortran/generated/_log_r8.F90 index a0b149b16ce..120145d49fe 100644 --- a/libgfortran/generated/_log_r8.F90 +++ b/libgfortran/generated/_log_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_mod_i16.F90 b/libgfortran/generated/_mod_i16.F90 index fd851b8d218..ce9f622e8f8 100644 --- a/libgfortran/generated/_mod_i16.F90 +++ b/libgfortran/generated/_mod_i16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_mod_i4.F90 b/libgfortran/generated/_mod_i4.F90 index 7f5bcb22015..e8ca186ee74 100644 --- a/libgfortran/generated/_mod_i4.F90 +++ b/libgfortran/generated/_mod_i4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_mod_i8.F90 b/libgfortran/generated/_mod_i8.F90 index 94f6c7b85f4..964b839a588 100644 --- a/libgfortran/generated/_mod_i8.F90 +++ b/libgfortran/generated/_mod_i8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_mod_r10.F90 b/libgfortran/generated/_mod_r10.F90 index a4cf1d04046..cb55f272c14 100644 --- a/libgfortran/generated/_mod_r10.F90 +++ b/libgfortran/generated/_mod_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_mod_r16.F90 b/libgfortran/generated/_mod_r16.F90 index 6ae2c4f1758..e369a315320 100644 --- a/libgfortran/generated/_mod_r16.F90 +++ b/libgfortran/generated/_mod_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_mod_r4.F90 b/libgfortran/generated/_mod_r4.F90 index dfb0f078e8e..73367026570 100644 --- a/libgfortran/generated/_mod_r4.F90 +++ b/libgfortran/generated/_mod_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_mod_r8.F90 b/libgfortran/generated/_mod_r8.F90 index 50df377fc6b..636ae7ade4c 100644 --- a/libgfortran/generated/_mod_r8.F90 +++ b/libgfortran/generated/_mod_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sign_i16.F90 b/libgfortran/generated/_sign_i16.F90 index 3e642b29b81..e37370b95bd 100644 --- a/libgfortran/generated/_sign_i16.F90 +++ b/libgfortran/generated/_sign_i16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sign_i4.F90 b/libgfortran/generated/_sign_i4.F90 index d637aae54bf..f7db3c1c031 100644 --- a/libgfortran/generated/_sign_i4.F90 +++ b/libgfortran/generated/_sign_i4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sign_i8.F90 b/libgfortran/generated/_sign_i8.F90 index 00d0eda6964..7f4ab42b7cf 100644 --- a/libgfortran/generated/_sign_i8.F90 +++ b/libgfortran/generated/_sign_i8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sign_r10.F90 b/libgfortran/generated/_sign_r10.F90 index b165526b579..571715260df 100644 --- a/libgfortran/generated/_sign_r10.F90 +++ b/libgfortran/generated/_sign_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sign_r16.F90 b/libgfortran/generated/_sign_r16.F90 index 5e66148d3ff..6cba9fb23b3 100644 --- a/libgfortran/generated/_sign_r16.F90 +++ b/libgfortran/generated/_sign_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sign_r4.F90 b/libgfortran/generated/_sign_r4.F90 index 6428b9adf4f..b27a77e9753 100644 --- a/libgfortran/generated/_sign_r4.F90 +++ b/libgfortran/generated/_sign_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sign_r8.F90 b/libgfortran/generated/_sign_r8.F90 index 452132dd0fe..31f27c21937 100644 --- a/libgfortran/generated/_sign_r8.F90 +++ b/libgfortran/generated/_sign_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sin_c10.F90 b/libgfortran/generated/_sin_c10.F90 index 6384598ee84..97c7364f4d6 100644 --- a/libgfortran/generated/_sin_c10.F90 +++ b/libgfortran/generated/_sin_c10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sin_c16.F90 b/libgfortran/generated/_sin_c16.F90 index 4e8f445f722..f52d22fa401 100644 --- a/libgfortran/generated/_sin_c16.F90 +++ b/libgfortran/generated/_sin_c16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sin_c4.F90 b/libgfortran/generated/_sin_c4.F90 index 7f4b6be6307..7e841ff8d72 100644 --- a/libgfortran/generated/_sin_c4.F90 +++ b/libgfortran/generated/_sin_c4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sin_c8.F90 b/libgfortran/generated/_sin_c8.F90 index 9abd4a13ec4..8733144a5ef 100644 --- a/libgfortran/generated/_sin_c8.F90 +++ b/libgfortran/generated/_sin_c8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sin_r10.F90 b/libgfortran/generated/_sin_r10.F90 index f201962e689..e11183d64dd 100644 --- a/libgfortran/generated/_sin_r10.F90 +++ b/libgfortran/generated/_sin_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sin_r16.F90 b/libgfortran/generated/_sin_r16.F90 index 10c86a88e49..8953c5b331e 100644 --- a/libgfortran/generated/_sin_r16.F90 +++ b/libgfortran/generated/_sin_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sin_r4.F90 b/libgfortran/generated/_sin_r4.F90 index b586928daf0..5278ba50ad4 100644 --- a/libgfortran/generated/_sin_r4.F90 +++ b/libgfortran/generated/_sin_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sin_r8.F90 b/libgfortran/generated/_sin_r8.F90 index cb8e25772d9..07055da31e8 100644 --- a/libgfortran/generated/_sin_r8.F90 +++ b/libgfortran/generated/_sin_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sinh_r10.F90 b/libgfortran/generated/_sinh_r10.F90 index 67609d682d2..681aa5513ad 100644 --- a/libgfortran/generated/_sinh_r10.F90 +++ b/libgfortran/generated/_sinh_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sinh_r16.F90 b/libgfortran/generated/_sinh_r16.F90 index 6274a59b7d6..1e0d345cf66 100644 --- a/libgfortran/generated/_sinh_r16.F90 +++ b/libgfortran/generated/_sinh_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sinh_r4.F90 b/libgfortran/generated/_sinh_r4.F90 index 116f205385c..91956cb00ff 100644 --- a/libgfortran/generated/_sinh_r4.F90 +++ b/libgfortran/generated/_sinh_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sinh_r8.F90 b/libgfortran/generated/_sinh_r8.F90 index bb4ceae479c..fe1c0007d2a 100644 --- a/libgfortran/generated/_sinh_r8.F90 +++ b/libgfortran/generated/_sinh_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sqrt_c10.F90 b/libgfortran/generated/_sqrt_c10.F90 index d6ca3b64dab..b591fc5ca17 100644 --- a/libgfortran/generated/_sqrt_c10.F90 +++ b/libgfortran/generated/_sqrt_c10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sqrt_c16.F90 b/libgfortran/generated/_sqrt_c16.F90 index 247bdf5f09d..d92ee4eeeb2 100644 --- a/libgfortran/generated/_sqrt_c16.F90 +++ b/libgfortran/generated/_sqrt_c16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sqrt_c4.F90 b/libgfortran/generated/_sqrt_c4.F90 index 7a8195f9dca..868ed8696cb 100644 --- a/libgfortran/generated/_sqrt_c4.F90 +++ b/libgfortran/generated/_sqrt_c4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sqrt_c8.F90 b/libgfortran/generated/_sqrt_c8.F90 index 1e1e153a91f..ae1de48dcbe 100644 --- a/libgfortran/generated/_sqrt_c8.F90 +++ b/libgfortran/generated/_sqrt_c8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sqrt_r10.F90 b/libgfortran/generated/_sqrt_r10.F90 index b770433ae9f..1e5c94a105a 100644 --- a/libgfortran/generated/_sqrt_r10.F90 +++ b/libgfortran/generated/_sqrt_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sqrt_r16.F90 b/libgfortran/generated/_sqrt_r16.F90 index 8e796f8b3a2..40ccd9da4b4 100644 --- a/libgfortran/generated/_sqrt_r16.F90 +++ b/libgfortran/generated/_sqrt_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sqrt_r4.F90 b/libgfortran/generated/_sqrt_r4.F90 index 2181cd09d78..c3eda2b00d4 100644 --- a/libgfortran/generated/_sqrt_r4.F90 +++ b/libgfortran/generated/_sqrt_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_sqrt_r8.F90 b/libgfortran/generated/_sqrt_r8.F90 index 47253da4e32..5dbb7b5e16b 100644 --- a/libgfortran/generated/_sqrt_r8.F90 +++ b/libgfortran/generated/_sqrt_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_tan_r10.F90 b/libgfortran/generated/_tan_r10.F90 index f2829e72ece..d92e5791e46 100644 --- a/libgfortran/generated/_tan_r10.F90 +++ b/libgfortran/generated/_tan_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_tan_r16.F90 b/libgfortran/generated/_tan_r16.F90 index dcc7f8e8c09..86664fbb8d5 100644 --- a/libgfortran/generated/_tan_r16.F90 +++ b/libgfortran/generated/_tan_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_tan_r4.F90 b/libgfortran/generated/_tan_r4.F90 index 638cc8da750..97d71f6578d 100644 --- a/libgfortran/generated/_tan_r4.F90 +++ b/libgfortran/generated/_tan_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_tan_r8.F90 b/libgfortran/generated/_tan_r8.F90 index cea72250666..160b59d3395 100644 --- a/libgfortran/generated/_tan_r8.F90 +++ b/libgfortran/generated/_tan_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_tanh_r10.F90 b/libgfortran/generated/_tanh_r10.F90 index 6994238888a..a0cf550ccab 100644 --- a/libgfortran/generated/_tanh_r10.F90 +++ b/libgfortran/generated/_tanh_r10.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_tanh_r16.F90 b/libgfortran/generated/_tanh_r16.F90 index d7dca680700..b4dda60a076 100644 --- a/libgfortran/generated/_tanh_r16.F90 +++ b/libgfortran/generated/_tanh_r16.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_tanh_r4.F90 b/libgfortran/generated/_tanh_r4.F90 index 098d9b86848..255e586bcc9 100644 --- a/libgfortran/generated/_tanh_r4.F90 +++ b/libgfortran/generated/_tanh_r4.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/_tanh_r8.F90 b/libgfortran/generated/_tanh_r8.F90 index ca7c7ccc71d..554c7349e38 100644 --- a/libgfortran/generated/_tanh_r8.F90 +++ b/libgfortran/generated/_tanh_r8.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/all_l1.c b/libgfortran/generated/all_l1.c new file mode 100644 index 00000000000..47cf2220d33 --- /dev/null +++ b/libgfortran/generated/all_l1.c @@ -0,0 +1,222 @@ +/* Implementation of the ALL intrinsic + Copyright 2002, 2007 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 <stdlib.h> +#include <assert.h> + + +#if defined (HAVE_GFC_LOGICAL_1) + + +extern void all_l1 (gfc_array_l1 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(all_l1); + +void +all_l1 (gfc_array_l1 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_LOGICAL_1 * restrict base; + GFC_LOGICAL_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride * src_kind; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride * src_kind; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride * src_kind; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_1) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " ALL intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ALL intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ALL intrinsic"); + + dest = retarray->data; + + while (base) + { + const GFC_LOGICAL_1 * restrict src; + GFC_LOGICAL_1 result; + src = base; + { + + /* Return true only if all the elements are set. */ + result = 1; + if (len <= 0) + *dest = 1; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (! *src) + { + result = 0; + break; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/all_l16.c b/libgfortran/generated/all_l16.c index 24aa4d71278..ca147e7d39f 100644 --- a/libgfortran/generated/all_l16.c +++ b/libgfortran/generated/all_l16.c @@ -1,5 +1,5 @@ /* Implementation of the ALL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,46 +28,48 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" -#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_LOGICAL_16) +#if defined (HAVE_GFC_LOGICAL_16) extern void all_l16 (gfc_array_l16 * const restrict, - gfc_array_l16 * const restrict, const index_type * const restrict); + gfc_array_l1 * const restrict, const index_type * const restrict); export_proto(all_l16); void all_l16 (gfc_array_l16 * const restrict retarray, - gfc_array_l16 * const restrict array, + gfc_array_l1 * const restrict array, const index_type * const restrict pdim) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride[GFC_MAX_DIMENSIONS]; - const GFC_LOGICAL_16 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_LOGICAL_16 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -75,7 +77,7 @@ all_l16 (gfc_array_l16 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,7 +118,25 @@ all_l16 (gfc_array_l16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " ALL intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ALL intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -128,11 +148,24 @@ all_l16 (gfc_array_l16 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ALL intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_16 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_16 result; src = base; { diff --git a/libgfortran/generated/all_l2.c b/libgfortran/generated/all_l2.c new file mode 100644 index 00000000000..9e4ab72b30c --- /dev/null +++ b/libgfortran/generated/all_l2.c @@ -0,0 +1,222 @@ +/* Implementation of the ALL intrinsic + Copyright 2002, 2007 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 <stdlib.h> +#include <assert.h> + + +#if defined (HAVE_GFC_LOGICAL_2) + + +extern void all_l2 (gfc_array_l2 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(all_l2); + +void +all_l2 (gfc_array_l2 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_LOGICAL_1 * restrict base; + GFC_LOGICAL_2 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride * src_kind; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride * src_kind; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride * src_kind; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_2) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " ALL intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ALL intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ALL intrinsic"); + + dest = retarray->data; + + while (base) + { + const GFC_LOGICAL_1 * restrict src; + GFC_LOGICAL_2 result; + src = base; + { + + /* Return true only if all the elements are set. */ + result = 1; + if (len <= 0) + *dest = 1; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (! *src) + { + result = 0; + break; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/all_l4.c b/libgfortran/generated/all_l4.c index be4fece74e3..255881b9112 100644 --- a/libgfortran/generated/all_l4.c +++ b/libgfortran/generated/all_l4.c @@ -1,5 +1,5 @@ /* Implementation of the ALL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,46 +28,48 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" -#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_LOGICAL_4) +#if defined (HAVE_GFC_LOGICAL_4) extern void all_l4 (gfc_array_l4 * const restrict, - gfc_array_l4 * const restrict, const index_type * const restrict); + gfc_array_l1 * const restrict, const index_type * const restrict); export_proto(all_l4); void all_l4 (gfc_array_l4 * const restrict retarray, - gfc_array_l4 * const restrict array, + gfc_array_l1 * const restrict array, const index_type * const restrict pdim) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride[GFC_MAX_DIMENSIONS]; - const GFC_LOGICAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_LOGICAL_4 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -75,7 +77,7 @@ all_l4 (gfc_array_l4 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,7 +118,25 @@ all_l4 (gfc_array_l4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " ALL intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ALL intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -128,11 +148,24 @@ all_l4 (gfc_array_l4 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ALL intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_4 result; src = base; { diff --git a/libgfortran/generated/all_l8.c b/libgfortran/generated/all_l8.c index 684510c5f20..00ba59f1034 100644 --- a/libgfortran/generated/all_l8.c +++ b/libgfortran/generated/all_l8.c @@ -1,5 +1,5 @@ /* Implementation of the ALL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,46 +28,48 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" -#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_LOGICAL_8) +#if defined (HAVE_GFC_LOGICAL_8) extern void all_l8 (gfc_array_l8 * const restrict, - gfc_array_l8 * const restrict, const index_type * const restrict); + gfc_array_l1 * const restrict, const index_type * const restrict); export_proto(all_l8); void all_l8 (gfc_array_l8 * const restrict retarray, - gfc_array_l8 * const restrict array, + gfc_array_l1 * const restrict array, const index_type * const restrict pdim) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride[GFC_MAX_DIMENSIONS]; - const GFC_LOGICAL_8 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_LOGICAL_8 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -75,7 +77,7 @@ all_l8 (gfc_array_l8 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,7 +118,25 @@ all_l8 (gfc_array_l8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " ALL intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ALL intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -128,11 +148,24 @@ all_l8 (gfc_array_l8 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ALL intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_8 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_8 result; src = base; { diff --git a/libgfortran/generated/any_l1.c b/libgfortran/generated/any_l1.c new file mode 100644 index 00000000000..9781a43c2cb --- /dev/null +++ b/libgfortran/generated/any_l1.c @@ -0,0 +1,222 @@ +/* Implementation of the ANY intrinsic + Copyright 2002, 2007 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 <stdlib.h> +#include <assert.h> + + +#if defined (HAVE_GFC_LOGICAL_1) + + +extern void any_l1 (gfc_array_l1 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(any_l1); + +void +any_l1 (gfc_array_l1 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_LOGICAL_1 * restrict base; + GFC_LOGICAL_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride * src_kind; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride * src_kind; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride * src_kind; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_1) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " ANY intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ANY intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ANY intrinsic"); + + dest = retarray->data; + + while (base) + { + const GFC_LOGICAL_1 * restrict src; + GFC_LOGICAL_1 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + /* Return true if any of the elements are set. */ + if (*src) + { + result = 1; + break; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/any_l16.c b/libgfortran/generated/any_l16.c index d351f222717..b0e95a6dad6 100644 --- a/libgfortran/generated/any_l16.c +++ b/libgfortran/generated/any_l16.c @@ -1,5 +1,5 @@ /* Implementation of the ANY intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,46 +28,48 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" -#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_LOGICAL_16) +#if defined (HAVE_GFC_LOGICAL_16) extern void any_l16 (gfc_array_l16 * const restrict, - gfc_array_l16 * const restrict, const index_type * const restrict); + gfc_array_l1 * const restrict, const index_type * const restrict); export_proto(any_l16); void any_l16 (gfc_array_l16 * const restrict retarray, - gfc_array_l16 * const restrict array, + gfc_array_l1 * const restrict array, const index_type * const restrict pdim) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride[GFC_MAX_DIMENSIONS]; - const GFC_LOGICAL_16 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_LOGICAL_16 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -75,7 +77,7 @@ any_l16 (gfc_array_l16 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,7 +118,25 @@ any_l16 (gfc_array_l16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " ANY intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ANY intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -128,11 +148,24 @@ any_l16 (gfc_array_l16 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ANY intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_16 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_16 result; src = base; { diff --git a/libgfortran/generated/any_l2.c b/libgfortran/generated/any_l2.c new file mode 100644 index 00000000000..6a42be0fcbc --- /dev/null +++ b/libgfortran/generated/any_l2.c @@ -0,0 +1,222 @@ +/* Implementation of the ANY intrinsic + Copyright 2002, 2007 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 <stdlib.h> +#include <assert.h> + + +#if defined (HAVE_GFC_LOGICAL_2) + + +extern void any_l2 (gfc_array_l2 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(any_l2); + +void +any_l2 (gfc_array_l2 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_LOGICAL_1 * restrict base; + GFC_LOGICAL_2 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride * src_kind; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride * src_kind; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride * src_kind; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_2) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " ANY intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ANY intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ANY intrinsic"); + + dest = retarray->data; + + while (base) + { + const GFC_LOGICAL_1 * restrict src; + GFC_LOGICAL_2 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + /* Return true if any of the elements are set. */ + if (*src) + { + result = 1; + break; + } + } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/any_l4.c b/libgfortran/generated/any_l4.c index 316d9e25231..eb372969030 100644 --- a/libgfortran/generated/any_l4.c +++ b/libgfortran/generated/any_l4.c @@ -1,5 +1,5 @@ /* Implementation of the ANY intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,46 +28,48 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" -#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_LOGICAL_4) +#if defined (HAVE_GFC_LOGICAL_4) extern void any_l4 (gfc_array_l4 * const restrict, - gfc_array_l4 * const restrict, const index_type * const restrict); + gfc_array_l1 * const restrict, const index_type * const restrict); export_proto(any_l4); void any_l4 (gfc_array_l4 * const restrict retarray, - gfc_array_l4 * const restrict array, + gfc_array_l1 * const restrict array, const index_type * const restrict pdim) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride[GFC_MAX_DIMENSIONS]; - const GFC_LOGICAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_LOGICAL_4 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -75,7 +77,7 @@ any_l4 (gfc_array_l4 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,7 +118,25 @@ any_l4 (gfc_array_l4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " ANY intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ANY intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -128,11 +148,24 @@ any_l4 (gfc_array_l4 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ANY intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_4 result; src = base; { diff --git a/libgfortran/generated/any_l8.c b/libgfortran/generated/any_l8.c index 6efe431da40..b5b52a0b81b 100644 --- a/libgfortran/generated/any_l8.c +++ b/libgfortran/generated/any_l8.c @@ -1,5 +1,5 @@ /* Implementation of the ANY intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,46 +28,48 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" -#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_LOGICAL_8) +#if defined (HAVE_GFC_LOGICAL_8) extern void any_l8 (gfc_array_l8 * const restrict, - gfc_array_l8 * const restrict, const index_type * const restrict); + gfc_array_l1 * const restrict, const index_type * const restrict); export_proto(any_l8); void any_l8 (gfc_array_l8 * const restrict retarray, - gfc_array_l8 * const restrict array, + gfc_array_l1 * const restrict array, const index_type * const restrict pdim) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride[GFC_MAX_DIMENSIONS]; - const GFC_LOGICAL_8 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_LOGICAL_8 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -75,7 +77,7 @@ any_l8 (gfc_array_l8 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,7 +118,25 @@ any_l8 (gfc_array_l8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " ANY intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ANY intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -128,11 +148,24 @@ any_l8 (gfc_array_l8 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ANY intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_8 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_LOGICAL_8 result; src = base; { diff --git a/libgfortran/generated/count_16_l4.c b/libgfortran/generated/count_16_l.c index 0f417ac96f3..d3f15d7119d 100644 --- a/libgfortran/generated/count_16_l4.c +++ b/libgfortran/generated/count_16_l.c @@ -1,5 +1,5 @@ /* Implementation of the COUNT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,46 +28,48 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" -#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_INTEGER_16) +#if defined (HAVE_GFC_INTEGER_16) -extern void count_16_l4 (gfc_array_i16 * const restrict, - gfc_array_l4 * const restrict, const index_type * const restrict); -export_proto(count_16_l4); +extern void count_16_l (gfc_array_i16 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(count_16_l); void -count_16_l4 (gfc_array_i16 * const restrict retarray, - gfc_array_l4 * const restrict array, +count_16_l (gfc_array_i16 * const restrict retarray, + gfc_array_l1 * const restrict array, const index_type * const restrict pdim) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride[GFC_MAX_DIMENSIONS]; - const GFC_LOGICAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_INTEGER_16 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -75,7 +77,7 @@ count_16_l4 (gfc_array_i16 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,7 +118,25 @@ count_16_l4 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " COUNT intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " COUNT intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -128,11 +148,24 @@ count_16_l4 (gfc_array_i16 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in COUNT intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_INTEGER_16 result; src = base; { diff --git a/libgfortran/generated/count_16_l16.c b/libgfortran/generated/count_16_l16.c deleted file mode 100644 index c396650eff1..00000000000 --- a/libgfortran/generated/count_16_l16.c +++ /dev/null @@ -1,185 +0,0 @@ -/* Implementation of the COUNT intrinsic - Copyright 2002 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 "config.h" -#include <stdlib.h> -#include <assert.h> -#include "libgfortran.h" - - -#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_INTEGER_16) - - -extern void count_16_l16 (gfc_array_i16 * const restrict, - gfc_array_l16 * const restrict, const index_type * const restrict); -export_proto(count_16_l16); - -void -count_16_l16 (gfc_array_i16 * const restrict retarray, - gfc_array_l16 * const restrict array, - const index_type * const restrict pdim) -{ - index_type count[GFC_MAX_DIMENSIONS]; - index_type extent[GFC_MAX_DIMENSIONS]; - index_type sstride[GFC_MAX_DIMENSIONS]; - index_type dstride[GFC_MAX_DIMENSIONS]; - const GFC_LOGICAL_16 * restrict base; - GFC_INTEGER_16 * restrict dest; - index_type rank; - index_type n; - index_type len; - index_type delta; - index_type dim; - - /* Make dim zero based to avoid confusion. */ - dim = (*pdim) - 1; - rank = GFC_DESCRIPTOR_RANK (array) - 1; - - len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; - - for (n = 0; n < dim; n++) - { - sstride[n] = array->dim[n].stride; - extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - for (n = dim; n < rank; n++) - { - sstride[n] = array->dim[n + 1].stride; - extent[n] = - array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - - if (retarray->data == NULL) - { - size_t alloc_size; - - for (n = 0; n < rank; n++) - { - retarray->dim[n].lbound = 0; - retarray->dim[n].ubound = extent[n]-1; - if (n == 0) - retarray->dim[n].stride = 1; - else - retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; - } - - retarray->offset = 0; - retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; - - alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride - * extent[rank-1]; - - if (alloc_size == 0) - { - /* Make sure we have a zero-sized array. */ - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = -1; - return; - } - else - retarray->data = internal_malloc_size (alloc_size); - } - else - { - if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); - } - - for (n = 0; n < rank; n++) - { - count[n] = 0; - dstride[n] = retarray->dim[n].stride; - if (extent[n] <= 0) - len = 0; - } - - base = array->data; - dest = retarray->data; - - while (base) - { - const GFC_LOGICAL_16 * restrict src; - GFC_INTEGER_16 result; - src = base; - { - - result = 0; - if (len <= 0) - *dest = 0; - else - { - for (n = 0; n < len; n++, src += delta) - { - - if (*src) - result++; - } - *dest = result; - } - } - /* Advance to the next element. */ - count[0]++; - base += sstride[0]; - dest += dstride[0]; - n = 0; - while (count[n] == extent[n]) - { - /* When we get to the end of a dimension, reset it and increment - the next dimension. */ - count[n] = 0; - /* We could precalculate these products, but this is a less - frequently used path so probably not worth it. */ - base -= sstride[n] * extent[n]; - dest -= dstride[n] * extent[n]; - n++; - if (n == rank) - { - /* Break out of the look. */ - base = NULL; - break; - } - else - { - count[n]++; - base += sstride[n]; - dest += dstride[n]; - } - } - } -} - -#endif diff --git a/libgfortran/generated/count_16_l8.c b/libgfortran/generated/count_16_l8.c deleted file mode 100644 index 2e4ea41b693..00000000000 --- a/libgfortran/generated/count_16_l8.c +++ /dev/null @@ -1,185 +0,0 @@ -/* Implementation of the COUNT intrinsic - Copyright 2002 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 "config.h" -#include <stdlib.h> -#include <assert.h> -#include "libgfortran.h" - - -#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_INTEGER_16) - - -extern void count_16_l8 (gfc_array_i16 * const restrict, - gfc_array_l8 * const restrict, const index_type * const restrict); -export_proto(count_16_l8); - -void -count_16_l8 (gfc_array_i16 * const restrict retarray, - gfc_array_l8 * const restrict array, - const index_type * const restrict pdim) -{ - index_type count[GFC_MAX_DIMENSIONS]; - index_type extent[GFC_MAX_DIMENSIONS]; - index_type sstride[GFC_MAX_DIMENSIONS]; - index_type dstride[GFC_MAX_DIMENSIONS]; - const GFC_LOGICAL_8 * restrict base; - GFC_INTEGER_16 * restrict dest; - index_type rank; - index_type n; - index_type len; - index_type delta; - index_type dim; - - /* Make dim zero based to avoid confusion. */ - dim = (*pdim) - 1; - rank = GFC_DESCRIPTOR_RANK (array) - 1; - - len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; - - for (n = 0; n < dim; n++) - { - sstride[n] = array->dim[n].stride; - extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - for (n = dim; n < rank; n++) - { - sstride[n] = array->dim[n + 1].stride; - extent[n] = - array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - - if (retarray->data == NULL) - { - size_t alloc_size; - - for (n = 0; n < rank; n++) - { - retarray->dim[n].lbound = 0; - retarray->dim[n].ubound = extent[n]-1; - if (n == 0) - retarray->dim[n].stride = 1; - else - retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; - } - - retarray->offset = 0; - retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; - - alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride - * extent[rank-1]; - - if (alloc_size == 0) - { - /* Make sure we have a zero-sized array. */ - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = -1; - return; - } - else - retarray->data = internal_malloc_size (alloc_size); - } - else - { - if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); - } - - for (n = 0; n < rank; n++) - { - count[n] = 0; - dstride[n] = retarray->dim[n].stride; - if (extent[n] <= 0) - len = 0; - } - - base = array->data; - dest = retarray->data; - - while (base) - { - const GFC_LOGICAL_8 * restrict src; - GFC_INTEGER_16 result; - src = base; - { - - result = 0; - if (len <= 0) - *dest = 0; - else - { - for (n = 0; n < len; n++, src += delta) - { - - if (*src) - result++; - } - *dest = result; - } - } - /* Advance to the next element. */ - count[0]++; - base += sstride[0]; - dest += dstride[0]; - n = 0; - while (count[n] == extent[n]) - { - /* When we get to the end of a dimension, reset it and increment - the next dimension. */ - count[n] = 0; - /* We could precalculate these products, but this is a less - frequently used path so probably not worth it. */ - base -= sstride[n] * extent[n]; - dest -= dstride[n] * extent[n]; - n++; - if (n == rank) - { - /* Break out of the look. */ - base = NULL; - break; - } - else - { - count[n]++; - base += sstride[n]; - dest += dstride[n]; - } - } - } -} - -#endif diff --git a/libgfortran/generated/count_4_l8.c b/libgfortran/generated/count_1_l.c index f1fd30296b3..78d82c0ea36 100644 --- a/libgfortran/generated/count_4_l8.c +++ b/libgfortran/generated/count_1_l.c @@ -1,5 +1,5 @@ /* Implementation of the COUNT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,46 +28,48 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" -#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_INTEGER_4) +#if defined (HAVE_GFC_INTEGER_1) -extern void count_4_l8 (gfc_array_i4 * const restrict, - gfc_array_l8 * const restrict, const index_type * const restrict); -export_proto(count_4_l8); +extern void count_1_l (gfc_array_i1 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(count_1_l); void -count_4_l8 (gfc_array_i4 * const restrict retarray, - gfc_array_l8 * const restrict array, +count_1_l (gfc_array_i1 * const restrict retarray, + gfc_array_l1 * const restrict array, const index_type * const restrict pdim) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride[GFC_MAX_DIMENSIONS]; - const GFC_LOGICAL_8 * restrict base; - GFC_INTEGER_4 * restrict dest; + const GFC_LOGICAL_1 * restrict base; + GFC_INTEGER_1 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -75,7 +77,7 @@ count_4_l8 (gfc_array_i4 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -100,7 +102,7 @@ count_4_l8 (gfc_array_i4 * const restrict retarray, retarray->offset = 0; retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; - alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride + alloc_size = sizeof (GFC_INTEGER_1) * retarray->dim[rank-1].stride * extent[rank-1]; if (alloc_size == 0) @@ -116,7 +118,25 @@ count_4_l8 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " COUNT intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " COUNT intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -128,12 +148,25 @@ count_4_l8 (gfc_array_i4 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in COUNT intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_8 * restrict src; - GFC_INTEGER_4 result; + const GFC_LOGICAL_1 * restrict src; + GFC_INTEGER_1 result; src = base; { diff --git a/libgfortran/generated/count_8_l4.c b/libgfortran/generated/count_2_l.c index 9ecddbd10b1..eb03c2d5c5f 100644 --- a/libgfortran/generated/count_8_l4.c +++ b/libgfortran/generated/count_2_l.c @@ -1,5 +1,5 @@ /* Implementation of the COUNT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,46 +28,48 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" -#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_INTEGER_8) +#if defined (HAVE_GFC_INTEGER_2) -extern void count_8_l4 (gfc_array_i8 * const restrict, - gfc_array_l4 * const restrict, const index_type * const restrict); -export_proto(count_8_l4); +extern void count_2_l (gfc_array_i2 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(count_2_l); void -count_8_l4 (gfc_array_i8 * const restrict retarray, - gfc_array_l4 * const restrict array, +count_2_l (gfc_array_i2 * const restrict retarray, + gfc_array_l1 * const restrict array, const index_type * const restrict pdim) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride[GFC_MAX_DIMENSIONS]; - const GFC_LOGICAL_4 * restrict base; - GFC_INTEGER_8 * restrict dest; + const GFC_LOGICAL_1 * restrict base; + GFC_INTEGER_2 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -75,7 +77,7 @@ count_8_l4 (gfc_array_i8 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -100,7 +102,7 @@ count_8_l4 (gfc_array_i8 * const restrict retarray, retarray->offset = 0; retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; - alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride + alloc_size = sizeof (GFC_INTEGER_2) * retarray->dim[rank-1].stride * extent[rank-1]; if (alloc_size == 0) @@ -116,7 +118,25 @@ count_8_l4 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " COUNT intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " COUNT intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -128,12 +148,25 @@ count_8_l4 (gfc_array_i8 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in COUNT intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_4 * restrict src; - GFC_INTEGER_8 result; + const GFC_LOGICAL_1 * restrict src; + GFC_INTEGER_2 result; src = base; { diff --git a/libgfortran/generated/count_4_l4.c b/libgfortran/generated/count_4_l.c index 6a8fde0b4b9..58dcd77c731 100644 --- a/libgfortran/generated/count_4_l4.c +++ b/libgfortran/generated/count_4_l.c @@ -1,5 +1,5 @@ /* Implementation of the COUNT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,46 +28,48 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" -#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_INTEGER_4) +#if defined (HAVE_GFC_INTEGER_4) -extern void count_4_l4 (gfc_array_i4 * const restrict, - gfc_array_l4 * const restrict, const index_type * const restrict); -export_proto(count_4_l4); +extern void count_4_l (gfc_array_i4 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(count_4_l); void -count_4_l4 (gfc_array_i4 * const restrict retarray, - gfc_array_l4 * const restrict array, +count_4_l (gfc_array_i4 * const restrict retarray, + gfc_array_l1 * const restrict array, const index_type * const restrict pdim) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride[GFC_MAX_DIMENSIONS]; - const GFC_LOGICAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_INTEGER_4 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -75,7 +77,7 @@ count_4_l4 (gfc_array_i4 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,7 +118,25 @@ count_4_l4 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " COUNT intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " COUNT intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -128,11 +148,24 @@ count_4_l4 (gfc_array_i4 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in COUNT intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_INTEGER_4 result; src = base; { diff --git a/libgfortran/generated/count_4_l16.c b/libgfortran/generated/count_4_l16.c deleted file mode 100644 index 0c13dd48222..00000000000 --- a/libgfortran/generated/count_4_l16.c +++ /dev/null @@ -1,185 +0,0 @@ -/* Implementation of the COUNT intrinsic - Copyright 2002 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 "config.h" -#include <stdlib.h> -#include <assert.h> -#include "libgfortran.h" - - -#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_INTEGER_4) - - -extern void count_4_l16 (gfc_array_i4 * const restrict, - gfc_array_l16 * const restrict, const index_type * const restrict); -export_proto(count_4_l16); - -void -count_4_l16 (gfc_array_i4 * const restrict retarray, - gfc_array_l16 * const restrict array, - const index_type * const restrict pdim) -{ - index_type count[GFC_MAX_DIMENSIONS]; - index_type extent[GFC_MAX_DIMENSIONS]; - index_type sstride[GFC_MAX_DIMENSIONS]; - index_type dstride[GFC_MAX_DIMENSIONS]; - const GFC_LOGICAL_16 * restrict base; - GFC_INTEGER_4 * restrict dest; - index_type rank; - index_type n; - index_type len; - index_type delta; - index_type dim; - - /* Make dim zero based to avoid confusion. */ - dim = (*pdim) - 1; - rank = GFC_DESCRIPTOR_RANK (array) - 1; - - len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; - - for (n = 0; n < dim; n++) - { - sstride[n] = array->dim[n].stride; - extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - for (n = dim; n < rank; n++) - { - sstride[n] = array->dim[n + 1].stride; - extent[n] = - array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - - if (retarray->data == NULL) - { - size_t alloc_size; - - for (n = 0; n < rank; n++) - { - retarray->dim[n].lbound = 0; - retarray->dim[n].ubound = extent[n]-1; - if (n == 0) - retarray->dim[n].stride = 1; - else - retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; - } - - retarray->offset = 0; - retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; - - alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride - * extent[rank-1]; - - if (alloc_size == 0) - { - /* Make sure we have a zero-sized array. */ - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = -1; - return; - } - else - retarray->data = internal_malloc_size (alloc_size); - } - else - { - if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); - } - - for (n = 0; n < rank; n++) - { - count[n] = 0; - dstride[n] = retarray->dim[n].stride; - if (extent[n] <= 0) - len = 0; - } - - base = array->data; - dest = retarray->data; - - while (base) - { - const GFC_LOGICAL_16 * restrict src; - GFC_INTEGER_4 result; - src = base; - { - - result = 0; - if (len <= 0) - *dest = 0; - else - { - for (n = 0; n < len; n++, src += delta) - { - - if (*src) - result++; - } - *dest = result; - } - } - /* Advance to the next element. */ - count[0]++; - base += sstride[0]; - dest += dstride[0]; - n = 0; - while (count[n] == extent[n]) - { - /* When we get to the end of a dimension, reset it and increment - the next dimension. */ - count[n] = 0; - /* We could precalculate these products, but this is a less - frequently used path so probably not worth it. */ - base -= sstride[n] * extent[n]; - dest -= dstride[n] * extent[n]; - n++; - if (n == rank) - { - /* Break out of the look. */ - base = NULL; - break; - } - else - { - count[n]++; - base += sstride[n]; - dest += dstride[n]; - } - } - } -} - -#endif diff --git a/libgfortran/generated/count_8_l8.c b/libgfortran/generated/count_8_l.c index 8ba9ed41d55..b7db60e00b0 100644 --- a/libgfortran/generated/count_8_l8.c +++ b/libgfortran/generated/count_8_l.c @@ -1,5 +1,5 @@ /* Implementation of the COUNT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,46 +28,48 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" -#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_INTEGER_8) +#if defined (HAVE_GFC_INTEGER_8) -extern void count_8_l8 (gfc_array_i8 * const restrict, - gfc_array_l8 * const restrict, const index_type * const restrict); -export_proto(count_8_l8); +extern void count_8_l (gfc_array_i8 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(count_8_l); void -count_8_l8 (gfc_array_i8 * const restrict retarray, - gfc_array_l8 * const restrict array, +count_8_l (gfc_array_i8 * const restrict retarray, + gfc_array_l1 * const restrict array, const index_type * const restrict pdim) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; index_type sstride[GFC_MAX_DIMENSIONS]; index_type dstride[GFC_MAX_DIMENSIONS]; - const GFC_LOGICAL_8 * restrict base; + const GFC_LOGICAL_1 * restrict base; GFC_INTEGER_8 * restrict dest; index_type rank; index_type n; index_type len; index_type delta; index_type dim; + int src_kind; /* Make dim zero based to avoid confusion. */ dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; + src_kind = GFC_DESCRIPTOR_SIZE (array); + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; + delta = array->dim[dim].stride * src_kind; for (n = 0; n < dim; n++) { - sstride[n] = array->dim[n].stride; + sstride[n] = array->dim[n].stride * src_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -75,7 +77,7 @@ count_8_l8 (gfc_array_i8 * const restrict retarray, } for (n = dim; n < rank; n++) { - sstride[n] = array->dim[n + 1].stride; + sstride[n] = array->dim[n + 1].stride * src_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -116,7 +118,25 @@ count_8_l8 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " COUNT intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " COUNT intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -128,11 +148,24 @@ count_8_l8 (gfc_array_i8 * const restrict retarray, } base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in COUNT intrinsic"); + dest = retarray->data; while (base) { - const GFC_LOGICAL_8 * restrict src; + const GFC_LOGICAL_1 * restrict src; GFC_INTEGER_8 result; src = base; { diff --git a/libgfortran/generated/count_8_l16.c b/libgfortran/generated/count_8_l16.c deleted file mode 100644 index 2c75d93e000..00000000000 --- a/libgfortran/generated/count_8_l16.c +++ /dev/null @@ -1,185 +0,0 @@ -/* Implementation of the COUNT intrinsic - Copyright 2002 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 "config.h" -#include <stdlib.h> -#include <assert.h> -#include "libgfortran.h" - - -#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_INTEGER_8) - - -extern void count_8_l16 (gfc_array_i8 * const restrict, - gfc_array_l16 * const restrict, const index_type * const restrict); -export_proto(count_8_l16); - -void -count_8_l16 (gfc_array_i8 * const restrict retarray, - gfc_array_l16 * const restrict array, - const index_type * const restrict pdim) -{ - index_type count[GFC_MAX_DIMENSIONS]; - index_type extent[GFC_MAX_DIMENSIONS]; - index_type sstride[GFC_MAX_DIMENSIONS]; - index_type dstride[GFC_MAX_DIMENSIONS]; - const GFC_LOGICAL_16 * restrict base; - GFC_INTEGER_8 * restrict dest; - index_type rank; - index_type n; - index_type len; - index_type delta; - index_type dim; - - /* Make dim zero based to avoid confusion. */ - dim = (*pdim) - 1; - rank = GFC_DESCRIPTOR_RANK (array) - 1; - - len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - delta = array->dim[dim].stride; - - for (n = 0; n < dim; n++) - { - sstride[n] = array->dim[n].stride; - extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - for (n = dim; n < rank; n++) - { - sstride[n] = array->dim[n + 1].stride; - extent[n] = - array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - - if (retarray->data == NULL) - { - size_t alloc_size; - - for (n = 0; n < rank; n++) - { - retarray->dim[n].lbound = 0; - retarray->dim[n].ubound = extent[n]-1; - if (n == 0) - retarray->dim[n].stride = 1; - else - retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; - } - - retarray->offset = 0; - retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; - - alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride - * extent[rank-1]; - - if (alloc_size == 0) - { - /* Make sure we have a zero-sized array. */ - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = -1; - return; - } - else - retarray->data = internal_malloc_size (alloc_size); - } - else - { - if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); - } - - for (n = 0; n < rank; n++) - { - count[n] = 0; - dstride[n] = retarray->dim[n].stride; - if (extent[n] <= 0) - len = 0; - } - - base = array->data; - dest = retarray->data; - - while (base) - { - const GFC_LOGICAL_16 * restrict src; - GFC_INTEGER_8 result; - src = base; - { - - result = 0; - if (len <= 0) - *dest = 0; - else - { - for (n = 0; n < len; n++, src += delta) - { - - if (*src) - result++; - } - *dest = result; - } - } - /* Advance to the next element. */ - count[0]++; - base += sstride[0]; - dest += dstride[0]; - n = 0; - while (count[n] == extent[n]) - { - /* When we get to the end of a dimension, reset it and increment - the next dimension. */ - count[n] = 0; - /* We could precalculate these products, but this is a less - frequently used path so probably not worth it. */ - base -= sstride[n] * extent[n]; - dest -= dstride[n] * extent[n]; - n++; - if (n == rank) - { - /* Break out of the look. */ - base = NULL; - break; - } - else - { - count[n]++; - base += sstride[n]; - dest += dstride[n]; - } - } - } -} - -#endif diff --git a/libgfortran/generated/cshift1_16.c b/libgfortran/generated/cshift1_16.c index 9bbe482dd71..a29bf79ce72 100644 --- a/libgfortran/generated/cshift1_16.c +++ b/libgfortran/generated/cshift1_16.c @@ -1,5 +1,5 @@ /* Implementation of the CSHIFT intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Feng Wang <wf_cs@yahoo.com> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_16) diff --git a/libgfortran/generated/cshift1_4.c b/libgfortran/generated/cshift1_4.c index f4a357e6220..0525873b563 100644 --- a/libgfortran/generated/cshift1_4.c +++ b/libgfortran/generated/cshift1_4.c @@ -1,5 +1,5 @@ /* Implementation of the CSHIFT intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Feng Wang <wf_cs@yahoo.com> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_4) diff --git a/libgfortran/generated/cshift1_8.c b/libgfortran/generated/cshift1_8.c index 9e9a8a0c696..624b662cea7 100644 --- a/libgfortran/generated/cshift1_8.c +++ b/libgfortran/generated/cshift1_8.c @@ -1,5 +1,5 @@ /* Implementation of the CSHIFT intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Feng Wang <wf_cs@yahoo.com> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_8) diff --git a/libgfortran/generated/eoshift1_16.c b/libgfortran/generated/eoshift1_16.c index 4cb01c85d55..628fa0ccca3 100644 --- a/libgfortran/generated/eoshift1_16.c +++ b/libgfortran/generated/eoshift1_16.c @@ -1,5 +1,5 @@ /* Implementation of the EOSHIFT intrinsic - Copyright 2002, 2005 Free Software Foundation, Inc. + Copyright 2002, 2005, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_16) diff --git a/libgfortran/generated/eoshift1_4.c b/libgfortran/generated/eoshift1_4.c index 2528597b46d..6253c6f2cf0 100644 --- a/libgfortran/generated/eoshift1_4.c +++ b/libgfortran/generated/eoshift1_4.c @@ -1,5 +1,5 @@ /* Implementation of the EOSHIFT intrinsic - Copyright 2002, 2005 Free Software Foundation, Inc. + Copyright 2002, 2005, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_4) diff --git a/libgfortran/generated/eoshift1_8.c b/libgfortran/generated/eoshift1_8.c index 0ca9844e293..983e1bf7523 100644 --- a/libgfortran/generated/eoshift1_8.c +++ b/libgfortran/generated/eoshift1_8.c @@ -1,5 +1,5 @@ /* Implementation of the EOSHIFT intrinsic - Copyright 2002, 2005 Free Software Foundation, Inc. + Copyright 2002, 2005, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_8) diff --git a/libgfortran/generated/eoshift3_16.c b/libgfortran/generated/eoshift3_16.c index 3c75a42ae8f..0898455cb1b 100644 --- a/libgfortran/generated/eoshift3_16.c +++ b/libgfortran/generated/eoshift3_16.c @@ -1,5 +1,5 @@ /* Implementation of the EOSHIFT intrinsic - Copyright 2002, 2005 Free Software Foundation, Inc. + Copyright 2002, 2005, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_16) diff --git a/libgfortran/generated/eoshift3_4.c b/libgfortran/generated/eoshift3_4.c index a8e54d06049..7f35a4c80f8 100644 --- a/libgfortran/generated/eoshift3_4.c +++ b/libgfortran/generated/eoshift3_4.c @@ -1,5 +1,5 @@ /* Implementation of the EOSHIFT intrinsic - Copyright 2002, 2005 Free Software Foundation, Inc. + Copyright 2002, 2005, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_4) diff --git a/libgfortran/generated/eoshift3_8.c b/libgfortran/generated/eoshift3_8.c index 8590554b0d2..1792507f6fb 100644 --- a/libgfortran/generated/eoshift3_8.c +++ b/libgfortran/generated/eoshift3_8.c @@ -1,5 +1,5 @@ /* Implementation of the EOSHIFT intrinsic - Copyright 2002, 2005 Free Software Foundation, Inc. + Copyright 2002, 2005, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_8) diff --git a/libgfortran/generated/exponent_r10.c b/libgfortran/generated/exponent_r10.c index 00474b8758f..90e9995c5f9 100644 --- a/libgfortran/generated/exponent_r10.c +++ b/libgfortran/generated/exponent_r10.c @@ -1,5 +1,5 @@ /* Implementation of the EXPONENT intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/exponent_r16.c b/libgfortran/generated/exponent_r16.c index 85e726ab746..d6907dd1103 100644 --- a/libgfortran/generated/exponent_r16.c +++ b/libgfortran/generated/exponent_r16.c @@ -1,5 +1,5 @@ /* Implementation of the EXPONENT intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/exponent_r4.c b/libgfortran/generated/exponent_r4.c index b9e47f77c71..aa3910aecad 100644 --- a/libgfortran/generated/exponent_r4.c +++ b/libgfortran/generated/exponent_r4.c @@ -1,5 +1,5 @@ /* Implementation of the EXPONENT intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/exponent_r8.c b/libgfortran/generated/exponent_r8.c index 624b7e36c28..76996675a8f 100644 --- a/libgfortran/generated/exponent_r8.c +++ b/libgfortran/generated/exponent_r8.c @@ -1,5 +1,5 @@ /* Implementation of the EXPONENT intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/fraction_r10.c b/libgfortran/generated/fraction_r10.c index cee531ba224..ef7f27c078f 100644 --- a/libgfortran/generated/fraction_r10.c +++ b/libgfortran/generated/fraction_r10.c @@ -1,5 +1,5 @@ /* Implementation of the FRACTION intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/fraction_r16.c b/libgfortran/generated/fraction_r16.c index 1ca093bd444..99049e8b683 100644 --- a/libgfortran/generated/fraction_r16.c +++ b/libgfortran/generated/fraction_r16.c @@ -1,5 +1,5 @@ /* Implementation of the FRACTION intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/fraction_r4.c b/libgfortran/generated/fraction_r4.c index 85bce70de44..2ca4b04abf5 100644 --- a/libgfortran/generated/fraction_r4.c +++ b/libgfortran/generated/fraction_r4.c @@ -1,5 +1,5 @@ /* Implementation of the FRACTION intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/fraction_r8.c b/libgfortran/generated/fraction_r8.c index 3d2c7e54f3b..028ac09b5d1 100644 --- a/libgfortran/generated/fraction_r8.c +++ b/libgfortran/generated/fraction_r8.c @@ -1,5 +1,5 @@ /* Implementation of the FRACTION intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/in_pack_c10.c b/libgfortran/generated/in_pack_c10.c index 2c5326f9c0d..60029536bf2 100644 --- a/libgfortran/generated/in_pack_c10.c +++ b/libgfortran/generated/in_pack_c10.c @@ -1,5 +1,5 @@ /* Helper function for repacking arrays. - Copyright 2003, 2006 Free Software Foundation, Inc. + Copyright 2003, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_COMPLEX_10) @@ -121,3 +121,4 @@ internal_pack_c10 (gfc_array_c10 * source) } #endif + diff --git a/libgfortran/generated/in_pack_c16.c b/libgfortran/generated/in_pack_c16.c index 912858b35f2..560a574df91 100644 --- a/libgfortran/generated/in_pack_c16.c +++ b/libgfortran/generated/in_pack_c16.c @@ -1,5 +1,5 @@ /* Helper function for repacking arrays. - Copyright 2003, 2006 Free Software Foundation, Inc. + Copyright 2003, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_COMPLEX_16) @@ -121,3 +121,4 @@ internal_pack_c16 (gfc_array_c16 * source) } #endif + diff --git a/libgfortran/generated/in_pack_c4.c b/libgfortran/generated/in_pack_c4.c index e4a7fc84f42..ea608d7b8b4 100644 --- a/libgfortran/generated/in_pack_c4.c +++ b/libgfortran/generated/in_pack_c4.c @@ -1,5 +1,5 @@ /* Helper function for repacking arrays. - Copyright 2003, 2006 Free Software Foundation, Inc. + Copyright 2003, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_COMPLEX_4) @@ -121,3 +121,4 @@ internal_pack_c4 (gfc_array_c4 * source) } #endif + diff --git a/libgfortran/generated/in_pack_c8.c b/libgfortran/generated/in_pack_c8.c index 17a3bdedbd5..7e8203ee933 100644 --- a/libgfortran/generated/in_pack_c8.c +++ b/libgfortran/generated/in_pack_c8.c @@ -1,5 +1,5 @@ /* Helper function for repacking arrays. - Copyright 2003, 2006 Free Software Foundation, Inc. + Copyright 2003, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_COMPLEX_8) @@ -121,3 +121,4 @@ internal_pack_c8 (gfc_array_c8 * source) } #endif + diff --git a/libgfortran/generated/in_pack_i16.c b/libgfortran/generated/in_pack_i16.c index 96a2bb4a5cf..eb729b6d38c 100644 --- a/libgfortran/generated/in_pack_i16.c +++ b/libgfortran/generated/in_pack_i16.c @@ -1,5 +1,5 @@ /* Helper function for repacking arrays. - Copyright 2003, 2006 Free Software Foundation, Inc. + Copyright 2003, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_16) @@ -121,3 +121,4 @@ internal_pack_16 (gfc_array_i16 * source) } #endif + diff --git a/libgfortran/generated/in_pack_i4.c b/libgfortran/generated/in_pack_i4.c index 04e17b817e3..0e3bf2302b7 100644 --- a/libgfortran/generated/in_pack_i4.c +++ b/libgfortran/generated/in_pack_i4.c @@ -1,5 +1,5 @@ /* Helper function for repacking arrays. - Copyright 2003, 2006 Free Software Foundation, Inc. + Copyright 2003, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_4) @@ -121,3 +121,4 @@ internal_pack_4 (gfc_array_i4 * source) } #endif + diff --git a/libgfortran/generated/in_pack_i8.c b/libgfortran/generated/in_pack_i8.c index f7b27e05ea1..e2337ffdb2b 100644 --- a/libgfortran/generated/in_pack_i8.c +++ b/libgfortran/generated/in_pack_i8.c @@ -1,5 +1,5 @@ /* Helper function for repacking arrays. - Copyright 2003, 2006 Free Software Foundation, Inc. + Copyright 2003, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_8) @@ -121,3 +121,4 @@ internal_pack_8 (gfc_array_i8 * source) } #endif + diff --git a/libgfortran/generated/in_unpack_c10.c b/libgfortran/generated/in_unpack_c10.c index 96e6833a034..078fab0cd38 100644 --- a/libgfortran/generated/in_unpack_c10.c +++ b/libgfortran/generated/in_unpack_c10.c @@ -1,5 +1,5 @@ /* Helper function for repacking arrays. - Copyright 2003, 2006 Free Software Foundation, Inc. + Copyright 2003, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_COMPLEX_10) @@ -109,3 +109,4 @@ internal_unpack_c10 (gfc_array_c10 * d, const GFC_COMPLEX_10 * src) } #endif + diff --git a/libgfortran/generated/in_unpack_c16.c b/libgfortran/generated/in_unpack_c16.c index 3c2fc796981..3adc947b673 100644 --- a/libgfortran/generated/in_unpack_c16.c +++ b/libgfortran/generated/in_unpack_c16.c @@ -1,5 +1,5 @@ /* Helper function for repacking arrays. - Copyright 2003, 2006 Free Software Foundation, Inc. + Copyright 2003, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_COMPLEX_16) @@ -109,3 +109,4 @@ internal_unpack_c16 (gfc_array_c16 * d, const GFC_COMPLEX_16 * src) } #endif + diff --git a/libgfortran/generated/in_unpack_c4.c b/libgfortran/generated/in_unpack_c4.c index 9ea8a36b125..32bcddb7c9e 100644 --- a/libgfortran/generated/in_unpack_c4.c +++ b/libgfortran/generated/in_unpack_c4.c @@ -1,5 +1,5 @@ /* Helper function for repacking arrays. - Copyright 2003, 2006 Free Software Foundation, Inc. + Copyright 2003, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_COMPLEX_4) @@ -109,3 +109,4 @@ internal_unpack_c4 (gfc_array_c4 * d, const GFC_COMPLEX_4 * src) } #endif + diff --git a/libgfortran/generated/in_unpack_c8.c b/libgfortran/generated/in_unpack_c8.c index a71a71948ea..5c88e975672 100644 --- a/libgfortran/generated/in_unpack_c8.c +++ b/libgfortran/generated/in_unpack_c8.c @@ -1,5 +1,5 @@ /* Helper function for repacking arrays. - Copyright 2003, 2006 Free Software Foundation, Inc. + Copyright 2003, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_COMPLEX_8) @@ -109,3 +109,4 @@ internal_unpack_c8 (gfc_array_c8 * d, const GFC_COMPLEX_8 * src) } #endif + diff --git a/libgfortran/generated/in_unpack_i16.c b/libgfortran/generated/in_unpack_i16.c index f8f6ea74b95..82f535eb3ba 100644 --- a/libgfortran/generated/in_unpack_i16.c +++ b/libgfortran/generated/in_unpack_i16.c @@ -1,5 +1,5 @@ /* Helper function for repacking arrays. - Copyright 2003, 2006 Free Software Foundation, Inc. + Copyright 2003, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_16) @@ -109,3 +109,4 @@ internal_unpack_16 (gfc_array_i16 * d, const GFC_INTEGER_16 * src) } #endif + diff --git a/libgfortran/generated/in_unpack_i4.c b/libgfortran/generated/in_unpack_i4.c index 3ac0298bcd1..8d808db6686 100644 --- a/libgfortran/generated/in_unpack_i4.c +++ b/libgfortran/generated/in_unpack_i4.c @@ -1,5 +1,5 @@ /* Helper function for repacking arrays. - Copyright 2003, 2006 Free Software Foundation, Inc. + Copyright 2003, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_4) @@ -109,3 +109,4 @@ internal_unpack_4 (gfc_array_i4 * d, const GFC_INTEGER_4 * src) } #endif + diff --git a/libgfortran/generated/in_unpack_i8.c b/libgfortran/generated/in_unpack_i8.c index 84e28f94ae9..39482b82705 100644 --- a/libgfortran/generated/in_unpack_i8.c +++ b/libgfortran/generated/in_unpack_i8.c @@ -1,5 +1,5 @@ /* Helper function for repacking arrays. - Copyright 2003, 2006 Free Software Foundation, Inc. + Copyright 2003, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_8) @@ -109,3 +109,4 @@ internal_unpack_8 (gfc_array_i8 * d, const GFC_INTEGER_8 * src) } #endif + diff --git a/libgfortran/generated/matmul_c10.c b/libgfortran/generated/matmul_c10.c index d7d4c650a98..84c6c5daabb 100644 --- a/libgfortran/generated/matmul_c10.c +++ b/libgfortran/generated/matmul_c10.c @@ -1,5 +1,5 @@ /* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <string.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_COMPLEX_10) diff --git a/libgfortran/generated/matmul_c16.c b/libgfortran/generated/matmul_c16.c index e9ad2d439c0..79ca57858ab 100644 --- a/libgfortran/generated/matmul_c16.c +++ b/libgfortran/generated/matmul_c16.c @@ -1,5 +1,5 @@ /* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <string.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_COMPLEX_16) diff --git a/libgfortran/generated/matmul_c4.c b/libgfortran/generated/matmul_c4.c index 753e535df79..f6b15796ad9 100644 --- a/libgfortran/generated/matmul_c4.c +++ b/libgfortran/generated/matmul_c4.c @@ -1,5 +1,5 @@ /* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <string.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_COMPLEX_4) diff --git a/libgfortran/generated/matmul_c8.c b/libgfortran/generated/matmul_c8.c index 23aea6a4fc3..5f4bdec8670 100644 --- a/libgfortran/generated/matmul_c8.c +++ b/libgfortran/generated/matmul_c8.c @@ -1,5 +1,5 @@ /* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <string.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_COMPLEX_8) diff --git a/libgfortran/generated/matmul_i1.c b/libgfortran/generated/matmul_i1.c index ae035076bed..7c2e95e8893 100644 --- a/libgfortran/generated/matmul_i1.c +++ b/libgfortran/generated/matmul_i1.c @@ -1,5 +1,5 @@ /* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <string.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_1) diff --git a/libgfortran/generated/matmul_i16.c b/libgfortran/generated/matmul_i16.c index 38756dc9010..9c33cc77b82 100644 --- a/libgfortran/generated/matmul_i16.c +++ b/libgfortran/generated/matmul_i16.c @@ -1,5 +1,5 @@ /* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <string.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_16) diff --git a/libgfortran/generated/matmul_i2.c b/libgfortran/generated/matmul_i2.c index 7287b6b745a..143f7832941 100644 --- a/libgfortran/generated/matmul_i2.c +++ b/libgfortran/generated/matmul_i2.c @@ -1,5 +1,5 @@ /* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <string.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_2) diff --git a/libgfortran/generated/matmul_i4.c b/libgfortran/generated/matmul_i4.c index d5eed998311..b90c43851f1 100644 --- a/libgfortran/generated/matmul_i4.c +++ b/libgfortran/generated/matmul_i4.c @@ -1,5 +1,5 @@ /* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <string.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_4) diff --git a/libgfortran/generated/matmul_i8.c b/libgfortran/generated/matmul_i8.c index 4ab55471c9e..b3260757c6e 100644 --- a/libgfortran/generated/matmul_i8.c +++ b/libgfortran/generated/matmul_i8.c @@ -1,5 +1,5 @@ /* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <string.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_8) diff --git a/libgfortran/generated/matmul_l16.c b/libgfortran/generated/matmul_l16.c index 7e7f2f9c658..b2b86ecfed1 100644 --- a/libgfortran/generated/matmul_l16.c +++ b/libgfortran/generated/matmul_l16.c @@ -1,5 +1,5 @@ /* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_LOGICAL_16) @@ -39,15 +39,15 @@ Boston, MA 02110-1301, USA. */ Either a or b can be rank 1. In this case x or y is 1. */ extern void matmul_l16 (gfc_array_l16 * const restrict, - gfc_array_l4 * const restrict, gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict, gfc_array_l1 * const restrict); export_proto(matmul_l16); void matmul_l16 (gfc_array_l16 * const restrict retarray, - gfc_array_l4 * const restrict a, gfc_array_l4 * const restrict b) + gfc_array_l1 * const restrict a, gfc_array_l1 * const restrict b) { - const GFC_INTEGER_4 * restrict abase; - const GFC_INTEGER_4 * restrict bbase; + const GFC_LOGICAL_1 * restrict abase; + const GFC_LOGICAL_1 * restrict bbase; GFC_LOGICAL_16 * restrict dest; index_type rxstride; index_type rystride; @@ -57,9 +57,11 @@ matmul_l16 (gfc_array_l16 * const restrict retarray, index_type ystride; index_type x; index_type y; + int a_kind; + int b_kind; - const GFC_INTEGER_4 * restrict pa; - const GFC_INTEGER_4 * restrict pb; + const GFC_LOGICAL_1 * restrict pa; + const GFC_LOGICAL_1 * restrict pb; index_type astride; index_type bstride; index_type count; @@ -99,17 +101,29 @@ matmul_l16 (gfc_array_l16 * const restrict retarray, } abase = a->data; - if (GFC_DESCRIPTOR_SIZE (a) != 4) - { - assert (GFC_DESCRIPTOR_SIZE (a) == 8); - abase = GFOR_POINTER_L8_TO_L4 (abase); - } + a_kind = GFC_DESCRIPTOR_SIZE (a); + + if (a_kind == 1 || a_kind == 2 || a_kind == 4 || a_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || a_kind == 16 +#endif + ) + abase = GFOR_POINTER_TO_L1 (abase, a_kind); + else + internal_error (NULL, "Funny sized logical array"); + bbase = b->data; - if (GFC_DESCRIPTOR_SIZE (b) != 4) - { - assert (GFC_DESCRIPTOR_SIZE (b) == 8); - bbase = GFOR_POINTER_L8_TO_L4 (bbase); - } + b_kind = GFC_DESCRIPTOR_SIZE (b); + + if (b_kind == 1 || b_kind == 2 || b_kind == 4 || b_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || b_kind == 16 +#endif + ) + bbase = GFOR_POINTER_TO_L1 (bbase, b_kind); + else + internal_error (NULL, "Funny sized logical array"); + dest = retarray->data; @@ -128,7 +142,7 @@ matmul_l16 (gfc_array_l16 * const restrict retarray, one. */ if (GFC_DESCRIPTOR_RANK (a) == 1) { - astride = a->dim[0].stride; + astride = a->dim[0].stride * a_kind; count = a->dim[0].ubound + 1 - a->dim[0].lbound; xstride = 0; rxstride = 0; @@ -136,14 +150,14 @@ matmul_l16 (gfc_array_l16 * const restrict retarray, } else { - astride = a->dim[1].stride; + astride = a->dim[1].stride * a_kind; count = a->dim[1].ubound + 1 - a->dim[1].lbound; - xstride = a->dim[0].stride; + xstride = a->dim[0].stride * a_kind; xcount = a->dim[0].ubound + 1 - a->dim[0].lbound; } if (GFC_DESCRIPTOR_RANK (b) == 1) { - bstride = b->dim[0].stride; + bstride = b->dim[0].stride * b_kind; assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound); ystride = 0; rystride = 0; @@ -151,9 +165,9 @@ matmul_l16 (gfc_array_l16 * const restrict retarray, } else { - bstride = b->dim[0].stride; + bstride = b->dim[0].stride * b_kind; assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound); - ystride = b->dim[1].stride; + ystride = b->dim[1].stride * b_kind; ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; } @@ -189,3 +203,4 @@ matmul_l16 (gfc_array_l16 * const restrict retarray, } #endif + diff --git a/libgfortran/generated/matmul_l4.c b/libgfortran/generated/matmul_l4.c index 8428ff9dc0b..9a6cb1d357d 100644 --- a/libgfortran/generated/matmul_l4.c +++ b/libgfortran/generated/matmul_l4.c @@ -1,5 +1,5 @@ /* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_LOGICAL_4) @@ -39,15 +39,15 @@ Boston, MA 02110-1301, USA. */ Either a or b can be rank 1. In this case x or y is 1. */ extern void matmul_l4 (gfc_array_l4 * const restrict, - gfc_array_l4 * const restrict, gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict, gfc_array_l1 * const restrict); export_proto(matmul_l4); void matmul_l4 (gfc_array_l4 * const restrict retarray, - gfc_array_l4 * const restrict a, gfc_array_l4 * const restrict b) + gfc_array_l1 * const restrict a, gfc_array_l1 * const restrict b) { - const GFC_INTEGER_4 * restrict abase; - const GFC_INTEGER_4 * restrict bbase; + const GFC_LOGICAL_1 * restrict abase; + const GFC_LOGICAL_1 * restrict bbase; GFC_LOGICAL_4 * restrict dest; index_type rxstride; index_type rystride; @@ -57,9 +57,11 @@ matmul_l4 (gfc_array_l4 * const restrict retarray, index_type ystride; index_type x; index_type y; + int a_kind; + int b_kind; - const GFC_INTEGER_4 * restrict pa; - const GFC_INTEGER_4 * restrict pb; + const GFC_LOGICAL_1 * restrict pa; + const GFC_LOGICAL_1 * restrict pb; index_type astride; index_type bstride; index_type count; @@ -99,17 +101,29 @@ matmul_l4 (gfc_array_l4 * const restrict retarray, } abase = a->data; - if (GFC_DESCRIPTOR_SIZE (a) != 4) - { - assert (GFC_DESCRIPTOR_SIZE (a) == 8); - abase = GFOR_POINTER_L8_TO_L4 (abase); - } + a_kind = GFC_DESCRIPTOR_SIZE (a); + + if (a_kind == 1 || a_kind == 2 || a_kind == 4 || a_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || a_kind == 16 +#endif + ) + abase = GFOR_POINTER_TO_L1 (abase, a_kind); + else + internal_error (NULL, "Funny sized logical array"); + bbase = b->data; - if (GFC_DESCRIPTOR_SIZE (b) != 4) - { - assert (GFC_DESCRIPTOR_SIZE (b) == 8); - bbase = GFOR_POINTER_L8_TO_L4 (bbase); - } + b_kind = GFC_DESCRIPTOR_SIZE (b); + + if (b_kind == 1 || b_kind == 2 || b_kind == 4 || b_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || b_kind == 16 +#endif + ) + bbase = GFOR_POINTER_TO_L1 (bbase, b_kind); + else + internal_error (NULL, "Funny sized logical array"); + dest = retarray->data; @@ -128,7 +142,7 @@ matmul_l4 (gfc_array_l4 * const restrict retarray, one. */ if (GFC_DESCRIPTOR_RANK (a) == 1) { - astride = a->dim[0].stride; + astride = a->dim[0].stride * a_kind; count = a->dim[0].ubound + 1 - a->dim[0].lbound; xstride = 0; rxstride = 0; @@ -136,14 +150,14 @@ matmul_l4 (gfc_array_l4 * const restrict retarray, } else { - astride = a->dim[1].stride; + astride = a->dim[1].stride * a_kind; count = a->dim[1].ubound + 1 - a->dim[1].lbound; - xstride = a->dim[0].stride; + xstride = a->dim[0].stride * a_kind; xcount = a->dim[0].ubound + 1 - a->dim[0].lbound; } if (GFC_DESCRIPTOR_RANK (b) == 1) { - bstride = b->dim[0].stride; + bstride = b->dim[0].stride * b_kind; assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound); ystride = 0; rystride = 0; @@ -151,9 +165,9 @@ matmul_l4 (gfc_array_l4 * const restrict retarray, } else { - bstride = b->dim[0].stride; + bstride = b->dim[0].stride * b_kind; assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound); - ystride = b->dim[1].stride; + ystride = b->dim[1].stride * b_kind; ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; } @@ -189,3 +203,4 @@ matmul_l4 (gfc_array_l4 * const restrict retarray, } #endif + diff --git a/libgfortran/generated/matmul_l8.c b/libgfortran/generated/matmul_l8.c index 76dee0a48d7..7d4e35e82e3 100644 --- a/libgfortran/generated/matmul_l8.c +++ b/libgfortran/generated/matmul_l8.c @@ -1,5 +1,5 @@ /* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_LOGICAL_8) @@ -39,15 +39,15 @@ Boston, MA 02110-1301, USA. */ Either a or b can be rank 1. In this case x or y is 1. */ extern void matmul_l8 (gfc_array_l8 * const restrict, - gfc_array_l4 * const restrict, gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict, gfc_array_l1 * const restrict); export_proto(matmul_l8); void matmul_l8 (gfc_array_l8 * const restrict retarray, - gfc_array_l4 * const restrict a, gfc_array_l4 * const restrict b) + gfc_array_l1 * const restrict a, gfc_array_l1 * const restrict b) { - const GFC_INTEGER_4 * restrict abase; - const GFC_INTEGER_4 * restrict bbase; + const GFC_LOGICAL_1 * restrict abase; + const GFC_LOGICAL_1 * restrict bbase; GFC_LOGICAL_8 * restrict dest; index_type rxstride; index_type rystride; @@ -57,9 +57,11 @@ matmul_l8 (gfc_array_l8 * const restrict retarray, index_type ystride; index_type x; index_type y; + int a_kind; + int b_kind; - const GFC_INTEGER_4 * restrict pa; - const GFC_INTEGER_4 * restrict pb; + const GFC_LOGICAL_1 * restrict pa; + const GFC_LOGICAL_1 * restrict pb; index_type astride; index_type bstride; index_type count; @@ -99,17 +101,29 @@ matmul_l8 (gfc_array_l8 * const restrict retarray, } abase = a->data; - if (GFC_DESCRIPTOR_SIZE (a) != 4) - { - assert (GFC_DESCRIPTOR_SIZE (a) == 8); - abase = GFOR_POINTER_L8_TO_L4 (abase); - } + a_kind = GFC_DESCRIPTOR_SIZE (a); + + if (a_kind == 1 || a_kind == 2 || a_kind == 4 || a_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || a_kind == 16 +#endif + ) + abase = GFOR_POINTER_TO_L1 (abase, a_kind); + else + internal_error (NULL, "Funny sized logical array"); + bbase = b->data; - if (GFC_DESCRIPTOR_SIZE (b) != 4) - { - assert (GFC_DESCRIPTOR_SIZE (b) == 8); - bbase = GFOR_POINTER_L8_TO_L4 (bbase); - } + b_kind = GFC_DESCRIPTOR_SIZE (b); + + if (b_kind == 1 || b_kind == 2 || b_kind == 4 || b_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || b_kind == 16 +#endif + ) + bbase = GFOR_POINTER_TO_L1 (bbase, b_kind); + else + internal_error (NULL, "Funny sized logical array"); + dest = retarray->data; @@ -128,7 +142,7 @@ matmul_l8 (gfc_array_l8 * const restrict retarray, one. */ if (GFC_DESCRIPTOR_RANK (a) == 1) { - astride = a->dim[0].stride; + astride = a->dim[0].stride * a_kind; count = a->dim[0].ubound + 1 - a->dim[0].lbound; xstride = 0; rxstride = 0; @@ -136,14 +150,14 @@ matmul_l8 (gfc_array_l8 * const restrict retarray, } else { - astride = a->dim[1].stride; + astride = a->dim[1].stride * a_kind; count = a->dim[1].ubound + 1 - a->dim[1].lbound; - xstride = a->dim[0].stride; + xstride = a->dim[0].stride * a_kind; xcount = a->dim[0].ubound + 1 - a->dim[0].lbound; } if (GFC_DESCRIPTOR_RANK (b) == 1) { - bstride = b->dim[0].stride; + bstride = b->dim[0].stride * b_kind; assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound); ystride = 0; rystride = 0; @@ -151,9 +165,9 @@ matmul_l8 (gfc_array_l8 * const restrict retarray, } else { - bstride = b->dim[0].stride; + bstride = b->dim[0].stride * b_kind; assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound); - ystride = b->dim[1].stride; + ystride = b->dim[1].stride * b_kind; ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; } @@ -189,3 +203,4 @@ matmul_l8 (gfc_array_l8 * const restrict retarray, } #endif + diff --git a/libgfortran/generated/matmul_r10.c b/libgfortran/generated/matmul_r10.c index 9f7fb4b654e..ee404b1b789 100644 --- a/libgfortran/generated/matmul_r10.c +++ b/libgfortran/generated/matmul_r10.c @@ -1,5 +1,5 @@ /* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <string.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_REAL_10) diff --git a/libgfortran/generated/matmul_r16.c b/libgfortran/generated/matmul_r16.c index 6a8f220a447..1d5f41efae5 100644 --- a/libgfortran/generated/matmul_r16.c +++ b/libgfortran/generated/matmul_r16.c @@ -1,5 +1,5 @@ /* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <string.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_REAL_16) diff --git a/libgfortran/generated/matmul_r4.c b/libgfortran/generated/matmul_r4.c index e4a45801edc..dc89f5592f9 100644 --- a/libgfortran/generated/matmul_r4.c +++ b/libgfortran/generated/matmul_r4.c @@ -1,5 +1,5 @@ /* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <string.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_REAL_4) diff --git a/libgfortran/generated/matmul_r8.c b/libgfortran/generated/matmul_r8.c index e823a756a97..5b23f28d697 100644 --- a/libgfortran/generated/matmul_r8.c +++ b/libgfortran/generated/matmul_r8.c @@ -1,5 +1,5 @@ /* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <string.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_REAL_8) diff --git a/libgfortran/generated/maxloc0_16_i1.c b/libgfortran/generated/maxloc0_16_i1.c index 37b0bb06614..7fc44432fa4 100644 --- a/libgfortran/generated/maxloc0_16_i1.c +++ b/libgfortran/generated/maxloc0_16_i1.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ maxloc0_16_i1 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_16_i1 (gfc_array_i16 * const restrict retarray, extern void mmaxloc0_16_i1 (gfc_array_i16 * const restrict, - gfc_array_i1 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i1 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_16_i1); void mmaxloc0_16_i1 (gfc_array_i16 * const restrict retarray, gfc_array_i1 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_16_i1 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_INTEGER_1 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_16_i1 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_16_i1 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_16_i1 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_16_i16.c b/libgfortran/generated/maxloc0_16_i16.c index efd421b053c..29eb3ccecf1 100644 --- a/libgfortran/generated/maxloc0_16_i16.c +++ b/libgfortran/generated/maxloc0_16_i16.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ maxloc0_16_i16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_16_i16 (gfc_array_i16 * const restrict retarray, extern void mmaxloc0_16_i16 (gfc_array_i16 * const restrict, - gfc_array_i16 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i16 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_16_i16); void mmaxloc0_16_i16 (gfc_array_i16 * const restrict retarray, gfc_array_i16 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_16_i16 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_INTEGER_16 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_16_i16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_16_i16 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_16_i16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_16_i2.c b/libgfortran/generated/maxloc0_16_i2.c index df2466b7776..30b693c1068 100644 --- a/libgfortran/generated/maxloc0_16_i2.c +++ b/libgfortran/generated/maxloc0_16_i2.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ maxloc0_16_i2 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_16_i2 (gfc_array_i16 * const restrict retarray, extern void mmaxloc0_16_i2 (gfc_array_i16 * const restrict, - gfc_array_i2 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i2 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_16_i2); void mmaxloc0_16_i2 (gfc_array_i16 * const restrict retarray, gfc_array_i2 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_16_i2 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_INTEGER_2 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_16_i2 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_16_i2 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_16_i2 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_16_i4.c b/libgfortran/generated/maxloc0_16_i4.c index 0154bf37c33..03f2794f30b 100644 --- a/libgfortran/generated/maxloc0_16_i4.c +++ b/libgfortran/generated/maxloc0_16_i4.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ maxloc0_16_i4 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_16_i4 (gfc_array_i16 * const restrict retarray, extern void mmaxloc0_16_i4 (gfc_array_i16 * const restrict, - gfc_array_i4 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i4 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_16_i4); void mmaxloc0_16_i4 (gfc_array_i16 * const restrict retarray, gfc_array_i4 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_16_i4 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_INTEGER_4 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_16_i4 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_16_i4 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_16_i4 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_16_i8.c b/libgfortran/generated/maxloc0_16_i8.c index 8f7804b201d..be18af39ce8 100644 --- a/libgfortran/generated/maxloc0_16_i8.c +++ b/libgfortran/generated/maxloc0_16_i8.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ maxloc0_16_i8 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_16_i8 (gfc_array_i16 * const restrict retarray, extern void mmaxloc0_16_i8 (gfc_array_i16 * const restrict, - gfc_array_i8 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i8 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_16_i8); void mmaxloc0_16_i8 (gfc_array_i16 * const restrict retarray, gfc_array_i8 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_16_i8 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_INTEGER_8 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_16_i8 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_16_i8 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_16_i8 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_16_r10.c b/libgfortran/generated/maxloc0_16_r10.c index 48910a9ce8d..48ba77e8732 100644 --- a/libgfortran/generated/maxloc0_16_r10.c +++ b/libgfortran/generated/maxloc0_16_r10.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ maxloc0_16_r10 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_16_r10 (gfc_array_i16 * const restrict retarray, extern void mmaxloc0_16_r10 (gfc_array_i16 * const restrict, - gfc_array_r10 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r10 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_16_r10); void mmaxloc0_16_r10 (gfc_array_i16 * const restrict retarray, gfc_array_r10 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_16_r10 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_REAL_10 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_16_r10 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_16_r10 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_16_r10 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_16_r16.c b/libgfortran/generated/maxloc0_16_r16.c index 8492293e9b3..9d2ce087015 100644 --- a/libgfortran/generated/maxloc0_16_r16.c +++ b/libgfortran/generated/maxloc0_16_r16.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ maxloc0_16_r16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_16_r16 (gfc_array_i16 * const restrict retarray, extern void mmaxloc0_16_r16 (gfc_array_i16 * const restrict, - gfc_array_r16 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r16 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_16_r16); void mmaxloc0_16_r16 (gfc_array_i16 * const restrict retarray, gfc_array_r16 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_16_r16 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_REAL_16 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_16_r16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_16_r16 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_16_r16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_16_r4.c b/libgfortran/generated/maxloc0_16_r4.c index 602f334b381..e908dadcdd0 100644 --- a/libgfortran/generated/maxloc0_16_r4.c +++ b/libgfortran/generated/maxloc0_16_r4.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ maxloc0_16_r4 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_16_r4 (gfc_array_i16 * const restrict retarray, extern void mmaxloc0_16_r4 (gfc_array_i16 * const restrict, - gfc_array_r4 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r4 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_16_r4); void mmaxloc0_16_r4 (gfc_array_i16 * const restrict retarray, gfc_array_r4 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_16_r4 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_REAL_4 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_16_r4 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_16_r4 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_16_r4 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_16_r8.c b/libgfortran/generated/maxloc0_16_r8.c index 1dbdda034a9..cb01745a44c 100644 --- a/libgfortran/generated/maxloc0_16_r8.c +++ b/libgfortran/generated/maxloc0_16_r8.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ maxloc0_16_r8 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_16_r8 (gfc_array_i16 * const restrict retarray, extern void mmaxloc0_16_r8 (gfc_array_i16 * const restrict, - gfc_array_r8 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r8 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_16_r8); void mmaxloc0_16_r8 (gfc_array_i16 * const restrict retarray, gfc_array_r8 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_16_r8 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_REAL_8 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_16_r8 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_16_r8 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_16_r8 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_4_i1.c b/libgfortran/generated/maxloc0_4_i1.c index de62212f47b..21ab578c402 100644 --- a/libgfortran/generated/maxloc0_4_i1.c +++ b/libgfortran/generated/maxloc0_4_i1.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ maxloc0_4_i1 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_4_i1 (gfc_array_i4 * const restrict retarray, extern void mmaxloc0_4_i1 (gfc_array_i4 * const restrict, - gfc_array_i1 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i1 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_4_i1); void mmaxloc0_4_i1 (gfc_array_i4 * const restrict retarray, gfc_array_i1 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_4_i1 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_INTEGER_1 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_4_i1 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_4_i1 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_4_i1 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_4_i16.c b/libgfortran/generated/maxloc0_4_i16.c index 98245df9814..6803420884c 100644 --- a/libgfortran/generated/maxloc0_4_i16.c +++ b/libgfortran/generated/maxloc0_4_i16.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ maxloc0_4_i16 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_4_i16 (gfc_array_i4 * const restrict retarray, extern void mmaxloc0_4_i16 (gfc_array_i4 * const restrict, - gfc_array_i16 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i16 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_4_i16); void mmaxloc0_4_i16 (gfc_array_i4 * const restrict retarray, gfc_array_i16 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_4_i16 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_INTEGER_16 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_4_i16 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_4_i16 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_4_i16 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_4_i2.c b/libgfortran/generated/maxloc0_4_i2.c index 0a0a04e82dc..27cccae9784 100644 --- a/libgfortran/generated/maxloc0_4_i2.c +++ b/libgfortran/generated/maxloc0_4_i2.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ maxloc0_4_i2 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_4_i2 (gfc_array_i4 * const restrict retarray, extern void mmaxloc0_4_i2 (gfc_array_i4 * const restrict, - gfc_array_i2 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i2 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_4_i2); void mmaxloc0_4_i2 (gfc_array_i4 * const restrict retarray, gfc_array_i2 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_4_i2 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_INTEGER_2 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_4_i2 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_4_i2 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_4_i2 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_4_i4.c b/libgfortran/generated/maxloc0_4_i4.c index e8fe5982483..650da03a1ed 100644 --- a/libgfortran/generated/maxloc0_4_i4.c +++ b/libgfortran/generated/maxloc0_4_i4.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ maxloc0_4_i4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_4_i4 (gfc_array_i4 * const restrict retarray, extern void mmaxloc0_4_i4 (gfc_array_i4 * const restrict, - gfc_array_i4 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i4 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_4_i4); void mmaxloc0_4_i4 (gfc_array_i4 * const restrict retarray, gfc_array_i4 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_4_i4 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_INTEGER_4 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_4_i4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_4_i4 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_4_i4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_4_i8.c b/libgfortran/generated/maxloc0_4_i8.c index 80ef84206d7..48e1d3e5215 100644 --- a/libgfortran/generated/maxloc0_4_i8.c +++ b/libgfortran/generated/maxloc0_4_i8.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ maxloc0_4_i8 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_4_i8 (gfc_array_i4 * const restrict retarray, extern void mmaxloc0_4_i8 (gfc_array_i4 * const restrict, - gfc_array_i8 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i8 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_4_i8); void mmaxloc0_4_i8 (gfc_array_i4 * const restrict retarray, gfc_array_i8 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_4_i8 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_INTEGER_8 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_4_i8 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_4_i8 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_4_i8 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_4_r10.c b/libgfortran/generated/maxloc0_4_r10.c index 0059d3bad05..05e31659238 100644 --- a/libgfortran/generated/maxloc0_4_r10.c +++ b/libgfortran/generated/maxloc0_4_r10.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ maxloc0_4_r10 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_4_r10 (gfc_array_i4 * const restrict retarray, extern void mmaxloc0_4_r10 (gfc_array_i4 * const restrict, - gfc_array_r10 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r10 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_4_r10); void mmaxloc0_4_r10 (gfc_array_i4 * const restrict retarray, gfc_array_r10 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_4_r10 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_REAL_10 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_4_r10 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_4_r10 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_4_r10 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_4_r16.c b/libgfortran/generated/maxloc0_4_r16.c index 9cb04bf30ce..38cf3527282 100644 --- a/libgfortran/generated/maxloc0_4_r16.c +++ b/libgfortran/generated/maxloc0_4_r16.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ maxloc0_4_r16 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_4_r16 (gfc_array_i4 * const restrict retarray, extern void mmaxloc0_4_r16 (gfc_array_i4 * const restrict, - gfc_array_r16 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r16 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_4_r16); void mmaxloc0_4_r16 (gfc_array_i4 * const restrict retarray, gfc_array_r16 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_4_r16 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_REAL_16 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_4_r16 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_4_r16 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_4_r16 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_4_r4.c b/libgfortran/generated/maxloc0_4_r4.c index e568a444b2a..5ab9429028e 100644 --- a/libgfortran/generated/maxloc0_4_r4.c +++ b/libgfortran/generated/maxloc0_4_r4.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ maxloc0_4_r4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_4_r4 (gfc_array_i4 * const restrict retarray, extern void mmaxloc0_4_r4 (gfc_array_i4 * const restrict, - gfc_array_r4 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r4 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_4_r4); void mmaxloc0_4_r4 (gfc_array_i4 * const restrict retarray, gfc_array_r4 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_4_r4 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_REAL_4 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_4_r4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_4_r4 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_4_r4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_4_r8.c b/libgfortran/generated/maxloc0_4_r8.c index e84235ea76f..2658e4a5b9a 100644 --- a/libgfortran/generated/maxloc0_4_r8.c +++ b/libgfortran/generated/maxloc0_4_r8.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ maxloc0_4_r8 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_4_r8 (gfc_array_i4 * const restrict retarray, extern void mmaxloc0_4_r8 (gfc_array_i4 * const restrict, - gfc_array_r8 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r8 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_4_r8); void mmaxloc0_4_r8 (gfc_array_i4 * const restrict retarray, gfc_array_r8 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_4_r8 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_REAL_8 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_4_r8 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_4_r8 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_4_r8 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_8_i1.c b/libgfortran/generated/maxloc0_8_i1.c index da132d4b5f1..ce71eb1ebbd 100644 --- a/libgfortran/generated/maxloc0_8_i1.c +++ b/libgfortran/generated/maxloc0_8_i1.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ maxloc0_8_i1 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_8_i1 (gfc_array_i8 * const restrict retarray, extern void mmaxloc0_8_i1 (gfc_array_i8 * const restrict, - gfc_array_i1 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i1 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_8_i1); void mmaxloc0_8_i1 (gfc_array_i8 * const restrict retarray, gfc_array_i1 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_8_i1 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_INTEGER_1 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_8_i1 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_8_i1 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_8_i1 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_8_i16.c b/libgfortran/generated/maxloc0_8_i16.c index 3b94adeffb3..e808a91cf59 100644 --- a/libgfortran/generated/maxloc0_8_i16.c +++ b/libgfortran/generated/maxloc0_8_i16.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ maxloc0_8_i16 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_8_i16 (gfc_array_i8 * const restrict retarray, extern void mmaxloc0_8_i16 (gfc_array_i8 * const restrict, - gfc_array_i16 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i16 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_8_i16); void mmaxloc0_8_i16 (gfc_array_i8 * const restrict retarray, gfc_array_i16 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_8_i16 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_INTEGER_16 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_8_i16 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_8_i16 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_8_i16 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_8_i2.c b/libgfortran/generated/maxloc0_8_i2.c index 41f6457ab63..8bc1961ea3a 100644 --- a/libgfortran/generated/maxloc0_8_i2.c +++ b/libgfortran/generated/maxloc0_8_i2.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ maxloc0_8_i2 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_8_i2 (gfc_array_i8 * const restrict retarray, extern void mmaxloc0_8_i2 (gfc_array_i8 * const restrict, - gfc_array_i2 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i2 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_8_i2); void mmaxloc0_8_i2 (gfc_array_i8 * const restrict retarray, gfc_array_i2 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_8_i2 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_INTEGER_2 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_8_i2 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_8_i2 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_8_i2 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_8_i4.c b/libgfortran/generated/maxloc0_8_i4.c index 93fa3581437..8b6d2128a5d 100644 --- a/libgfortran/generated/maxloc0_8_i4.c +++ b/libgfortran/generated/maxloc0_8_i4.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ maxloc0_8_i4 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_8_i4 (gfc_array_i8 * const restrict retarray, extern void mmaxloc0_8_i4 (gfc_array_i8 * const restrict, - gfc_array_i4 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i4 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_8_i4); void mmaxloc0_8_i4 (gfc_array_i8 * const restrict retarray, gfc_array_i4 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_8_i4 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_INTEGER_4 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_8_i4 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_8_i4 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_8_i4 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_8_i8.c b/libgfortran/generated/maxloc0_8_i8.c index 49a8d5255a0..121827eabb3 100644 --- a/libgfortran/generated/maxloc0_8_i8.c +++ b/libgfortran/generated/maxloc0_8_i8.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ maxloc0_8_i8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_8_i8 (gfc_array_i8 * const restrict retarray, extern void mmaxloc0_8_i8 (gfc_array_i8 * const restrict, - gfc_array_i8 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i8 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_8_i8); void mmaxloc0_8_i8 (gfc_array_i8 * const restrict retarray, gfc_array_i8 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_8_i8 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_INTEGER_8 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_8_i8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_8_i8 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_8_i8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_8_r10.c b/libgfortran/generated/maxloc0_8_r10.c index ebe3f04d195..8fb4b13eb69 100644 --- a/libgfortran/generated/maxloc0_8_r10.c +++ b/libgfortran/generated/maxloc0_8_r10.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ maxloc0_8_r10 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_8_r10 (gfc_array_i8 * const restrict retarray, extern void mmaxloc0_8_r10 (gfc_array_i8 * const restrict, - gfc_array_r10 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r10 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_8_r10); void mmaxloc0_8_r10 (gfc_array_i8 * const restrict retarray, gfc_array_r10 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_8_r10 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_REAL_10 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_8_r10 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_8_r10 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_8_r10 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_8_r16.c b/libgfortran/generated/maxloc0_8_r16.c index 800f5c6d7a0..7a5a4f354af 100644 --- a/libgfortran/generated/maxloc0_8_r16.c +++ b/libgfortran/generated/maxloc0_8_r16.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ maxloc0_8_r16 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_8_r16 (gfc_array_i8 * const restrict retarray, extern void mmaxloc0_8_r16 (gfc_array_i8 * const restrict, - gfc_array_r16 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r16 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_8_r16); void mmaxloc0_8_r16 (gfc_array_i8 * const restrict retarray, gfc_array_r16 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_8_r16 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_REAL_16 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_8_r16 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_8_r16 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_8_r16 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_8_r4.c b/libgfortran/generated/maxloc0_8_r4.c index f68a5ea4531..8e02dcb7718 100644 --- a/libgfortran/generated/maxloc0_8_r4.c +++ b/libgfortran/generated/maxloc0_8_r4.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ maxloc0_8_r4 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_8_r4 (gfc_array_i8 * const restrict retarray, extern void mmaxloc0_8_r4 (gfc_array_i8 * const restrict, - gfc_array_r4 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r4 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_8_r4); void mmaxloc0_8_r4 (gfc_array_i8 * const restrict retarray, gfc_array_r4 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_8_r4 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_REAL_4 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_8_r4 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_8_r4 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_8_r4 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc0_8_r8.c b/libgfortran/generated/maxloc0_8_r8.c index 5ec6afede23..c539df0596d 100644 --- a/libgfortran/generated/maxloc0_8_r8.c +++ b/libgfortran/generated/maxloc0_8_r8.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ maxloc0_8_r8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ maxloc0_8_r8 (gfc_array_i8 * const restrict retarray, extern void mmaxloc0_8_r8 (gfc_array_i8 * const restrict, - gfc_array_r8 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r8 * const restrict, gfc_array_l1 * const restrict); export_proto(mmaxloc0_8_r8); void mmaxloc0_8_r8 (gfc_array_i8 * const restrict retarray, gfc_array_r8 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mmaxloc0_8_r8 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_REAL_8 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mmaxloc0_8_r8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MAXLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mmaxloc0_8_r8 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ smaxloc0_8_r8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/maxloc1_16_i1.c b/libgfortran/generated/maxloc1_16_i1.c index 009ea6de124..47e67239322 100644 --- a/libgfortran/generated/maxloc1_16_i1.c +++ b/libgfortran/generated/maxloc1_16_i1.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ maxloc1_16_i1 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_16_i1 (gfc_array_i16 * const restrict retarray, extern void mmaxloc1_16_i1 (gfc_array_i16 * const restrict, gfc_array_i1 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_16_i1); void mmaxloc1_16_i1 (gfc_array_i16 * const restrict retarray, gfc_array_i1 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_16_i1 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_INTEGER_1 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_16_i1 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_16_i1 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_16_i1 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_16_i1 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_1 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_16_i1 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_16_i16.c b/libgfortran/generated/maxloc1_16_i16.c index 94bab619f19..2c8a06cb675 100644 --- a/libgfortran/generated/maxloc1_16_i16.c +++ b/libgfortran/generated/maxloc1_16_i16.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ maxloc1_16_i16 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_16_i16 (gfc_array_i16 * const restrict retarray, extern void mmaxloc1_16_i16 (gfc_array_i16 * const restrict, gfc_array_i16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_16_i16); void mmaxloc1_16_i16 (gfc_array_i16 * const restrict retarray, gfc_array_i16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_16_i16 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_INTEGER_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_16_i16 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_16_i16 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_16_i16 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_16_i16 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_16_i16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_16_i2.c b/libgfortran/generated/maxloc1_16_i2.c index 9cdd41814d3..d7b1ca57eed 100644 --- a/libgfortran/generated/maxloc1_16_i2.c +++ b/libgfortran/generated/maxloc1_16_i2.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ maxloc1_16_i2 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_16_i2 (gfc_array_i16 * const restrict retarray, extern void mmaxloc1_16_i2 (gfc_array_i16 * const restrict, gfc_array_i2 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_16_i2); void mmaxloc1_16_i2 (gfc_array_i16 * const restrict retarray, gfc_array_i2 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_16_i2 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_INTEGER_2 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_16_i2 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_16_i2 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_16_i2 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_16_i2 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_2 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_16_i2 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_16_i4.c b/libgfortran/generated/maxloc1_16_i4.c index 564b378c4ed..394c0160261 100644 --- a/libgfortran/generated/maxloc1_16_i4.c +++ b/libgfortran/generated/maxloc1_16_i4.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ maxloc1_16_i4 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_16_i4 (gfc_array_i16 * const restrict retarray, extern void mmaxloc1_16_i4 (gfc_array_i16 * const restrict, gfc_array_i4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_16_i4); void mmaxloc1_16_i4 (gfc_array_i16 * const restrict retarray, gfc_array_i4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_16_i4 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_INTEGER_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_16_i4 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_16_i4 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_16_i4 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_16_i4 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_16_i4 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_16_i8.c b/libgfortran/generated/maxloc1_16_i8.c index 91b68bf1b76..5cff65dece4 100644 --- a/libgfortran/generated/maxloc1_16_i8.c +++ b/libgfortran/generated/maxloc1_16_i8.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ maxloc1_16_i8 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_16_i8 (gfc_array_i16 * const restrict retarray, extern void mmaxloc1_16_i8 (gfc_array_i16 * const restrict, gfc_array_i8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_16_i8); void mmaxloc1_16_i8 (gfc_array_i16 * const restrict retarray, gfc_array_i8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_16_i8 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_INTEGER_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_16_i8 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_16_i8 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_16_i8 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_16_i8 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_16_i8 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_16_r10.c b/libgfortran/generated/maxloc1_16_r10.c index f60e044d6f9..32af8cd8854 100644 --- a/libgfortran/generated/maxloc1_16_r10.c +++ b/libgfortran/generated/maxloc1_16_r10.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ maxloc1_16_r10 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_16_r10 (gfc_array_i16 * const restrict retarray, extern void mmaxloc1_16_r10 (gfc_array_i16 * const restrict, gfc_array_r10 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_16_r10); void mmaxloc1_16_r10 (gfc_array_i16 * const restrict retarray, gfc_array_r10 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_16_r10 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_REAL_10 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_16_r10 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_16_r10 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_16_r10 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_16_r10 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_10 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_16_r10 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_16_r16.c b/libgfortran/generated/maxloc1_16_r16.c index 22bdb6d545f..d695ad8ec5d 100644 --- a/libgfortran/generated/maxloc1_16_r16.c +++ b/libgfortran/generated/maxloc1_16_r16.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ maxloc1_16_r16 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_16_r16 (gfc_array_i16 * const restrict retarray, extern void mmaxloc1_16_r16 (gfc_array_i16 * const restrict, gfc_array_r16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_16_r16); void mmaxloc1_16_r16 (gfc_array_i16 * const restrict retarray, gfc_array_r16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_16_r16 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_REAL_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_16_r16 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_16_r16 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_16_r16 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_16_r16 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_16_r16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_16_r4.c b/libgfortran/generated/maxloc1_16_r4.c index 4af1841322b..05dfbe380a7 100644 --- a/libgfortran/generated/maxloc1_16_r4.c +++ b/libgfortran/generated/maxloc1_16_r4.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ maxloc1_16_r4 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_16_r4 (gfc_array_i16 * const restrict retarray, extern void mmaxloc1_16_r4 (gfc_array_i16 * const restrict, gfc_array_r4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_16_r4); void mmaxloc1_16_r4 (gfc_array_i16 * const restrict retarray, gfc_array_r4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_16_r4 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_REAL_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_16_r4 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_16_r4 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_16_r4 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_16_r4 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_16_r4 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_16_r8.c b/libgfortran/generated/maxloc1_16_r8.c index 34d5ada7dc9..a060e0620a8 100644 --- a/libgfortran/generated/maxloc1_16_r8.c +++ b/libgfortran/generated/maxloc1_16_r8.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ maxloc1_16_r8 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_16_r8 (gfc_array_i16 * const restrict retarray, extern void mmaxloc1_16_r8 (gfc_array_i16 * const restrict, gfc_array_r8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_16_r8); void mmaxloc1_16_r8 (gfc_array_i16 * const restrict retarray, gfc_array_r8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_16_r8 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_REAL_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_16_r8 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_16_r8 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_16_r8 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_16_r8 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_16_r8 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_4_i1.c b/libgfortran/generated/maxloc1_4_i1.c index e2f41411528..2244456c154 100644 --- a/libgfortran/generated/maxloc1_4_i1.c +++ b/libgfortran/generated/maxloc1_4_i1.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ maxloc1_4_i1 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_4_i1 (gfc_array_i4 * const restrict retarray, extern void mmaxloc1_4_i1 (gfc_array_i4 * const restrict, gfc_array_i1 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_4_i1); void mmaxloc1_4_i1 (gfc_array_i4 * const restrict retarray, gfc_array_i1 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_4_i1 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_INTEGER_1 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_4_i1 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_4_i1 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_4_i1 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_4_i1 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_1 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_4_i1 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_4_i16.c b/libgfortran/generated/maxloc1_4_i16.c index 30d782ca579..d0f260c962d 100644 --- a/libgfortran/generated/maxloc1_4_i16.c +++ b/libgfortran/generated/maxloc1_4_i16.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ maxloc1_4_i16 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_4_i16 (gfc_array_i4 * const restrict retarray, extern void mmaxloc1_4_i16 (gfc_array_i4 * const restrict, gfc_array_i16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_4_i16); void mmaxloc1_4_i16 (gfc_array_i4 * const restrict retarray, gfc_array_i16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_4_i16 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_INTEGER_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_4_i16 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_4_i16 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_4_i16 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_4_i16 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_4_i16 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_4_i2.c b/libgfortran/generated/maxloc1_4_i2.c index 1e02f75b1c6..5415ebabacf 100644 --- a/libgfortran/generated/maxloc1_4_i2.c +++ b/libgfortran/generated/maxloc1_4_i2.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ maxloc1_4_i2 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_4_i2 (gfc_array_i4 * const restrict retarray, extern void mmaxloc1_4_i2 (gfc_array_i4 * const restrict, gfc_array_i2 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_4_i2); void mmaxloc1_4_i2 (gfc_array_i4 * const restrict retarray, gfc_array_i2 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_4_i2 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_INTEGER_2 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_4_i2 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_4_i2 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_4_i2 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_4_i2 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_2 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_4_i2 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_4_i4.c b/libgfortran/generated/maxloc1_4_i4.c index 249efd76354..291b919945d 100644 --- a/libgfortran/generated/maxloc1_4_i4.c +++ b/libgfortran/generated/maxloc1_4_i4.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ maxloc1_4_i4 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_4_i4 (gfc_array_i4 * const restrict retarray, extern void mmaxloc1_4_i4 (gfc_array_i4 * const restrict, gfc_array_i4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_4_i4); void mmaxloc1_4_i4 (gfc_array_i4 * const restrict retarray, gfc_array_i4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_4_i4 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_INTEGER_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_4_i4 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_4_i4 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_4_i4 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_4_i4 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_4_i4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_4_i8.c b/libgfortran/generated/maxloc1_4_i8.c index b12a40b9050..97a904dc687 100644 --- a/libgfortran/generated/maxloc1_4_i8.c +++ b/libgfortran/generated/maxloc1_4_i8.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ maxloc1_4_i8 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_4_i8 (gfc_array_i4 * const restrict retarray, extern void mmaxloc1_4_i8 (gfc_array_i4 * const restrict, gfc_array_i8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_4_i8); void mmaxloc1_4_i8 (gfc_array_i4 * const restrict retarray, gfc_array_i8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_4_i8 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_INTEGER_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_4_i8 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_4_i8 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_4_i8 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_4_i8 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_4_i8 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_4_r10.c b/libgfortran/generated/maxloc1_4_r10.c index c498bffd669..07ccb242ae4 100644 --- a/libgfortran/generated/maxloc1_4_r10.c +++ b/libgfortran/generated/maxloc1_4_r10.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ maxloc1_4_r10 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_4_r10 (gfc_array_i4 * const restrict retarray, extern void mmaxloc1_4_r10 (gfc_array_i4 * const restrict, gfc_array_r10 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_4_r10); void mmaxloc1_4_r10 (gfc_array_i4 * const restrict retarray, gfc_array_r10 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_4_r10 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_REAL_10 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_4_r10 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_4_r10 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_4_r10 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_4_r10 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_10 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_4_r10 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_4_r16.c b/libgfortran/generated/maxloc1_4_r16.c index 71c9723c120..5ecfffd7b04 100644 --- a/libgfortran/generated/maxloc1_4_r16.c +++ b/libgfortran/generated/maxloc1_4_r16.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ maxloc1_4_r16 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_4_r16 (gfc_array_i4 * const restrict retarray, extern void mmaxloc1_4_r16 (gfc_array_i4 * const restrict, gfc_array_r16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_4_r16); void mmaxloc1_4_r16 (gfc_array_i4 * const restrict retarray, gfc_array_r16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_4_r16 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_REAL_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_4_r16 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_4_r16 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_4_r16 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_4_r16 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_4_r16 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_4_r4.c b/libgfortran/generated/maxloc1_4_r4.c index 69f3ca9e268..f859cc76199 100644 --- a/libgfortran/generated/maxloc1_4_r4.c +++ b/libgfortran/generated/maxloc1_4_r4.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ maxloc1_4_r4 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_4_r4 (gfc_array_i4 * const restrict retarray, extern void mmaxloc1_4_r4 (gfc_array_i4 * const restrict, gfc_array_r4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_4_r4); void mmaxloc1_4_r4 (gfc_array_i4 * const restrict retarray, gfc_array_r4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_4_r4 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_REAL_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_4_r4 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_4_r4 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_4_r4 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_4_r4 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_4_r4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_4_r8.c b/libgfortran/generated/maxloc1_4_r8.c index cab8eebbfa2..5d673420fd9 100644 --- a/libgfortran/generated/maxloc1_4_r8.c +++ b/libgfortran/generated/maxloc1_4_r8.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ maxloc1_4_r8 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_4_r8 (gfc_array_i4 * const restrict retarray, extern void mmaxloc1_4_r8 (gfc_array_i4 * const restrict, gfc_array_r8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_4_r8); void mmaxloc1_4_r8 (gfc_array_i4 * const restrict retarray, gfc_array_r8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_4_r8 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_REAL_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_4_r8 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_4_r8 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_4_r8 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_4_r8 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_4_r8 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_8_i1.c b/libgfortran/generated/maxloc1_8_i1.c index a6a796672e1..f9ea707ab95 100644 --- a/libgfortran/generated/maxloc1_8_i1.c +++ b/libgfortran/generated/maxloc1_8_i1.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ maxloc1_8_i1 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_8_i1 (gfc_array_i8 * const restrict retarray, extern void mmaxloc1_8_i1 (gfc_array_i8 * const restrict, gfc_array_i1 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_8_i1); void mmaxloc1_8_i1 (gfc_array_i8 * const restrict retarray, gfc_array_i1 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_8_i1 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_INTEGER_1 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_8_i1 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_8_i1 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_8_i1 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_8_i1 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_1 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_8_i1 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_8_i16.c b/libgfortran/generated/maxloc1_8_i16.c index b366e68cf71..478a8bc87b0 100644 --- a/libgfortran/generated/maxloc1_8_i16.c +++ b/libgfortran/generated/maxloc1_8_i16.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ maxloc1_8_i16 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_8_i16 (gfc_array_i8 * const restrict retarray, extern void mmaxloc1_8_i16 (gfc_array_i8 * const restrict, gfc_array_i16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_8_i16); void mmaxloc1_8_i16 (gfc_array_i8 * const restrict retarray, gfc_array_i16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_8_i16 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_INTEGER_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_8_i16 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_8_i16 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_8_i16 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_8_i16 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_8_i16 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_8_i2.c b/libgfortran/generated/maxloc1_8_i2.c index 0cfe019ad4b..972767f6558 100644 --- a/libgfortran/generated/maxloc1_8_i2.c +++ b/libgfortran/generated/maxloc1_8_i2.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ maxloc1_8_i2 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_8_i2 (gfc_array_i8 * const restrict retarray, extern void mmaxloc1_8_i2 (gfc_array_i8 * const restrict, gfc_array_i2 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_8_i2); void mmaxloc1_8_i2 (gfc_array_i8 * const restrict retarray, gfc_array_i2 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_8_i2 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_INTEGER_2 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_8_i2 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_8_i2 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_8_i2 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_8_i2 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_2 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_8_i2 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_8_i4.c b/libgfortran/generated/maxloc1_8_i4.c index e43ba950ade..e3b566d57ec 100644 --- a/libgfortran/generated/maxloc1_8_i4.c +++ b/libgfortran/generated/maxloc1_8_i4.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ maxloc1_8_i4 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_8_i4 (gfc_array_i8 * const restrict retarray, extern void mmaxloc1_8_i4 (gfc_array_i8 * const restrict, gfc_array_i4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_8_i4); void mmaxloc1_8_i4 (gfc_array_i8 * const restrict retarray, gfc_array_i4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_8_i4 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_INTEGER_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_8_i4 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_8_i4 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_8_i4 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_8_i4 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_8_i4 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_8_i8.c b/libgfortran/generated/maxloc1_8_i8.c index 733462baffe..e30e104dfc6 100644 --- a/libgfortran/generated/maxloc1_8_i8.c +++ b/libgfortran/generated/maxloc1_8_i8.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ maxloc1_8_i8 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_8_i8 (gfc_array_i8 * const restrict retarray, extern void mmaxloc1_8_i8 (gfc_array_i8 * const restrict, gfc_array_i8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_8_i8); void mmaxloc1_8_i8 (gfc_array_i8 * const restrict retarray, gfc_array_i8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_8_i8 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_INTEGER_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_8_i8 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_8_i8 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_8_i8 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_8_i8 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_8_i8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_8_r10.c b/libgfortran/generated/maxloc1_8_r10.c index deef31c91ec..01e30f660e4 100644 --- a/libgfortran/generated/maxloc1_8_r10.c +++ b/libgfortran/generated/maxloc1_8_r10.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ maxloc1_8_r10 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_8_r10 (gfc_array_i8 * const restrict retarray, extern void mmaxloc1_8_r10 (gfc_array_i8 * const restrict, gfc_array_r10 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_8_r10); void mmaxloc1_8_r10 (gfc_array_i8 * const restrict retarray, gfc_array_r10 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_8_r10 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_REAL_10 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_8_r10 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_8_r10 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_8_r10 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_8_r10 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_10 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_8_r10 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_8_r16.c b/libgfortran/generated/maxloc1_8_r16.c index 24d55c34bca..fbe72d1874f 100644 --- a/libgfortran/generated/maxloc1_8_r16.c +++ b/libgfortran/generated/maxloc1_8_r16.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ maxloc1_8_r16 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_8_r16 (gfc_array_i8 * const restrict retarray, extern void mmaxloc1_8_r16 (gfc_array_i8 * const restrict, gfc_array_r16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_8_r16); void mmaxloc1_8_r16 (gfc_array_i8 * const restrict retarray, gfc_array_r16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_8_r16 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_REAL_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_8_r16 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_8_r16 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_8_r16 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_8_r16 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_8_r16 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_8_r4.c b/libgfortran/generated/maxloc1_8_r4.c index 3dd01b3bd6a..3985d684fe4 100644 --- a/libgfortran/generated/maxloc1_8_r4.c +++ b/libgfortran/generated/maxloc1_8_r4.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ maxloc1_8_r4 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_8_r4 (gfc_array_i8 * const restrict retarray, extern void mmaxloc1_8_r4 (gfc_array_i8 * const restrict, gfc_array_r4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_8_r4); void mmaxloc1_8_r4 (gfc_array_i8 * const restrict retarray, gfc_array_r4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_8_r4 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_REAL_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_8_r4 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_8_r4 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_8_r4 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_8_r4 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_8_r4 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxloc1_8_r8.c b/libgfortran/generated/maxloc1_8_r8.c index 1adc4c88838..6e7745b31ba 100644 --- a/libgfortran/generated/maxloc1_8_r8.c +++ b/libgfortran/generated/maxloc1_8_r8.c @@ -1,5 +1,5 @@ /* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ maxloc1_8_r8 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ maxloc1_8_r8 (gfc_array_i8 * const restrict retarray, extern void mmaxloc1_8_r8 (gfc_array_i8 * const restrict, gfc_array_r8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxloc1_8_r8); void mmaxloc1_8_r8 (gfc_array_i8 * const restrict retarray, gfc_array_r8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mmaxloc1_8_r8 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_REAL_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mmaxloc1_8_r8 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mmaxloc1_8_r8 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mmaxloc1_8_r8 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mmaxloc1_8_r8 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ smaxloc1_8_r8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxval_i1.c b/libgfortran/generated/maxval_i1.c index 3c63c225821..901f4e7f2a7 100644 --- a/libgfortran/generated/maxval_i1.c +++ b/libgfortran/generated/maxval_i1.c @@ -1,5 +1,5 @@ /* Implementation of the MAXVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) @@ -116,7 +115,26 @@ maxval_i1 (gfc_array_i1 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ maxval_i1 (gfc_array_i1 * const restrict retarray, extern void mmaxval_i1 (gfc_array_i1 * const restrict, gfc_array_i1 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxval_i1); void mmaxval_i1 (gfc_array_i1 * const restrict retarray, gfc_array_i1 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mmaxval_i1 (gfc_array_i1 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_1 * restrict dest; const GFC_INTEGER_1 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mmaxval_i1 (gfc_array_i1 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mmaxval_i1 (gfc_array_i1 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mmaxval_i1 (gfc_array_i1 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mmaxval_i1 (gfc_array_i1 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_1 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_1 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ smaxval_i1 (gfc_array_i1 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxval_i16.c b/libgfortran/generated/maxval_i16.c index 9a217ac9dbd..c082e856922 100644 --- a/libgfortran/generated/maxval_i16.c +++ b/libgfortran/generated/maxval_i16.c @@ -1,5 +1,5 @@ /* Implementation of the MAXVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) @@ -116,7 +115,26 @@ maxval_i16 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ maxval_i16 (gfc_array_i16 * const restrict retarray, extern void mmaxval_i16 (gfc_array_i16 * const restrict, gfc_array_i16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxval_i16); void mmaxval_i16 (gfc_array_i16 * const restrict retarray, gfc_array_i16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mmaxval_i16 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_INTEGER_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mmaxval_i16 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mmaxval_i16 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mmaxval_i16 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mmaxval_i16 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ smaxval_i16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxval_i2.c b/libgfortran/generated/maxval_i2.c index c8fd718f8dc..87865e1b49b 100644 --- a/libgfortran/generated/maxval_i2.c +++ b/libgfortran/generated/maxval_i2.c @@ -1,5 +1,5 @@ /* Implementation of the MAXVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_2) @@ -116,7 +115,26 @@ maxval_i2 (gfc_array_i2 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ maxval_i2 (gfc_array_i2 * const restrict retarray, extern void mmaxval_i2 (gfc_array_i2 * const restrict, gfc_array_i2 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxval_i2); void mmaxval_i2 (gfc_array_i2 * const restrict retarray, gfc_array_i2 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mmaxval_i2 (gfc_array_i2 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_2 * restrict dest; const GFC_INTEGER_2 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mmaxval_i2 (gfc_array_i2 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mmaxval_i2 (gfc_array_i2 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mmaxval_i2 (gfc_array_i2 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mmaxval_i2 (gfc_array_i2 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_2 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_2 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ smaxval_i2 (gfc_array_i2 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxval_i4.c b/libgfortran/generated/maxval_i4.c index c800f1a733d..3fa4a10b1bf 100644 --- a/libgfortran/generated/maxval_i4.c +++ b/libgfortran/generated/maxval_i4.c @@ -1,5 +1,5 @@ /* Implementation of the MAXVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) @@ -116,7 +115,26 @@ maxval_i4 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ maxval_i4 (gfc_array_i4 * const restrict retarray, extern void mmaxval_i4 (gfc_array_i4 * const restrict, gfc_array_i4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxval_i4); void mmaxval_i4 (gfc_array_i4 * const restrict retarray, gfc_array_i4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mmaxval_i4 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_INTEGER_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mmaxval_i4 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mmaxval_i4 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mmaxval_i4 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mmaxval_i4 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ smaxval_i4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxval_i8.c b/libgfortran/generated/maxval_i8.c index 898ef3c5956..8b2106d209f 100644 --- a/libgfortran/generated/maxval_i8.c +++ b/libgfortran/generated/maxval_i8.c @@ -1,5 +1,5 @@ /* Implementation of the MAXVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) @@ -116,7 +115,26 @@ maxval_i8 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ maxval_i8 (gfc_array_i8 * const restrict retarray, extern void mmaxval_i8 (gfc_array_i8 * const restrict, gfc_array_i8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxval_i8); void mmaxval_i8 (gfc_array_i8 * const restrict retarray, gfc_array_i8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mmaxval_i8 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_INTEGER_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mmaxval_i8 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mmaxval_i8 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mmaxval_i8 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mmaxval_i8 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ smaxval_i8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxval_r10.c b/libgfortran/generated/maxval_r10.c index 3123d06cf58..a076190e8af 100644 --- a/libgfortran/generated/maxval_r10.c +++ b/libgfortran/generated/maxval_r10.c @@ -1,5 +1,5 @@ /* Implementation of the MAXVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_REAL_10) @@ -116,7 +115,26 @@ maxval_r10 (gfc_array_r10 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ maxval_r10 (gfc_array_r10 * const restrict retarray, extern void mmaxval_r10 (gfc_array_r10 * const restrict, gfc_array_r10 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxval_r10); void mmaxval_r10 (gfc_array_r10 * const restrict retarray, gfc_array_r10 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mmaxval_r10 (gfc_array_r10 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_REAL_10 * restrict dest; const GFC_REAL_10 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mmaxval_r10 (gfc_array_r10 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mmaxval_r10 (gfc_array_r10 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mmaxval_r10 (gfc_array_r10 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mmaxval_r10 (gfc_array_r10 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_10 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_REAL_10 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ smaxval_r10 (gfc_array_r10 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxval_r16.c b/libgfortran/generated/maxval_r16.c index bdef6167916..1e36379048b 100644 --- a/libgfortran/generated/maxval_r16.c +++ b/libgfortran/generated/maxval_r16.c @@ -1,5 +1,5 @@ /* Implementation of the MAXVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_REAL_16) @@ -116,7 +115,26 @@ maxval_r16 (gfc_array_r16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ maxval_r16 (gfc_array_r16 * const restrict retarray, extern void mmaxval_r16 (gfc_array_r16 * const restrict, gfc_array_r16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxval_r16); void mmaxval_r16 (gfc_array_r16 * const restrict retarray, gfc_array_r16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mmaxval_r16 (gfc_array_r16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_REAL_16 * restrict dest; const GFC_REAL_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mmaxval_r16 (gfc_array_r16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mmaxval_r16 (gfc_array_r16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mmaxval_r16 (gfc_array_r16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mmaxval_r16 (gfc_array_r16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_REAL_16 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ smaxval_r16 (gfc_array_r16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxval_r4.c b/libgfortran/generated/maxval_r4.c index ebdb9684fb6..222a4e3beee 100644 --- a/libgfortran/generated/maxval_r4.c +++ b/libgfortran/generated/maxval_r4.c @@ -1,5 +1,5 @@ /* Implementation of the MAXVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4) @@ -116,7 +115,26 @@ maxval_r4 (gfc_array_r4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ maxval_r4 (gfc_array_r4 * const restrict retarray, extern void mmaxval_r4 (gfc_array_r4 * const restrict, gfc_array_r4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxval_r4); void mmaxval_r4 (gfc_array_r4 * const restrict retarray, gfc_array_r4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mmaxval_r4 (gfc_array_r4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_REAL_4 * restrict dest; const GFC_REAL_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mmaxval_r4 (gfc_array_r4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mmaxval_r4 (gfc_array_r4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mmaxval_r4 (gfc_array_r4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mmaxval_r4 (gfc_array_r4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_REAL_4 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ smaxval_r4 (gfc_array_r4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/maxval_r8.c b/libgfortran/generated/maxval_r8.c index 6a05df76381..163ec5a1b03 100644 --- a/libgfortran/generated/maxval_r8.c +++ b/libgfortran/generated/maxval_r8.c @@ -1,5 +1,5 @@ /* Implementation of the MAXVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8) @@ -116,7 +115,26 @@ maxval_r8 (gfc_array_r8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ maxval_r8 (gfc_array_r8 * const restrict retarray, extern void mmaxval_r8 (gfc_array_r8 * const restrict, gfc_array_r8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mmaxval_r8); void mmaxval_r8 (gfc_array_r8 * const restrict retarray, gfc_array_r8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mmaxval_r8 (gfc_array_r8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_REAL_8 * restrict dest; const GFC_REAL_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mmaxval_r8 (gfc_array_r8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mmaxval_r8 (gfc_array_r8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mmaxval_r8 (gfc_array_r8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mmaxval_r8 (gfc_array_r8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_REAL_8 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ smaxval_r8 (gfc_array_r8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MAXVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc0_16_i1.c b/libgfortran/generated/minloc0_16_i1.c index e8f985627d8..d0d6903bf41 100644 --- a/libgfortran/generated/minloc0_16_i1.c +++ b/libgfortran/generated/minloc0_16_i1.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ minloc0_16_i1 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_16_i1 (gfc_array_i16 * const restrict retarray, extern void mminloc0_16_i1 (gfc_array_i16 * const restrict, - gfc_array_i1 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i1 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_16_i1); void mminloc0_16_i1 (gfc_array_i16 * const restrict retarray, gfc_array_i1 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_16_i1 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_INTEGER_1 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_16_i1 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_16_i1 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_16_i1 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_16_i16.c b/libgfortran/generated/minloc0_16_i16.c index 31ade2421ea..59c1d0abbf8 100644 --- a/libgfortran/generated/minloc0_16_i16.c +++ b/libgfortran/generated/minloc0_16_i16.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ minloc0_16_i16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_16_i16 (gfc_array_i16 * const restrict retarray, extern void mminloc0_16_i16 (gfc_array_i16 * const restrict, - gfc_array_i16 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i16 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_16_i16); void mminloc0_16_i16 (gfc_array_i16 * const restrict retarray, gfc_array_i16 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_16_i16 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_INTEGER_16 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_16_i16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_16_i16 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_16_i16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_16_i2.c b/libgfortran/generated/minloc0_16_i2.c index 772519dbebd..0df6bd189c5 100644 --- a/libgfortran/generated/minloc0_16_i2.c +++ b/libgfortran/generated/minloc0_16_i2.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ minloc0_16_i2 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_16_i2 (gfc_array_i16 * const restrict retarray, extern void mminloc0_16_i2 (gfc_array_i16 * const restrict, - gfc_array_i2 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i2 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_16_i2); void mminloc0_16_i2 (gfc_array_i16 * const restrict retarray, gfc_array_i2 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_16_i2 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_INTEGER_2 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_16_i2 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_16_i2 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_16_i2 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_16_i4.c b/libgfortran/generated/minloc0_16_i4.c index 3096ec02049..48bb60be737 100644 --- a/libgfortran/generated/minloc0_16_i4.c +++ b/libgfortran/generated/minloc0_16_i4.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ minloc0_16_i4 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_16_i4 (gfc_array_i16 * const restrict retarray, extern void mminloc0_16_i4 (gfc_array_i16 * const restrict, - gfc_array_i4 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i4 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_16_i4); void mminloc0_16_i4 (gfc_array_i16 * const restrict retarray, gfc_array_i4 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_16_i4 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_INTEGER_4 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_16_i4 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_16_i4 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_16_i4 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_16_i8.c b/libgfortran/generated/minloc0_16_i8.c index 99b53bef5eb..b92f7e43031 100644 --- a/libgfortran/generated/minloc0_16_i8.c +++ b/libgfortran/generated/minloc0_16_i8.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ minloc0_16_i8 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_16_i8 (gfc_array_i16 * const restrict retarray, extern void mminloc0_16_i8 (gfc_array_i16 * const restrict, - gfc_array_i8 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i8 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_16_i8); void mminloc0_16_i8 (gfc_array_i16 * const restrict retarray, gfc_array_i8 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_16_i8 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_INTEGER_8 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_16_i8 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_16_i8 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_16_i8 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_16_r10.c b/libgfortran/generated/minloc0_16_r10.c index 5c043f899d9..6480a8dd681 100644 --- a/libgfortran/generated/minloc0_16_r10.c +++ b/libgfortran/generated/minloc0_16_r10.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ minloc0_16_r10 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_16_r10 (gfc_array_i16 * const restrict retarray, extern void mminloc0_16_r10 (gfc_array_i16 * const restrict, - gfc_array_r10 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r10 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_16_r10); void mminloc0_16_r10 (gfc_array_i16 * const restrict retarray, gfc_array_r10 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_16_r10 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_REAL_10 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_16_r10 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_16_r10 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_16_r10 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_16_r16.c b/libgfortran/generated/minloc0_16_r16.c index 9a87bb61ee7..325c8f68d50 100644 --- a/libgfortran/generated/minloc0_16_r16.c +++ b/libgfortran/generated/minloc0_16_r16.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ minloc0_16_r16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_16_r16 (gfc_array_i16 * const restrict retarray, extern void mminloc0_16_r16 (gfc_array_i16 * const restrict, - gfc_array_r16 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r16 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_16_r16); void mminloc0_16_r16 (gfc_array_i16 * const restrict retarray, gfc_array_r16 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_16_r16 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_REAL_16 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_16_r16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_16_r16 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_16_r16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_16_r4.c b/libgfortran/generated/minloc0_16_r4.c index dbe167ecfea..2376d4034b6 100644 --- a/libgfortran/generated/minloc0_16_r4.c +++ b/libgfortran/generated/minloc0_16_r4.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ minloc0_16_r4 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_16_r4 (gfc_array_i16 * const restrict retarray, extern void mminloc0_16_r4 (gfc_array_i16 * const restrict, - gfc_array_r4 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r4 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_16_r4); void mminloc0_16_r4 (gfc_array_i16 * const restrict retarray, gfc_array_r4 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_16_r4 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_REAL_4 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_16_r4 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_16_r4 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_16_r4 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_16_r8.c b/libgfortran/generated/minloc0_16_r8.c index 8c43bb5a7c4..e72abab2c5b 100644 --- a/libgfortran/generated/minloc0_16_r8.c +++ b/libgfortran/generated/minloc0_16_r8.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_16) @@ -70,11 +69,22 @@ minloc0_16_r8 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_16_r8 (gfc_array_i16 * const restrict retarray, extern void mminloc0_16_r8 (gfc_array_i16 * const restrict, - gfc_array_r8 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r8 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_16_r8); void mminloc0_16_r8 (gfc_array_i16 * const restrict retarray, gfc_array_r8 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_16_r8 (gfc_array_i16 * const restrict retarray, index_type dstride; GFC_INTEGER_16 *dest; const GFC_REAL_8 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_16_r8 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_16_r8 (gfc_array_i16 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_16_r8 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_4_i1.c b/libgfortran/generated/minloc0_4_i1.c index 42d64a8750d..ce045a28e73 100644 --- a/libgfortran/generated/minloc0_4_i1.c +++ b/libgfortran/generated/minloc0_4_i1.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ minloc0_4_i1 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_4_i1 (gfc_array_i4 * const restrict retarray, extern void mminloc0_4_i1 (gfc_array_i4 * const restrict, - gfc_array_i1 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i1 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_4_i1); void mminloc0_4_i1 (gfc_array_i4 * const restrict retarray, gfc_array_i1 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_4_i1 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_INTEGER_1 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_4_i1 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_4_i1 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_4_i1 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_4_i16.c b/libgfortran/generated/minloc0_4_i16.c index 19b960e912a..9ae856e686c 100644 --- a/libgfortran/generated/minloc0_4_i16.c +++ b/libgfortran/generated/minloc0_4_i16.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ minloc0_4_i16 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_4_i16 (gfc_array_i4 * const restrict retarray, extern void mminloc0_4_i16 (gfc_array_i4 * const restrict, - gfc_array_i16 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i16 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_4_i16); void mminloc0_4_i16 (gfc_array_i4 * const restrict retarray, gfc_array_i16 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_4_i16 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_INTEGER_16 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_4_i16 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_4_i16 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_4_i16 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_4_i2.c b/libgfortran/generated/minloc0_4_i2.c index c57d5e72643..c33e99cfedb 100644 --- a/libgfortran/generated/minloc0_4_i2.c +++ b/libgfortran/generated/minloc0_4_i2.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ minloc0_4_i2 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_4_i2 (gfc_array_i4 * const restrict retarray, extern void mminloc0_4_i2 (gfc_array_i4 * const restrict, - gfc_array_i2 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i2 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_4_i2); void mminloc0_4_i2 (gfc_array_i4 * const restrict retarray, gfc_array_i2 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_4_i2 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_INTEGER_2 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_4_i2 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_4_i2 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_4_i2 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_4_i4.c b/libgfortran/generated/minloc0_4_i4.c index a8c5a5e8ff2..9d7eda6c839 100644 --- a/libgfortran/generated/minloc0_4_i4.c +++ b/libgfortran/generated/minloc0_4_i4.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ minloc0_4_i4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_4_i4 (gfc_array_i4 * const restrict retarray, extern void mminloc0_4_i4 (gfc_array_i4 * const restrict, - gfc_array_i4 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i4 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_4_i4); void mminloc0_4_i4 (gfc_array_i4 * const restrict retarray, gfc_array_i4 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_4_i4 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_INTEGER_4 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_4_i4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_4_i4 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_4_i4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_4_i8.c b/libgfortran/generated/minloc0_4_i8.c index 61eab8cdd0c..046e040daf0 100644 --- a/libgfortran/generated/minloc0_4_i8.c +++ b/libgfortran/generated/minloc0_4_i8.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ minloc0_4_i8 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_4_i8 (gfc_array_i4 * const restrict retarray, extern void mminloc0_4_i8 (gfc_array_i4 * const restrict, - gfc_array_i8 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i8 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_4_i8); void mminloc0_4_i8 (gfc_array_i4 * const restrict retarray, gfc_array_i8 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_4_i8 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_INTEGER_8 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_4_i8 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_4_i8 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_4_i8 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_4_r10.c b/libgfortran/generated/minloc0_4_r10.c index 20a22520f3f..8f7b9247868 100644 --- a/libgfortran/generated/minloc0_4_r10.c +++ b/libgfortran/generated/minloc0_4_r10.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ minloc0_4_r10 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_4_r10 (gfc_array_i4 * const restrict retarray, extern void mminloc0_4_r10 (gfc_array_i4 * const restrict, - gfc_array_r10 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r10 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_4_r10); void mminloc0_4_r10 (gfc_array_i4 * const restrict retarray, gfc_array_r10 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_4_r10 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_REAL_10 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_4_r10 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_4_r10 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_4_r10 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_4_r16.c b/libgfortran/generated/minloc0_4_r16.c index 83f293c203f..1539192ca15 100644 --- a/libgfortran/generated/minloc0_4_r16.c +++ b/libgfortran/generated/minloc0_4_r16.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ minloc0_4_r16 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_4_r16 (gfc_array_i4 * const restrict retarray, extern void mminloc0_4_r16 (gfc_array_i4 * const restrict, - gfc_array_r16 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r16 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_4_r16); void mminloc0_4_r16 (gfc_array_i4 * const restrict retarray, gfc_array_r16 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_4_r16 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_REAL_16 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_4_r16 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_4_r16 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_4_r16 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_4_r4.c b/libgfortran/generated/minloc0_4_r4.c index 669a8c1c325..86ffdb8c6ef 100644 --- a/libgfortran/generated/minloc0_4_r4.c +++ b/libgfortran/generated/minloc0_4_r4.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ minloc0_4_r4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_4_r4 (gfc_array_i4 * const restrict retarray, extern void mminloc0_4_r4 (gfc_array_i4 * const restrict, - gfc_array_r4 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r4 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_4_r4); void mminloc0_4_r4 (gfc_array_i4 * const restrict retarray, gfc_array_r4 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_4_r4 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_REAL_4 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_4_r4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_4_r4 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_4_r4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_4_r8.c b/libgfortran/generated/minloc0_4_r8.c index fbe9abd83bb..e78cdd898f5 100644 --- a/libgfortran/generated/minloc0_4_r8.c +++ b/libgfortran/generated/minloc0_4_r8.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4) @@ -70,11 +69,22 @@ minloc0_4_r8 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_4_r8 (gfc_array_i4 * const restrict retarray, extern void mminloc0_4_r8 (gfc_array_i4 * const restrict, - gfc_array_r8 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r8 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_4_r8); void mminloc0_4_r8 (gfc_array_i4 * const restrict retarray, gfc_array_r8 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_4_r8 (gfc_array_i4 * const restrict retarray, index_type dstride; GFC_INTEGER_4 *dest; const GFC_REAL_8 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_4_r8 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_4_r8 (gfc_array_i4 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_4_r8 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_8_i1.c b/libgfortran/generated/minloc0_8_i1.c index e1b95ced532..5872d85560d 100644 --- a/libgfortran/generated/minloc0_8_i1.c +++ b/libgfortran/generated/minloc0_8_i1.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ minloc0_8_i1 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_8_i1 (gfc_array_i8 * const restrict retarray, extern void mminloc0_8_i1 (gfc_array_i8 * const restrict, - gfc_array_i1 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i1 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_8_i1); void mminloc0_8_i1 (gfc_array_i8 * const restrict retarray, gfc_array_i1 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_8_i1 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_INTEGER_1 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_8_i1 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_8_i1 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_8_i1 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_8_i16.c b/libgfortran/generated/minloc0_8_i16.c index 390b74a7f75..b56409a050c 100644 --- a/libgfortran/generated/minloc0_8_i16.c +++ b/libgfortran/generated/minloc0_8_i16.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ minloc0_8_i16 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_8_i16 (gfc_array_i8 * const restrict retarray, extern void mminloc0_8_i16 (gfc_array_i8 * const restrict, - gfc_array_i16 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i16 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_8_i16); void mminloc0_8_i16 (gfc_array_i8 * const restrict retarray, gfc_array_i16 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_8_i16 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_INTEGER_16 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_8_i16 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_8_i16 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_8_i16 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_8_i2.c b/libgfortran/generated/minloc0_8_i2.c index c07042989e9..63cd947c42d 100644 --- a/libgfortran/generated/minloc0_8_i2.c +++ b/libgfortran/generated/minloc0_8_i2.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ minloc0_8_i2 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_8_i2 (gfc_array_i8 * const restrict retarray, extern void mminloc0_8_i2 (gfc_array_i8 * const restrict, - gfc_array_i2 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i2 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_8_i2); void mminloc0_8_i2 (gfc_array_i8 * const restrict retarray, gfc_array_i2 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_8_i2 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_INTEGER_2 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_8_i2 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_8_i2 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_8_i2 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_8_i4.c b/libgfortran/generated/minloc0_8_i4.c index 524af749728..5092f89f706 100644 --- a/libgfortran/generated/minloc0_8_i4.c +++ b/libgfortran/generated/minloc0_8_i4.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ minloc0_8_i4 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_8_i4 (gfc_array_i8 * const restrict retarray, extern void mminloc0_8_i4 (gfc_array_i8 * const restrict, - gfc_array_i4 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i4 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_8_i4); void mminloc0_8_i4 (gfc_array_i8 * const restrict retarray, gfc_array_i4 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_8_i4 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_INTEGER_4 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_8_i4 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_8_i4 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_8_i4 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_8_i8.c b/libgfortran/generated/minloc0_8_i8.c index 510973cb35f..e1b99ef9f94 100644 --- a/libgfortran/generated/minloc0_8_i8.c +++ b/libgfortran/generated/minloc0_8_i8.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ minloc0_8_i8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_8_i8 (gfc_array_i8 * const restrict retarray, extern void mminloc0_8_i8 (gfc_array_i8 * const restrict, - gfc_array_i8 * const restrict, gfc_array_l4 * const restrict); + gfc_array_i8 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_8_i8); void mminloc0_8_i8 (gfc_array_i8 * const restrict retarray, gfc_array_i8 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_8_i8 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_INTEGER_8 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_8_i8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_8_i8 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_8_i8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_8_r10.c b/libgfortran/generated/minloc0_8_r10.c index 7e4dcb017e7..600b3aa6af0 100644 --- a/libgfortran/generated/minloc0_8_r10.c +++ b/libgfortran/generated/minloc0_8_r10.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ minloc0_8_r10 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_8_r10 (gfc_array_i8 * const restrict retarray, extern void mminloc0_8_r10 (gfc_array_i8 * const restrict, - gfc_array_r10 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r10 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_8_r10); void mminloc0_8_r10 (gfc_array_i8 * const restrict retarray, gfc_array_r10 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_8_r10 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_REAL_10 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_8_r10 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_8_r10 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_8_r10 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_8_r16.c b/libgfortran/generated/minloc0_8_r16.c index dfb6bd67ead..fa4b5cd1d56 100644 --- a/libgfortran/generated/minloc0_8_r16.c +++ b/libgfortran/generated/minloc0_8_r16.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ minloc0_8_r16 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_8_r16 (gfc_array_i8 * const restrict retarray, extern void mminloc0_8_r16 (gfc_array_i8 * const restrict, - gfc_array_r16 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r16 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_8_r16); void mminloc0_8_r16 (gfc_array_i8 * const restrict retarray, gfc_array_r16 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_8_r16 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_REAL_16 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_8_r16 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_8_r16 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_8_r16 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_8_r4.c b/libgfortran/generated/minloc0_8_r4.c index d10f942e2ab..1347f15c8a8 100644 --- a/libgfortran/generated/minloc0_8_r4.c +++ b/libgfortran/generated/minloc0_8_r4.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ minloc0_8_r4 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_8_r4 (gfc_array_i8 * const restrict retarray, extern void mminloc0_8_r4 (gfc_array_i8 * const restrict, - gfc_array_r4 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r4 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_8_r4); void mminloc0_8_r4 (gfc_array_i8 * const restrict retarray, gfc_array_r4 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_8_r4 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_REAL_4 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_8_r4 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_8_r4 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_8_r4 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc0_8_r8.c b/libgfortran/generated/minloc0_8_r8.c index 781f0caaef4..6a7b2f0d6b0 100644 --- a/libgfortran/generated/minloc0_8_r8.c +++ b/libgfortran/generated/minloc0_8_r8.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_8) @@ -70,11 +69,22 @@ minloc0_8_r8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -148,13 +158,13 @@ minloc0_8_r8 (gfc_array_i8 * const restrict retarray, extern void mminloc0_8_r8 (gfc_array_i8 * const restrict, - gfc_array_r8 * const restrict, gfc_array_l4 * const restrict); + gfc_array_r8 * const restrict, gfc_array_l1 * const restrict); export_proto(mminloc0_8_r8); void mminloc0_8_r8 (gfc_array_i8 * const restrict retarray, gfc_array_r8 * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -163,9 +173,10 @@ mminloc0_8_r8 (gfc_array_i8 * const restrict retarray, index_type dstride; GFC_INTEGER_8 *dest; const GFC_REAL_8 *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -182,19 +193,62 @@ mminloc0_8_r8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); - - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in MINLOC intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -207,17 +261,6 @@ mminloc0_8_r8 (gfc_array_i8 * const restrict retarray, } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -310,11 +353,20 @@ sminloc0_8_r8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/generated/minloc1_16_i1.c b/libgfortran/generated/minloc1_16_i1.c index fa25b3d82d6..f4abfa8f0d1 100644 --- a/libgfortran/generated/minloc1_16_i1.c +++ b/libgfortran/generated/minloc1_16_i1.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ minloc1_16_i1 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_16_i1 (gfc_array_i16 * const restrict retarray, extern void mminloc1_16_i1 (gfc_array_i16 * const restrict, gfc_array_i1 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_16_i1); void mminloc1_16_i1 (gfc_array_i16 * const restrict retarray, gfc_array_i1 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_16_i1 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_INTEGER_1 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_16_i1 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_16_i1 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_16_i1 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_16_i1 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_1 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_16_i1 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_16_i16.c b/libgfortran/generated/minloc1_16_i16.c index 4ea816f6539..40b86eadc6c 100644 --- a/libgfortran/generated/minloc1_16_i16.c +++ b/libgfortran/generated/minloc1_16_i16.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ minloc1_16_i16 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_16_i16 (gfc_array_i16 * const restrict retarray, extern void mminloc1_16_i16 (gfc_array_i16 * const restrict, gfc_array_i16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_16_i16); void mminloc1_16_i16 (gfc_array_i16 * const restrict retarray, gfc_array_i16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_16_i16 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_INTEGER_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_16_i16 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_16_i16 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_16_i16 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_16_i16 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_16_i16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_16_i2.c b/libgfortran/generated/minloc1_16_i2.c index 6251f19d2eb..f7057b2c849 100644 --- a/libgfortran/generated/minloc1_16_i2.c +++ b/libgfortran/generated/minloc1_16_i2.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ minloc1_16_i2 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_16_i2 (gfc_array_i16 * const restrict retarray, extern void mminloc1_16_i2 (gfc_array_i16 * const restrict, gfc_array_i2 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_16_i2); void mminloc1_16_i2 (gfc_array_i16 * const restrict retarray, gfc_array_i2 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_16_i2 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_INTEGER_2 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_16_i2 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_16_i2 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_16_i2 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_16_i2 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_2 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_16_i2 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_16_i4.c b/libgfortran/generated/minloc1_16_i4.c index c70b028122f..3cf6f0de83f 100644 --- a/libgfortran/generated/minloc1_16_i4.c +++ b/libgfortran/generated/minloc1_16_i4.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ minloc1_16_i4 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_16_i4 (gfc_array_i16 * const restrict retarray, extern void mminloc1_16_i4 (gfc_array_i16 * const restrict, gfc_array_i4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_16_i4); void mminloc1_16_i4 (gfc_array_i16 * const restrict retarray, gfc_array_i4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_16_i4 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_INTEGER_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_16_i4 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_16_i4 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_16_i4 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_16_i4 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_16_i4 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_16_i8.c b/libgfortran/generated/minloc1_16_i8.c index 913532711c4..a0838687ba8 100644 --- a/libgfortran/generated/minloc1_16_i8.c +++ b/libgfortran/generated/minloc1_16_i8.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ minloc1_16_i8 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_16_i8 (gfc_array_i16 * const restrict retarray, extern void mminloc1_16_i8 (gfc_array_i16 * const restrict, gfc_array_i8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_16_i8); void mminloc1_16_i8 (gfc_array_i16 * const restrict retarray, gfc_array_i8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_16_i8 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_INTEGER_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_16_i8 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_16_i8 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_16_i8 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_16_i8 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_16_i8 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_16_r10.c b/libgfortran/generated/minloc1_16_r10.c index 77cc6442b99..20b1c5789a7 100644 --- a/libgfortran/generated/minloc1_16_r10.c +++ b/libgfortran/generated/minloc1_16_r10.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ minloc1_16_r10 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_16_r10 (gfc_array_i16 * const restrict retarray, extern void mminloc1_16_r10 (gfc_array_i16 * const restrict, gfc_array_r10 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_16_r10); void mminloc1_16_r10 (gfc_array_i16 * const restrict retarray, gfc_array_r10 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_16_r10 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_REAL_10 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_16_r10 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_16_r10 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_16_r10 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_16_r10 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_10 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_16_r10 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_16_r16.c b/libgfortran/generated/minloc1_16_r16.c index 146a66f29a7..40fcbaea3f9 100644 --- a/libgfortran/generated/minloc1_16_r16.c +++ b/libgfortran/generated/minloc1_16_r16.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ minloc1_16_r16 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_16_r16 (gfc_array_i16 * const restrict retarray, extern void mminloc1_16_r16 (gfc_array_i16 * const restrict, gfc_array_r16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_16_r16); void mminloc1_16_r16 (gfc_array_i16 * const restrict retarray, gfc_array_r16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_16_r16 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_REAL_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_16_r16 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_16_r16 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_16_r16 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_16_r16 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_16_r16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_16_r4.c b/libgfortran/generated/minloc1_16_r4.c index 93bf9e99b4e..76e7efaf0eb 100644 --- a/libgfortran/generated/minloc1_16_r4.c +++ b/libgfortran/generated/minloc1_16_r4.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ minloc1_16_r4 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_16_r4 (gfc_array_i16 * const restrict retarray, extern void mminloc1_16_r4 (gfc_array_i16 * const restrict, gfc_array_r4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_16_r4); void mminloc1_16_r4 (gfc_array_i16 * const restrict retarray, gfc_array_r4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_16_r4 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_REAL_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_16_r4 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_16_r4 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_16_r4 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_16_r4 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_16_r4 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_16_r8.c b/libgfortran/generated/minloc1_16_r8.c index 8313589bd7b..97ca8661dfb 100644 --- a/libgfortran/generated/minloc1_16_r8.c +++ b/libgfortran/generated/minloc1_16_r8.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_16) @@ -117,7 +116,26 @@ minloc1_16_r8 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_16_r8 (gfc_array_i16 * const restrict retarray, extern void mminloc1_16_r8 (gfc_array_i16 * const restrict, gfc_array_r8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_16_r8); void mminloc1_16_r8 (gfc_array_i16 * const restrict retarray, gfc_array_r8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_16_r8 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_REAL_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_16_r8 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_16_r8 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_16_r8 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_16_r8 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_16_r8 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_4_i1.c b/libgfortran/generated/minloc1_4_i1.c index 637a7ec2be6..330c0d9b91a 100644 --- a/libgfortran/generated/minloc1_4_i1.c +++ b/libgfortran/generated/minloc1_4_i1.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ minloc1_4_i1 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_4_i1 (gfc_array_i4 * const restrict retarray, extern void mminloc1_4_i1 (gfc_array_i4 * const restrict, gfc_array_i1 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_4_i1); void mminloc1_4_i1 (gfc_array_i4 * const restrict retarray, gfc_array_i1 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_4_i1 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_INTEGER_1 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_4_i1 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_4_i1 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_4_i1 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_4_i1 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_1 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_4_i1 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_4_i16.c b/libgfortran/generated/minloc1_4_i16.c index abc9d792c90..a142adb9630 100644 --- a/libgfortran/generated/minloc1_4_i16.c +++ b/libgfortran/generated/minloc1_4_i16.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ minloc1_4_i16 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_4_i16 (gfc_array_i4 * const restrict retarray, extern void mminloc1_4_i16 (gfc_array_i4 * const restrict, gfc_array_i16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_4_i16); void mminloc1_4_i16 (gfc_array_i4 * const restrict retarray, gfc_array_i16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_4_i16 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_INTEGER_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_4_i16 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_4_i16 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_4_i16 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_4_i16 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_4_i16 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_4_i2.c b/libgfortran/generated/minloc1_4_i2.c index 0183035d462..d7a92804094 100644 --- a/libgfortran/generated/minloc1_4_i2.c +++ b/libgfortran/generated/minloc1_4_i2.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ minloc1_4_i2 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_4_i2 (gfc_array_i4 * const restrict retarray, extern void mminloc1_4_i2 (gfc_array_i4 * const restrict, gfc_array_i2 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_4_i2); void mminloc1_4_i2 (gfc_array_i4 * const restrict retarray, gfc_array_i2 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_4_i2 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_INTEGER_2 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_4_i2 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_4_i2 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_4_i2 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_4_i2 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_2 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_4_i2 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_4_i4.c b/libgfortran/generated/minloc1_4_i4.c index 8e746c8bc40..c6b12e84e26 100644 --- a/libgfortran/generated/minloc1_4_i4.c +++ b/libgfortran/generated/minloc1_4_i4.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ minloc1_4_i4 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_4_i4 (gfc_array_i4 * const restrict retarray, extern void mminloc1_4_i4 (gfc_array_i4 * const restrict, gfc_array_i4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_4_i4); void mminloc1_4_i4 (gfc_array_i4 * const restrict retarray, gfc_array_i4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_4_i4 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_INTEGER_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_4_i4 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_4_i4 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_4_i4 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_4_i4 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_4_i4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_4_i8.c b/libgfortran/generated/minloc1_4_i8.c index a05e972817b..bac4eb5fc82 100644 --- a/libgfortran/generated/minloc1_4_i8.c +++ b/libgfortran/generated/minloc1_4_i8.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ minloc1_4_i8 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_4_i8 (gfc_array_i4 * const restrict retarray, extern void mminloc1_4_i8 (gfc_array_i4 * const restrict, gfc_array_i8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_4_i8); void mminloc1_4_i8 (gfc_array_i4 * const restrict retarray, gfc_array_i8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_4_i8 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_INTEGER_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_4_i8 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_4_i8 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_4_i8 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_4_i8 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_4_i8 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_4_r10.c b/libgfortran/generated/minloc1_4_r10.c index 2c36814d3fe..0579519ab0d 100644 --- a/libgfortran/generated/minloc1_4_r10.c +++ b/libgfortran/generated/minloc1_4_r10.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ minloc1_4_r10 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_4_r10 (gfc_array_i4 * const restrict retarray, extern void mminloc1_4_r10 (gfc_array_i4 * const restrict, gfc_array_r10 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_4_r10); void mminloc1_4_r10 (gfc_array_i4 * const restrict retarray, gfc_array_r10 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_4_r10 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_REAL_10 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_4_r10 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_4_r10 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_4_r10 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_4_r10 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_10 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_4_r10 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_4_r16.c b/libgfortran/generated/minloc1_4_r16.c index 7258ddaed42..d74d26dc605 100644 --- a/libgfortran/generated/minloc1_4_r16.c +++ b/libgfortran/generated/minloc1_4_r16.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ minloc1_4_r16 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_4_r16 (gfc_array_i4 * const restrict retarray, extern void mminloc1_4_r16 (gfc_array_i4 * const restrict, gfc_array_r16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_4_r16); void mminloc1_4_r16 (gfc_array_i4 * const restrict retarray, gfc_array_r16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_4_r16 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_REAL_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_4_r16 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_4_r16 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_4_r16 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_4_r16 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_4_r16 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_4_r4.c b/libgfortran/generated/minloc1_4_r4.c index b36cee2d1fa..050ed5c3c79 100644 --- a/libgfortran/generated/minloc1_4_r4.c +++ b/libgfortran/generated/minloc1_4_r4.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ minloc1_4_r4 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_4_r4 (gfc_array_i4 * const restrict retarray, extern void mminloc1_4_r4 (gfc_array_i4 * const restrict, gfc_array_r4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_4_r4); void mminloc1_4_r4 (gfc_array_i4 * const restrict retarray, gfc_array_r4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_4_r4 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_REAL_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_4_r4 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_4_r4 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_4_r4 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_4_r4 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_4_r4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_4_r8.c b/libgfortran/generated/minloc1_4_r8.c index a4ad1382b57..483cd19f262 100644 --- a/libgfortran/generated/minloc1_4_r8.c +++ b/libgfortran/generated/minloc1_4_r8.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4) @@ -117,7 +116,26 @@ minloc1_4_r8 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_4_r8 (gfc_array_i4 * const restrict retarray, extern void mminloc1_4_r8 (gfc_array_i4 * const restrict, gfc_array_r8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_4_r8); void mminloc1_4_r8 (gfc_array_i4 * const restrict retarray, gfc_array_r8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_4_r8 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_REAL_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_4_r8 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_4_r8 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_4_r8 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_4_r8 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_4_r8 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_8_i1.c b/libgfortran/generated/minloc1_8_i1.c index 36f49828bae..1fc81d106e2 100644 --- a/libgfortran/generated/minloc1_8_i1.c +++ b/libgfortran/generated/minloc1_8_i1.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ minloc1_8_i1 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_8_i1 (gfc_array_i8 * const restrict retarray, extern void mminloc1_8_i1 (gfc_array_i8 * const restrict, gfc_array_i1 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_8_i1); void mminloc1_8_i1 (gfc_array_i8 * const restrict retarray, gfc_array_i1 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_8_i1 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_INTEGER_1 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_8_i1 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_8_i1 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_8_i1 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_8_i1 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_1 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_8_i1 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_8_i16.c b/libgfortran/generated/minloc1_8_i16.c index 907454dc50a..ecbabc7a981 100644 --- a/libgfortran/generated/minloc1_8_i16.c +++ b/libgfortran/generated/minloc1_8_i16.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ minloc1_8_i16 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_8_i16 (gfc_array_i8 * const restrict retarray, extern void mminloc1_8_i16 (gfc_array_i8 * const restrict, gfc_array_i16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_8_i16); void mminloc1_8_i16 (gfc_array_i8 * const restrict retarray, gfc_array_i16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_8_i16 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_INTEGER_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_8_i16 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_8_i16 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_8_i16 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_8_i16 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_8_i16 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_8_i2.c b/libgfortran/generated/minloc1_8_i2.c index 1d6526ec6b6..2c03443258e 100644 --- a/libgfortran/generated/minloc1_8_i2.c +++ b/libgfortran/generated/minloc1_8_i2.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ minloc1_8_i2 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_8_i2 (gfc_array_i8 * const restrict retarray, extern void mminloc1_8_i2 (gfc_array_i8 * const restrict, gfc_array_i2 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_8_i2); void mminloc1_8_i2 (gfc_array_i8 * const restrict retarray, gfc_array_i2 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_8_i2 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_INTEGER_2 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_8_i2 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_8_i2 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_8_i2 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_8_i2 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_2 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_8_i2 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_8_i4.c b/libgfortran/generated/minloc1_8_i4.c index cebf4527e13..945423748c5 100644 --- a/libgfortran/generated/minloc1_8_i4.c +++ b/libgfortran/generated/minloc1_8_i4.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ minloc1_8_i4 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_8_i4 (gfc_array_i8 * const restrict retarray, extern void mminloc1_8_i4 (gfc_array_i8 * const restrict, gfc_array_i4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_8_i4); void mminloc1_8_i4 (gfc_array_i8 * const restrict retarray, gfc_array_i4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_8_i4 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_INTEGER_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_8_i4 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_8_i4 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_8_i4 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_8_i4 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_8_i4 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_8_i8.c b/libgfortran/generated/minloc1_8_i8.c index 1b822e2c6a5..df801458e09 100644 --- a/libgfortran/generated/minloc1_8_i8.c +++ b/libgfortran/generated/minloc1_8_i8.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ minloc1_8_i8 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_8_i8 (gfc_array_i8 * const restrict retarray, extern void mminloc1_8_i8 (gfc_array_i8 * const restrict, gfc_array_i8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_8_i8); void mminloc1_8_i8 (gfc_array_i8 * const restrict retarray, gfc_array_i8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_8_i8 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_INTEGER_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_8_i8 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_8_i8 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_8_i8 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_8_i8 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_8_i8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_8_r10.c b/libgfortran/generated/minloc1_8_r10.c index f7fb3bf3c13..364bf5c6f04 100644 --- a/libgfortran/generated/minloc1_8_r10.c +++ b/libgfortran/generated/minloc1_8_r10.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ minloc1_8_r10 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_8_r10 (gfc_array_i8 * const restrict retarray, extern void mminloc1_8_r10 (gfc_array_i8 * const restrict, gfc_array_r10 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_8_r10); void mminloc1_8_r10 (gfc_array_i8 * const restrict retarray, gfc_array_r10 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_8_r10 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_REAL_10 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_8_r10 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_8_r10 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_8_r10 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_8_r10 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_10 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_8_r10 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_8_r16.c b/libgfortran/generated/minloc1_8_r16.c index cbba161c84c..b8ad0950ec5 100644 --- a/libgfortran/generated/minloc1_8_r16.c +++ b/libgfortran/generated/minloc1_8_r16.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ minloc1_8_r16 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_8_r16 (gfc_array_i8 * const restrict retarray, extern void mminloc1_8_r16 (gfc_array_i8 * const restrict, gfc_array_r16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_8_r16); void mminloc1_8_r16 (gfc_array_i8 * const restrict retarray, gfc_array_r16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_8_r16 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_REAL_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_8_r16 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_8_r16 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_8_r16 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_8_r16 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_8_r16 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_8_r4.c b/libgfortran/generated/minloc1_8_r4.c index 75081789788..e9df66c669f 100644 --- a/libgfortran/generated/minloc1_8_r4.c +++ b/libgfortran/generated/minloc1_8_r4.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ minloc1_8_r4 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_8_r4 (gfc_array_i8 * const restrict retarray, extern void mminloc1_8_r4 (gfc_array_i8 * const restrict, gfc_array_r4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_8_r4); void mminloc1_8_r4 (gfc_array_i8 * const restrict retarray, gfc_array_r4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_8_r4 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_REAL_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_8_r4 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_8_r4 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_8_r4 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_8_r4 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_8_r4 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minloc1_8_r8.c b/libgfortran/generated/minloc1_8_r8.c index 372ff2135fa..7d2cfff7fed 100644 --- a/libgfortran/generated/minloc1_8_r8.c +++ b/libgfortran/generated/minloc1_8_r8.c @@ -1,5 +1,5 @@ /* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <limits.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_8) @@ -117,7 +116,26 @@ minloc1_8_r8 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -191,14 +209,14 @@ minloc1_8_r8 (gfc_array_i8 * const restrict retarray, extern void mminloc1_8_r8 (gfc_array_i8 * const restrict, gfc_array_r8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminloc1_8_r8); void mminloc1_8_r8 (gfc_array_i8 * const restrict retarray, gfc_array_r8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -207,13 +225,14 @@ mminloc1_8_r8 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_REAL_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -221,13 +240,27 @@ mminloc1_8_r8 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -237,7 +270,7 @@ mminloc1_8_r8 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -279,7 +312,35 @@ mminloc1_8_r8 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -292,22 +353,11 @@ mminloc1_8_r8 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -403,13 +453,21 @@ sminloc1_8_r8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINLOC intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minval_i1.c b/libgfortran/generated/minval_i1.c index 6ac105b2cd9..1789ec9fcfa 100644 --- a/libgfortran/generated/minval_i1.c +++ b/libgfortran/generated/minval_i1.c @@ -1,5 +1,5 @@ /* Implementation of the MINVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) @@ -116,7 +115,26 @@ minval_i1 (gfc_array_i1 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ minval_i1 (gfc_array_i1 * const restrict retarray, extern void mminval_i1 (gfc_array_i1 * const restrict, gfc_array_i1 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminval_i1); void mminval_i1 (gfc_array_i1 * const restrict retarray, gfc_array_i1 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mminval_i1 (gfc_array_i1 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_1 * restrict dest; const GFC_INTEGER_1 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mminval_i1 (gfc_array_i1 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mminval_i1 (gfc_array_i1 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mminval_i1 (gfc_array_i1 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mminval_i1 (gfc_array_i1 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_1 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_1 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ sminval_i1 (gfc_array_i1 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minval_i16.c b/libgfortran/generated/minval_i16.c index 3dd1678b617..2916256e3eb 100644 --- a/libgfortran/generated/minval_i16.c +++ b/libgfortran/generated/minval_i16.c @@ -1,5 +1,5 @@ /* Implementation of the MINVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) @@ -116,7 +115,26 @@ minval_i16 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ minval_i16 (gfc_array_i16 * const restrict retarray, extern void mminval_i16 (gfc_array_i16 * const restrict, gfc_array_i16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminval_i16); void mminval_i16 (gfc_array_i16 * const restrict retarray, gfc_array_i16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mminval_i16 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_INTEGER_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mminval_i16 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mminval_i16 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mminval_i16 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mminval_i16 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ sminval_i16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minval_i2.c b/libgfortran/generated/minval_i2.c index 6d0d3eb8668..73bf18b6167 100644 --- a/libgfortran/generated/minval_i2.c +++ b/libgfortran/generated/minval_i2.c @@ -1,5 +1,5 @@ /* Implementation of the MINVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_2) @@ -116,7 +115,26 @@ minval_i2 (gfc_array_i2 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ minval_i2 (gfc_array_i2 * const restrict retarray, extern void mminval_i2 (gfc_array_i2 * const restrict, gfc_array_i2 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminval_i2); void mminval_i2 (gfc_array_i2 * const restrict retarray, gfc_array_i2 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mminval_i2 (gfc_array_i2 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_2 * restrict dest; const GFC_INTEGER_2 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mminval_i2 (gfc_array_i2 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mminval_i2 (gfc_array_i2 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mminval_i2 (gfc_array_i2 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mminval_i2 (gfc_array_i2 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_2 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_2 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ sminval_i2 (gfc_array_i2 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minval_i4.c b/libgfortran/generated/minval_i4.c index 2d6c1dee749..8d6e52a2ac0 100644 --- a/libgfortran/generated/minval_i4.c +++ b/libgfortran/generated/minval_i4.c @@ -1,5 +1,5 @@ /* Implementation of the MINVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) @@ -116,7 +115,26 @@ minval_i4 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ minval_i4 (gfc_array_i4 * const restrict retarray, extern void mminval_i4 (gfc_array_i4 * const restrict, gfc_array_i4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminval_i4); void mminval_i4 (gfc_array_i4 * const restrict retarray, gfc_array_i4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mminval_i4 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_INTEGER_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mminval_i4 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mminval_i4 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mminval_i4 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mminval_i4 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ sminval_i4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minval_i8.c b/libgfortran/generated/minval_i8.c index 78158ca98b3..22cf462d060 100644 --- a/libgfortran/generated/minval_i8.c +++ b/libgfortran/generated/minval_i8.c @@ -1,5 +1,5 @@ /* Implementation of the MINVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) @@ -116,7 +115,26 @@ minval_i8 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ minval_i8 (gfc_array_i8 * const restrict retarray, extern void mminval_i8 (gfc_array_i8 * const restrict, gfc_array_i8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminval_i8); void mminval_i8 (gfc_array_i8 * const restrict retarray, gfc_array_i8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mminval_i8 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_INTEGER_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mminval_i8 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mminval_i8 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mminval_i8 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mminval_i8 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ sminval_i8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minval_r10.c b/libgfortran/generated/minval_r10.c index fe87af41ac1..f4d467c0d99 100644 --- a/libgfortran/generated/minval_r10.c +++ b/libgfortran/generated/minval_r10.c @@ -1,5 +1,5 @@ /* Implementation of the MINVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_REAL_10) @@ -116,7 +115,26 @@ minval_r10 (gfc_array_r10 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ minval_r10 (gfc_array_r10 * const restrict retarray, extern void mminval_r10 (gfc_array_r10 * const restrict, gfc_array_r10 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminval_r10); void mminval_r10 (gfc_array_r10 * const restrict retarray, gfc_array_r10 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mminval_r10 (gfc_array_r10 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_REAL_10 * restrict dest; const GFC_REAL_10 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mminval_r10 (gfc_array_r10 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mminval_r10 (gfc_array_r10 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mminval_r10 (gfc_array_r10 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mminval_r10 (gfc_array_r10 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_10 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_REAL_10 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ sminval_r10 (gfc_array_r10 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minval_r16.c b/libgfortran/generated/minval_r16.c index 58596b5eea6..7ba19c99c1b 100644 --- a/libgfortran/generated/minval_r16.c +++ b/libgfortran/generated/minval_r16.c @@ -1,5 +1,5 @@ /* Implementation of the MINVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_REAL_16) @@ -116,7 +115,26 @@ minval_r16 (gfc_array_r16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ minval_r16 (gfc_array_r16 * const restrict retarray, extern void mminval_r16 (gfc_array_r16 * const restrict, gfc_array_r16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminval_r16); void mminval_r16 (gfc_array_r16 * const restrict retarray, gfc_array_r16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mminval_r16 (gfc_array_r16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_REAL_16 * restrict dest; const GFC_REAL_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mminval_r16 (gfc_array_r16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mminval_r16 (gfc_array_r16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mminval_r16 (gfc_array_r16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mminval_r16 (gfc_array_r16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_REAL_16 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ sminval_r16 (gfc_array_r16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minval_r4.c b/libgfortran/generated/minval_r4.c index a11549ee974..3b29f2f5d3b 100644 --- a/libgfortran/generated/minval_r4.c +++ b/libgfortran/generated/minval_r4.c @@ -1,5 +1,5 @@ /* Implementation of the MINVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4) @@ -116,7 +115,26 @@ minval_r4 (gfc_array_r4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ minval_r4 (gfc_array_r4 * const restrict retarray, extern void mminval_r4 (gfc_array_r4 * const restrict, gfc_array_r4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminval_r4); void mminval_r4 (gfc_array_r4 * const restrict retarray, gfc_array_r4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mminval_r4 (gfc_array_r4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_REAL_4 * restrict dest; const GFC_REAL_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mminval_r4 (gfc_array_r4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mminval_r4 (gfc_array_r4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mminval_r4 (gfc_array_r4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mminval_r4 (gfc_array_r4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_REAL_4 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ sminval_r4 (gfc_array_r4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/minval_r8.c b/libgfortran/generated/minval_r8.c index 14ca0552bda..adca8b28c7d 100644 --- a/libgfortran/generated/minval_r8.c +++ b/libgfortran/generated/minval_r8.c @@ -1,5 +1,5 @@ /* Implementation of the MINVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8) @@ -116,7 +115,26 @@ minval_r8 (gfc_array_r8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -185,14 +203,14 @@ minval_r8 (gfc_array_r8 * const restrict retarray, extern void mminval_r8 (gfc_array_r8 * const restrict, gfc_array_r8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mminval_r8); void mminval_r8 (gfc_array_r8 * const restrict retarray, gfc_array_r8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -201,13 +219,14 @@ mminval_r8 (gfc_array_r8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_REAL_8 * restrict dest; const GFC_REAL_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -215,13 +234,27 @@ mminval_r8 (gfc_array_r8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -231,7 +264,7 @@ mminval_r8 (gfc_array_r8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -273,7 +306,35 @@ mminval_r8 (gfc_array_r8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -286,22 +347,11 @@ mminval_r8 (gfc_array_r8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_REAL_8 result; src = base; msrc = mbase; @@ -392,13 +442,21 @@ sminval_r8 (gfc_array_r8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in MINVAL intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/misc_specifics.F90 b/libgfortran/generated/misc_specifics.F90 index 29e999f7651..2b14cbf3f3b 100644 --- a/libgfortran/generated/misc_specifics.F90 +++ b/libgfortran/generated/misc_specifics.F90 @@ -1,4 +1,4 @@ -! Copyright 2002 Free Software Foundation, Inc. +! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/generated/nearest_r10.c b/libgfortran/generated/nearest_r10.c index 6db0725e8b4..3995d7cf19c 100644 --- a/libgfortran/generated/nearest_r10.c +++ b/libgfortran/generated/nearest_r10.c @@ -1,5 +1,5 @@ /* Implementation of the NEAREST intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/nearest_r16.c b/libgfortran/generated/nearest_r16.c index a7d846bfccd..15e3f6ac321 100644 --- a/libgfortran/generated/nearest_r16.c +++ b/libgfortran/generated/nearest_r16.c @@ -1,5 +1,5 @@ /* Implementation of the NEAREST intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/nearest_r4.c b/libgfortran/generated/nearest_r4.c index 53a8baaec61..7cce54a38b3 100644 --- a/libgfortran/generated/nearest_r4.c +++ b/libgfortran/generated/nearest_r4.c @@ -1,5 +1,5 @@ /* Implementation of the NEAREST intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/nearest_r8.c b/libgfortran/generated/nearest_r8.c index ef9fca772ae..feb34ece221 100644 --- a/libgfortran/generated/nearest_r8.c +++ b/libgfortran/generated/nearest_r8.c @@ -1,5 +1,5 @@ /* Implementation of the NEAREST intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/pow_c10_i16.c b/libgfortran/generated/pow_c10_i16.c index c62d5f47c22..4ed76b0cccf 100644 --- a/libgfortran/generated/pow_c10_i16.c +++ b/libgfortran/generated/pow_c10_i16.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_c10_i4.c b/libgfortran/generated/pow_c10_i4.c index aca3e7f1ad7..3ffc1491cdf 100644 --- a/libgfortran/generated/pow_c10_i4.c +++ b/libgfortran/generated/pow_c10_i4.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_c10_i8.c b/libgfortran/generated/pow_c10_i8.c index a4a94526db4..3436c80c504 100644 --- a/libgfortran/generated/pow_c10_i8.c +++ b/libgfortran/generated/pow_c10_i8.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_c16_i16.c b/libgfortran/generated/pow_c16_i16.c index d05580f71d6..38dbe9e364b 100644 --- a/libgfortran/generated/pow_c16_i16.c +++ b/libgfortran/generated/pow_c16_i16.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_c16_i4.c b/libgfortran/generated/pow_c16_i4.c index b0576c5ad44..1b778e2c69c 100644 --- a/libgfortran/generated/pow_c16_i4.c +++ b/libgfortran/generated/pow_c16_i4.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_c16_i8.c b/libgfortran/generated/pow_c16_i8.c index 3d991606a40..e5451e19d0c 100644 --- a/libgfortran/generated/pow_c16_i8.c +++ b/libgfortran/generated/pow_c16_i8.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_c4_i16.c b/libgfortran/generated/pow_c4_i16.c index 84309ff63bd..0eb3e96cc4a 100644 --- a/libgfortran/generated/pow_c4_i16.c +++ b/libgfortran/generated/pow_c4_i16.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_c4_i4.c b/libgfortran/generated/pow_c4_i4.c index 35597d0df16..cbdabc2fc05 100644 --- a/libgfortran/generated/pow_c4_i4.c +++ b/libgfortran/generated/pow_c4_i4.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_c4_i8.c b/libgfortran/generated/pow_c4_i8.c index bb113df2b47..46b5627ddd7 100644 --- a/libgfortran/generated/pow_c4_i8.c +++ b/libgfortran/generated/pow_c4_i8.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_c8_i16.c b/libgfortran/generated/pow_c8_i16.c index ee4b68e955f..4ba148ae9bb 100644 --- a/libgfortran/generated/pow_c8_i16.c +++ b/libgfortran/generated/pow_c8_i16.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_c8_i4.c b/libgfortran/generated/pow_c8_i4.c index 30c6007879f..919cba7579b 100644 --- a/libgfortran/generated/pow_c8_i4.c +++ b/libgfortran/generated/pow_c8_i4.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_c8_i8.c b/libgfortran/generated/pow_c8_i8.c index d9b658b4fc4..4f86082c0fc 100644 --- a/libgfortran/generated/pow_c8_i8.c +++ b/libgfortran/generated/pow_c8_i8.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_i16_i16.c b/libgfortran/generated/pow_i16_i16.c index b665f5ea2b9..9bc865f2034 100644 --- a/libgfortran/generated/pow_i16_i16.c +++ b/libgfortran/generated/pow_i16_i16.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_i16_i4.c b/libgfortran/generated/pow_i16_i4.c index 45994a3598e..9b231138b5d 100644 --- a/libgfortran/generated/pow_i16_i4.c +++ b/libgfortran/generated/pow_i16_i4.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_i16_i8.c b/libgfortran/generated/pow_i16_i8.c index 80075051553..40c613de5c7 100644 --- a/libgfortran/generated/pow_i16_i8.c +++ b/libgfortran/generated/pow_i16_i8.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_i4_i16.c b/libgfortran/generated/pow_i4_i16.c index abab476830c..c69b4bace1d 100644 --- a/libgfortran/generated/pow_i4_i16.c +++ b/libgfortran/generated/pow_i4_i16.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_i4_i4.c b/libgfortran/generated/pow_i4_i4.c index e28cf90b116..b3e697c99d3 100644 --- a/libgfortran/generated/pow_i4_i4.c +++ b/libgfortran/generated/pow_i4_i4.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_i4_i8.c b/libgfortran/generated/pow_i4_i8.c index 51d2e14a808..daa7a1d57f9 100644 --- a/libgfortran/generated/pow_i4_i8.c +++ b/libgfortran/generated/pow_i4_i8.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_i8_i16.c b/libgfortran/generated/pow_i8_i16.c index 88713da698e..abba5724efe 100644 --- a/libgfortran/generated/pow_i8_i16.c +++ b/libgfortran/generated/pow_i8_i16.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_i8_i4.c b/libgfortran/generated/pow_i8_i4.c index 6746af33d5b..e4663757da5 100644 --- a/libgfortran/generated/pow_i8_i4.c +++ b/libgfortran/generated/pow_i8_i4.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_i8_i8.c b/libgfortran/generated/pow_i8_i8.c index 3050974036c..28c8ee29494 100644 --- a/libgfortran/generated/pow_i8_i8.c +++ b/libgfortran/generated/pow_i8_i8.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_r10_i16.c b/libgfortran/generated/pow_r10_i16.c index 2377e67ca51..6f9d71ab6b1 100644 --- a/libgfortran/generated/pow_r10_i16.c +++ b/libgfortran/generated/pow_r10_i16.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_r10_i8.c b/libgfortran/generated/pow_r10_i8.c index 5a5ecffdb44..b917960256a 100644 --- a/libgfortran/generated/pow_r10_i8.c +++ b/libgfortran/generated/pow_r10_i8.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_r16_i16.c b/libgfortran/generated/pow_r16_i16.c index 24313c2df2a..fb3e7cd0e2a 100644 --- a/libgfortran/generated/pow_r16_i16.c +++ b/libgfortran/generated/pow_r16_i16.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_r16_i8.c b/libgfortran/generated/pow_r16_i8.c index e7233729b48..8cd5a4f33dd 100644 --- a/libgfortran/generated/pow_r16_i8.c +++ b/libgfortran/generated/pow_r16_i8.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_r4_i16.c b/libgfortran/generated/pow_r4_i16.c index e73794952d7..94de4aa4168 100644 --- a/libgfortran/generated/pow_r4_i16.c +++ b/libgfortran/generated/pow_r4_i16.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_r4_i8.c b/libgfortran/generated/pow_r4_i8.c index 0aae60a7d45..f881d91fbb9 100644 --- a/libgfortran/generated/pow_r4_i8.c +++ b/libgfortran/generated/pow_r4_i8.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_r8_i16.c b/libgfortran/generated/pow_r8_i16.c index e527f3a7a1e..28d8cefbbcf 100644 --- a/libgfortran/generated/pow_r8_i16.c +++ b/libgfortran/generated/pow_r8_i16.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/pow_r8_i8.c b/libgfortran/generated/pow_r8_i8.c index b858fab3a29..cee5107ff1b 100644 --- a/libgfortran/generated/pow_r8_i8.c +++ b/libgfortran/generated/pow_r8_i8.c @@ -1,5 +1,5 @@ /* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" #include "libgfortran.h" + /* Use Binary Method to calculate the powi. This is not an optimal but a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art diff --git a/libgfortran/generated/product_c10.c b/libgfortran/generated/product_c10.c index 0d73a9b799c..def678ab953 100644 --- a/libgfortran/generated/product_c10.c +++ b/libgfortran/generated/product_c10.c @@ -1,5 +1,5 @@ /* Implementation of the PRODUCT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_COMPLEX_10) && defined (HAVE_GFC_COMPLEX_10) @@ -116,7 +115,26 @@ product_c10 (gfc_array_c10 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ product_c10 (gfc_array_c10 * const restrict retarray, extern void mproduct_c10 (gfc_array_c10 * const restrict, gfc_array_c10 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mproduct_c10); void mproduct_c10 (gfc_array_c10 * const restrict retarray, gfc_array_c10 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ mproduct_c10 (gfc_array_c10 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_COMPLEX_10 * restrict dest; const GFC_COMPLEX_10 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ mproduct_c10 (gfc_array_c10 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ mproduct_c10 (gfc_array_c10 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ mproduct_c10 (gfc_array_c10 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ mproduct_c10 (gfc_array_c10 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_COMPLEX_10 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_COMPLEX_10 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ sproduct_c10 (gfc_array_c10 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in PRODUCT intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/product_c16.c b/libgfortran/generated/product_c16.c index a5c8bd07e74..d8750aef5b0 100644 --- a/libgfortran/generated/product_c16.c +++ b/libgfortran/generated/product_c16.c @@ -1,5 +1,5 @@ /* Implementation of the PRODUCT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_COMPLEX_16) && defined (HAVE_GFC_COMPLEX_16) @@ -116,7 +115,26 @@ product_c16 (gfc_array_c16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ product_c16 (gfc_array_c16 * const restrict retarray, extern void mproduct_c16 (gfc_array_c16 * const restrict, gfc_array_c16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mproduct_c16); void mproduct_c16 (gfc_array_c16 * const restrict retarray, gfc_array_c16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ mproduct_c16 (gfc_array_c16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_COMPLEX_16 * restrict dest; const GFC_COMPLEX_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ mproduct_c16 (gfc_array_c16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ mproduct_c16 (gfc_array_c16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ mproduct_c16 (gfc_array_c16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ mproduct_c16 (gfc_array_c16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_COMPLEX_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_COMPLEX_16 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ sproduct_c16 (gfc_array_c16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in PRODUCT intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/product_c4.c b/libgfortran/generated/product_c4.c index 45a62c9cfb9..7cac33fc8c6 100644 --- a/libgfortran/generated/product_c4.c +++ b/libgfortran/generated/product_c4.c @@ -1,5 +1,5 @@ /* Implementation of the PRODUCT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_COMPLEX_4) && defined (HAVE_GFC_COMPLEX_4) @@ -116,7 +115,26 @@ product_c4 (gfc_array_c4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ product_c4 (gfc_array_c4 * const restrict retarray, extern void mproduct_c4 (gfc_array_c4 * const restrict, gfc_array_c4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mproduct_c4); void mproduct_c4 (gfc_array_c4 * const restrict retarray, gfc_array_c4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ mproduct_c4 (gfc_array_c4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_COMPLEX_4 * restrict dest; const GFC_COMPLEX_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ mproduct_c4 (gfc_array_c4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ mproduct_c4 (gfc_array_c4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ mproduct_c4 (gfc_array_c4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ mproduct_c4 (gfc_array_c4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_COMPLEX_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_COMPLEX_4 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ sproduct_c4 (gfc_array_c4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in PRODUCT intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/product_c8.c b/libgfortran/generated/product_c8.c index 69bcb87c399..e4f0f6bfd30 100644 --- a/libgfortran/generated/product_c8.c +++ b/libgfortran/generated/product_c8.c @@ -1,5 +1,5 @@ /* Implementation of the PRODUCT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_COMPLEX_8) && defined (HAVE_GFC_COMPLEX_8) @@ -116,7 +115,26 @@ product_c8 (gfc_array_c8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ product_c8 (gfc_array_c8 * const restrict retarray, extern void mproduct_c8 (gfc_array_c8 * const restrict, gfc_array_c8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mproduct_c8); void mproduct_c8 (gfc_array_c8 * const restrict retarray, gfc_array_c8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ mproduct_c8 (gfc_array_c8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_COMPLEX_8 * restrict dest; const GFC_COMPLEX_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ mproduct_c8 (gfc_array_c8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ mproduct_c8 (gfc_array_c8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ mproduct_c8 (gfc_array_c8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ mproduct_c8 (gfc_array_c8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_COMPLEX_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_COMPLEX_8 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ sproduct_c8 (gfc_array_c8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in PRODUCT intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/product_i1.c b/libgfortran/generated/product_i1.c index 76427e4cbb7..5a428cad202 100644 --- a/libgfortran/generated/product_i1.c +++ b/libgfortran/generated/product_i1.c @@ -1,5 +1,5 @@ /* Implementation of the PRODUCT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) @@ -116,7 +115,26 @@ product_i1 (gfc_array_i1 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ product_i1 (gfc_array_i1 * const restrict retarray, extern void mproduct_i1 (gfc_array_i1 * const restrict, gfc_array_i1 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mproduct_i1); void mproduct_i1 (gfc_array_i1 * const restrict retarray, gfc_array_i1 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ mproduct_i1 (gfc_array_i1 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_1 * restrict dest; const GFC_INTEGER_1 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ mproduct_i1 (gfc_array_i1 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ mproduct_i1 (gfc_array_i1 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ mproduct_i1 (gfc_array_i1 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ mproduct_i1 (gfc_array_i1 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_1 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_1 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ sproduct_i1 (gfc_array_i1 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in PRODUCT intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/product_i16.c b/libgfortran/generated/product_i16.c index 7b735783094..a1593a4f66a 100644 --- a/libgfortran/generated/product_i16.c +++ b/libgfortran/generated/product_i16.c @@ -1,5 +1,5 @@ /* Implementation of the PRODUCT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) @@ -116,7 +115,26 @@ product_i16 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ product_i16 (gfc_array_i16 * const restrict retarray, extern void mproduct_i16 (gfc_array_i16 * const restrict, gfc_array_i16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mproduct_i16); void mproduct_i16 (gfc_array_i16 * const restrict retarray, gfc_array_i16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ mproduct_i16 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_INTEGER_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ mproduct_i16 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ mproduct_i16 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ mproduct_i16 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ mproduct_i16 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ sproduct_i16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in PRODUCT intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/product_i2.c b/libgfortran/generated/product_i2.c index bdb51a65c52..16793f89579 100644 --- a/libgfortran/generated/product_i2.c +++ b/libgfortran/generated/product_i2.c @@ -1,5 +1,5 @@ /* Implementation of the PRODUCT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_2) @@ -116,7 +115,26 @@ product_i2 (gfc_array_i2 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ product_i2 (gfc_array_i2 * const restrict retarray, extern void mproduct_i2 (gfc_array_i2 * const restrict, gfc_array_i2 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mproduct_i2); void mproduct_i2 (gfc_array_i2 * const restrict retarray, gfc_array_i2 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ mproduct_i2 (gfc_array_i2 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_2 * restrict dest; const GFC_INTEGER_2 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ mproduct_i2 (gfc_array_i2 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ mproduct_i2 (gfc_array_i2 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ mproduct_i2 (gfc_array_i2 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ mproduct_i2 (gfc_array_i2 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_2 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_2 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ sproduct_i2 (gfc_array_i2 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in PRODUCT intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/product_i4.c b/libgfortran/generated/product_i4.c index 72d0e1afbad..cbace913d6a 100644 --- a/libgfortran/generated/product_i4.c +++ b/libgfortran/generated/product_i4.c @@ -1,5 +1,5 @@ /* Implementation of the PRODUCT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) @@ -116,7 +115,26 @@ product_i4 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ product_i4 (gfc_array_i4 * const restrict retarray, extern void mproduct_i4 (gfc_array_i4 * const restrict, gfc_array_i4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mproduct_i4); void mproduct_i4 (gfc_array_i4 * const restrict retarray, gfc_array_i4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ mproduct_i4 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_INTEGER_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ mproduct_i4 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ mproduct_i4 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ mproduct_i4 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ mproduct_i4 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ sproduct_i4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in PRODUCT intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/product_i8.c b/libgfortran/generated/product_i8.c index d1ae82e4303..f1fc56718a8 100644 --- a/libgfortran/generated/product_i8.c +++ b/libgfortran/generated/product_i8.c @@ -1,5 +1,5 @@ /* Implementation of the PRODUCT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) @@ -116,7 +115,26 @@ product_i8 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ product_i8 (gfc_array_i8 * const restrict retarray, extern void mproduct_i8 (gfc_array_i8 * const restrict, gfc_array_i8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mproduct_i8); void mproduct_i8 (gfc_array_i8 * const restrict retarray, gfc_array_i8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ mproduct_i8 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_INTEGER_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ mproduct_i8 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ mproduct_i8 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ mproduct_i8 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ mproduct_i8 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ sproduct_i8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in PRODUCT intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/product_r10.c b/libgfortran/generated/product_r10.c index f19b67ba949..4b7c5803096 100644 --- a/libgfortran/generated/product_r10.c +++ b/libgfortran/generated/product_r10.c @@ -1,5 +1,5 @@ /* Implementation of the PRODUCT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_REAL_10) @@ -116,7 +115,26 @@ product_r10 (gfc_array_r10 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ product_r10 (gfc_array_r10 * const restrict retarray, extern void mproduct_r10 (gfc_array_r10 * const restrict, gfc_array_r10 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mproduct_r10); void mproduct_r10 (gfc_array_r10 * const restrict retarray, gfc_array_r10 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ mproduct_r10 (gfc_array_r10 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_REAL_10 * restrict dest; const GFC_REAL_10 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ mproduct_r10 (gfc_array_r10 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ mproduct_r10 (gfc_array_r10 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ mproduct_r10 (gfc_array_r10 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ mproduct_r10 (gfc_array_r10 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_10 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_REAL_10 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ sproduct_r10 (gfc_array_r10 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in PRODUCT intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/product_r16.c b/libgfortran/generated/product_r16.c index 3d0a76a4ade..b18155bd73c 100644 --- a/libgfortran/generated/product_r16.c +++ b/libgfortran/generated/product_r16.c @@ -1,5 +1,5 @@ /* Implementation of the PRODUCT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_REAL_16) @@ -116,7 +115,26 @@ product_r16 (gfc_array_r16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ product_r16 (gfc_array_r16 * const restrict retarray, extern void mproduct_r16 (gfc_array_r16 * const restrict, gfc_array_r16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mproduct_r16); void mproduct_r16 (gfc_array_r16 * const restrict retarray, gfc_array_r16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ mproduct_r16 (gfc_array_r16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_REAL_16 * restrict dest; const GFC_REAL_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ mproduct_r16 (gfc_array_r16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ mproduct_r16 (gfc_array_r16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ mproduct_r16 (gfc_array_r16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ mproduct_r16 (gfc_array_r16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_REAL_16 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ sproduct_r16 (gfc_array_r16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in PRODUCT intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/product_r4.c b/libgfortran/generated/product_r4.c index 069b0d0c0e7..754cac2bfb1 100644 --- a/libgfortran/generated/product_r4.c +++ b/libgfortran/generated/product_r4.c @@ -1,5 +1,5 @@ /* Implementation of the PRODUCT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4) @@ -116,7 +115,26 @@ product_r4 (gfc_array_r4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ product_r4 (gfc_array_r4 * const restrict retarray, extern void mproduct_r4 (gfc_array_r4 * const restrict, gfc_array_r4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mproduct_r4); void mproduct_r4 (gfc_array_r4 * const restrict retarray, gfc_array_r4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ mproduct_r4 (gfc_array_r4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_REAL_4 * restrict dest; const GFC_REAL_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ mproduct_r4 (gfc_array_r4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ mproduct_r4 (gfc_array_r4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ mproduct_r4 (gfc_array_r4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ mproduct_r4 (gfc_array_r4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_REAL_4 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ sproduct_r4 (gfc_array_r4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in PRODUCT intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/product_r8.c b/libgfortran/generated/product_r8.c index e9cfae39782..5f68856a8b0 100644 --- a/libgfortran/generated/product_r8.c +++ b/libgfortran/generated/product_r8.c @@ -1,5 +1,5 @@ /* Implementation of the PRODUCT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8) @@ -116,7 +115,26 @@ product_r8 (gfc_array_r8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ product_r8 (gfc_array_r8 * const restrict retarray, extern void mproduct_r8 (gfc_array_r8 * const restrict, gfc_array_r8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(mproduct_r8); void mproduct_r8 (gfc_array_r8 * const restrict retarray, gfc_array_r8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ mproduct_r8 (gfc_array_r8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_REAL_8 * restrict dest; const GFC_REAL_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ mproduct_r8 (gfc_array_r8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ mproduct_r8 (gfc_array_r8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ mproduct_r8 (gfc_array_r8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ mproduct_r8 (gfc_array_r8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_REAL_8 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ sproduct_r8 (gfc_array_r8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in PRODUCT intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/reshape_c10.c b/libgfortran/generated/reshape_c10.c index 1440e75b116..b9eb754481a 100644 --- a/libgfortran/generated/reshape_c10.c +++ b/libgfortran/generated/reshape_c10.c @@ -1,5 +1,5 @@ /* Implementation of the RESHAPE - Copyright 2002, 2006 Free Software Foundation, Inc. + Copyright 2002, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_COMPLEX_10) diff --git a/libgfortran/generated/reshape_c16.c b/libgfortran/generated/reshape_c16.c index 2ab6111cf3c..c9cdaa931a9 100644 --- a/libgfortran/generated/reshape_c16.c +++ b/libgfortran/generated/reshape_c16.c @@ -1,5 +1,5 @@ /* Implementation of the RESHAPE - Copyright 2002, 2006 Free Software Foundation, Inc. + Copyright 2002, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_COMPLEX_16) diff --git a/libgfortran/generated/reshape_c4.c b/libgfortran/generated/reshape_c4.c index 66b162218f6..3d1eac24824 100644 --- a/libgfortran/generated/reshape_c4.c +++ b/libgfortran/generated/reshape_c4.c @@ -1,5 +1,5 @@ /* Implementation of the RESHAPE - Copyright 2002, 2006 Free Software Foundation, Inc. + Copyright 2002, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_COMPLEX_4) diff --git a/libgfortran/generated/reshape_c8.c b/libgfortran/generated/reshape_c8.c index 89316539443..4a4a3e68161 100644 --- a/libgfortran/generated/reshape_c8.c +++ b/libgfortran/generated/reshape_c8.c @@ -1,5 +1,5 @@ /* Implementation of the RESHAPE - Copyright 2002, 2006 Free Software Foundation, Inc. + Copyright 2002, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_COMPLEX_8) diff --git a/libgfortran/generated/reshape_i16.c b/libgfortran/generated/reshape_i16.c index c8777cfc09b..9e58dcc3d5a 100644 --- a/libgfortran/generated/reshape_i16.c +++ b/libgfortran/generated/reshape_i16.c @@ -1,5 +1,5 @@ /* Implementation of the RESHAPE - Copyright 2002, 2006 Free Software Foundation, Inc. + Copyright 2002, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_16) diff --git a/libgfortran/generated/reshape_i4.c b/libgfortran/generated/reshape_i4.c index f51b73096d8..b8114123a8a 100644 --- a/libgfortran/generated/reshape_i4.c +++ b/libgfortran/generated/reshape_i4.c @@ -1,5 +1,5 @@ /* Implementation of the RESHAPE - Copyright 2002, 2006 Free Software Foundation, Inc. + Copyright 2002, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_4) diff --git a/libgfortran/generated/reshape_i8.c b/libgfortran/generated/reshape_i8.c index 463919db188..ffec9bb8d6e 100644 --- a/libgfortran/generated/reshape_i8.c +++ b/libgfortran/generated/reshape_i8.c @@ -1,5 +1,5 @@ /* Implementation of the RESHAPE - Copyright 2002, 2006 Free Software Foundation, Inc. + Copyright 2002, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_8) diff --git a/libgfortran/generated/reshape_r10.c b/libgfortran/generated/reshape_r10.c index c3d414320ad..8bca529b7c9 100644 --- a/libgfortran/generated/reshape_r10.c +++ b/libgfortran/generated/reshape_r10.c @@ -1,5 +1,5 @@ /* Implementation of the RESHAPE - Copyright 2002, 2006 Free Software Foundation, Inc. + Copyright 2002, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_REAL_10) diff --git a/libgfortran/generated/reshape_r16.c b/libgfortran/generated/reshape_r16.c index a8ba40b421b..cd5527297f8 100644 --- a/libgfortran/generated/reshape_r16.c +++ b/libgfortran/generated/reshape_r16.c @@ -1,5 +1,5 @@ /* Implementation of the RESHAPE - Copyright 2002, 2006 Free Software Foundation, Inc. + Copyright 2002, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_REAL_16) diff --git a/libgfortran/generated/reshape_r4.c b/libgfortran/generated/reshape_r4.c index b03900ae29f..ace0f4e7728 100644 --- a/libgfortran/generated/reshape_r4.c +++ b/libgfortran/generated/reshape_r4.c @@ -1,5 +1,5 @@ /* Implementation of the RESHAPE - Copyright 2002, 2006 Free Software Foundation, Inc. + Copyright 2002, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_REAL_4) diff --git a/libgfortran/generated/reshape_r8.c b/libgfortran/generated/reshape_r8.c index 2a3e7338018..8d0fd6619c5 100644 --- a/libgfortran/generated/reshape_r8.c +++ b/libgfortran/generated/reshape_r8.c @@ -1,5 +1,5 @@ /* Implementation of the RESHAPE - Copyright 2002, 2006 Free Software Foundation, Inc. + Copyright 2002, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_REAL_8) diff --git a/libgfortran/generated/rrspacing_r10.c b/libgfortran/generated/rrspacing_r10.c index 019c40fdcf0..11b634f5376 100644 --- a/libgfortran/generated/rrspacing_r10.c +++ b/libgfortran/generated/rrspacing_r10.c @@ -1,5 +1,5 @@ /* Implementation of the RRSPACING intrinsic - Copyright 2006 Free Software Foundation, Inc. + Copyright 2006, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargl@gcc.gnu.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/rrspacing_r16.c b/libgfortran/generated/rrspacing_r16.c index 352d303eac7..155b1c34c98 100644 --- a/libgfortran/generated/rrspacing_r16.c +++ b/libgfortran/generated/rrspacing_r16.c @@ -1,5 +1,5 @@ /* Implementation of the RRSPACING intrinsic - Copyright 2006 Free Software Foundation, Inc. + Copyright 2006, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargl@gcc.gnu.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/rrspacing_r4.c b/libgfortran/generated/rrspacing_r4.c index 22e844f65b3..578aae17aa5 100644 --- a/libgfortran/generated/rrspacing_r4.c +++ b/libgfortran/generated/rrspacing_r4.c @@ -1,5 +1,5 @@ /* Implementation of the RRSPACING intrinsic - Copyright 2006 Free Software Foundation, Inc. + Copyright 2006, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargl@gcc.gnu.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/rrspacing_r8.c b/libgfortran/generated/rrspacing_r8.c index f2b93bf67d5..e0b2ccc354c 100644 --- a/libgfortran/generated/rrspacing_r8.c +++ b/libgfortran/generated/rrspacing_r8.c @@ -1,5 +1,5 @@ /* Implementation of the RRSPACING intrinsic - Copyright 2006 Free Software Foundation, Inc. + Copyright 2006, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargl@gcc.gnu.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/set_exponent_r10.c b/libgfortran/generated/set_exponent_r10.c index 1613baa844a..5dd39e85698 100644 --- a/libgfortran/generated/set_exponent_r10.c +++ b/libgfortran/generated/set_exponent_r10.c @@ -1,5 +1,5 @@ /* Implementation of the SET_EXPONENT intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/set_exponent_r16.c b/libgfortran/generated/set_exponent_r16.c index 498ab4baf09..b0e52317057 100644 --- a/libgfortran/generated/set_exponent_r16.c +++ b/libgfortran/generated/set_exponent_r16.c @@ -1,5 +1,5 @@ /* Implementation of the SET_EXPONENT intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/set_exponent_r4.c b/libgfortran/generated/set_exponent_r4.c index cb0f6e11321..7f40464dfb0 100644 --- a/libgfortran/generated/set_exponent_r4.c +++ b/libgfortran/generated/set_exponent_r4.c @@ -1,5 +1,5 @@ /* Implementation of the SET_EXPONENT intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/set_exponent_r8.c b/libgfortran/generated/set_exponent_r8.c index e616e95f765..4c4bc8f8469 100644 --- a/libgfortran/generated/set_exponent_r8.c +++ b/libgfortran/generated/set_exponent_r8.c @@ -1,5 +1,5 @@ /* Implementation of the SET_EXPONENT intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/shape_i16.c b/libgfortran/generated/shape_i16.c index 58b59098cae..0ab2654bd8c 100644 --- a/libgfortran/generated/shape_i16.c +++ b/libgfortran/generated/shape_i16.c @@ -1,5 +1,5 @@ /* Implementation of the SHAPE intrinsic - Copyright 2002, 2006 Free Software Foundation, Inc. + Copyright 2002, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_16) @@ -45,13 +45,17 @@ shape_16 (gfc_array_i16 * const restrict ret, { int n; index_type stride; + index_type extent; stride = ret->dim[0].stride; + if (ret->dim[0].ubound < ret->dim[0].lbound) + return; + for (n = 0; n < GFC_DESCRIPTOR_RANK (array); n++) { - ret->data[n * stride] = - array->dim[n].ubound + 1 - array->dim[n].lbound; + extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + ret->data[n * stride] = extent > 0 ? extent : 0 ; } } diff --git a/libgfortran/generated/shape_i4.c b/libgfortran/generated/shape_i4.c index 5a7aa03bced..64a6fcdb994 100644 --- a/libgfortran/generated/shape_i4.c +++ b/libgfortran/generated/shape_i4.c @@ -1,5 +1,5 @@ /* Implementation of the SHAPE intrinsic - Copyright 2002, 2006 Free Software Foundation, Inc. + Copyright 2002, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_4) @@ -45,13 +45,17 @@ shape_4 (gfc_array_i4 * const restrict ret, { int n; index_type stride; + index_type extent; stride = ret->dim[0].stride; + if (ret->dim[0].ubound < ret->dim[0].lbound) + return; + for (n = 0; n < GFC_DESCRIPTOR_RANK (array); n++) { - ret->data[n * stride] = - array->dim[n].ubound + 1 - array->dim[n].lbound; + extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + ret->data[n * stride] = extent > 0 ? extent : 0 ; } } diff --git a/libgfortran/generated/shape_i8.c b/libgfortran/generated/shape_i8.c index e3e2bf538b9..80bef318b81 100644 --- a/libgfortran/generated/shape_i8.c +++ b/libgfortran/generated/shape_i8.c @@ -1,5 +1,5 @@ /* Implementation of the SHAPE intrinsic - Copyright 2002, 2006 Free Software Foundation, Inc. + Copyright 2002, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" + #if defined (HAVE_GFC_INTEGER_8) @@ -45,13 +45,17 @@ shape_8 (gfc_array_i8 * const restrict ret, { int n; index_type stride; + index_type extent; stride = ret->dim[0].stride; + if (ret->dim[0].ubound < ret->dim[0].lbound) + return; + for (n = 0; n < GFC_DESCRIPTOR_RANK (array); n++) { - ret->data[n * stride] = - array->dim[n].ubound + 1 - array->dim[n].lbound; + extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + ret->data[n * stride] = extent > 0 ? extent : 0 ; } } diff --git a/libgfortran/generated/spacing_r10.c b/libgfortran/generated/spacing_r10.c index c9317dc027b..2868e852fe8 100644 --- a/libgfortran/generated/spacing_r10.c +++ b/libgfortran/generated/spacing_r10.c @@ -1,5 +1,5 @@ /* Implementation of the SPACING intrinsic - Copyright 2006 Free Software Foundation, Inc. + Copyright 2006, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargl@gcc.gnu.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/spacing_r16.c b/libgfortran/generated/spacing_r16.c index 5919f75a90e..ae44823d449 100644 --- a/libgfortran/generated/spacing_r16.c +++ b/libgfortran/generated/spacing_r16.c @@ -1,5 +1,5 @@ /* Implementation of the SPACING intrinsic - Copyright 2006 Free Software Foundation, Inc. + Copyright 2006, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargl@gcc.gnu.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/spacing_r4.c b/libgfortran/generated/spacing_r4.c index f8617a9628d..648d433229f 100644 --- a/libgfortran/generated/spacing_r4.c +++ b/libgfortran/generated/spacing_r4.c @@ -1,5 +1,5 @@ /* Implementation of the SPACING intrinsic - Copyright 2006 Free Software Foundation, Inc. + Copyright 2006, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargl@gcc.gnu.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/spacing_r8.c b/libgfortran/generated/spacing_r8.c index 4de8ce81364..d9ead8c8c57 100644 --- a/libgfortran/generated/spacing_r8.c +++ b/libgfortran/generated/spacing_r8.c @@ -1,5 +1,5 @@ /* Implementation of the SPACING intrinsic - Copyright 2006 Free Software Foundation, Inc. + Copyright 2006, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargl@gcc.gnu.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" diff --git a/libgfortran/generated/sum_c10.c b/libgfortran/generated/sum_c10.c index 96b878b7fcd..e495a0ba497 100644 --- a/libgfortran/generated/sum_c10.c +++ b/libgfortran/generated/sum_c10.c @@ -1,5 +1,5 @@ /* Implementation of the SUM intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_COMPLEX_10) && defined (HAVE_GFC_COMPLEX_10) @@ -116,7 +115,26 @@ sum_c10 (gfc_array_c10 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ sum_c10 (gfc_array_c10 * const restrict retarray, extern void msum_c10 (gfc_array_c10 * const restrict, gfc_array_c10 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(msum_c10); void msum_c10 (gfc_array_c10 * const restrict retarray, gfc_array_c10 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ msum_c10 (gfc_array_c10 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_COMPLEX_10 * restrict dest; const GFC_COMPLEX_10 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ msum_c10 (gfc_array_c10 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ msum_c10 (gfc_array_c10 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ msum_c10 (gfc_array_c10 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ msum_c10 (gfc_array_c10 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_COMPLEX_10 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_COMPLEX_10 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ ssum_c10 (gfc_array_c10 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in SUM intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/sum_c16.c b/libgfortran/generated/sum_c16.c index a99d4f65b62..c73083a930c 100644 --- a/libgfortran/generated/sum_c16.c +++ b/libgfortran/generated/sum_c16.c @@ -1,5 +1,5 @@ /* Implementation of the SUM intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_COMPLEX_16) && defined (HAVE_GFC_COMPLEX_16) @@ -116,7 +115,26 @@ sum_c16 (gfc_array_c16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ sum_c16 (gfc_array_c16 * const restrict retarray, extern void msum_c16 (gfc_array_c16 * const restrict, gfc_array_c16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(msum_c16); void msum_c16 (gfc_array_c16 * const restrict retarray, gfc_array_c16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ msum_c16 (gfc_array_c16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_COMPLEX_16 * restrict dest; const GFC_COMPLEX_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ msum_c16 (gfc_array_c16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ msum_c16 (gfc_array_c16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ msum_c16 (gfc_array_c16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ msum_c16 (gfc_array_c16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_COMPLEX_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_COMPLEX_16 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ ssum_c16 (gfc_array_c16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in SUM intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/sum_c4.c b/libgfortran/generated/sum_c4.c index 83979fbdf21..6f32327ad0b 100644 --- a/libgfortran/generated/sum_c4.c +++ b/libgfortran/generated/sum_c4.c @@ -1,5 +1,5 @@ /* Implementation of the SUM intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_COMPLEX_4) && defined (HAVE_GFC_COMPLEX_4) @@ -116,7 +115,26 @@ sum_c4 (gfc_array_c4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ sum_c4 (gfc_array_c4 * const restrict retarray, extern void msum_c4 (gfc_array_c4 * const restrict, gfc_array_c4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(msum_c4); void msum_c4 (gfc_array_c4 * const restrict retarray, gfc_array_c4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ msum_c4 (gfc_array_c4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_COMPLEX_4 * restrict dest; const GFC_COMPLEX_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ msum_c4 (gfc_array_c4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ msum_c4 (gfc_array_c4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ msum_c4 (gfc_array_c4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ msum_c4 (gfc_array_c4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_COMPLEX_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_COMPLEX_4 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ ssum_c4 (gfc_array_c4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in SUM intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/sum_c8.c b/libgfortran/generated/sum_c8.c index d82092a1b6b..80db1101cfe 100644 --- a/libgfortran/generated/sum_c8.c +++ b/libgfortran/generated/sum_c8.c @@ -1,5 +1,5 @@ /* Implementation of the SUM intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_COMPLEX_8) && defined (HAVE_GFC_COMPLEX_8) @@ -116,7 +115,26 @@ sum_c8 (gfc_array_c8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ sum_c8 (gfc_array_c8 * const restrict retarray, extern void msum_c8 (gfc_array_c8 * const restrict, gfc_array_c8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(msum_c8); void msum_c8 (gfc_array_c8 * const restrict retarray, gfc_array_c8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ msum_c8 (gfc_array_c8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_COMPLEX_8 * restrict dest; const GFC_COMPLEX_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ msum_c8 (gfc_array_c8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ msum_c8 (gfc_array_c8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ msum_c8 (gfc_array_c8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ msum_c8 (gfc_array_c8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_COMPLEX_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_COMPLEX_8 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ ssum_c8 (gfc_array_c8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in SUM intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/sum_i1.c b/libgfortran/generated/sum_i1.c index 87205b8f716..c652712d4e7 100644 --- a/libgfortran/generated/sum_i1.c +++ b/libgfortran/generated/sum_i1.c @@ -1,5 +1,5 @@ /* Implementation of the SUM intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) @@ -116,7 +115,26 @@ sum_i1 (gfc_array_i1 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ sum_i1 (gfc_array_i1 * const restrict retarray, extern void msum_i1 (gfc_array_i1 * const restrict, gfc_array_i1 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(msum_i1); void msum_i1 (gfc_array_i1 * const restrict retarray, gfc_array_i1 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ msum_i1 (gfc_array_i1 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_1 * restrict dest; const GFC_INTEGER_1 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ msum_i1 (gfc_array_i1 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ msum_i1 (gfc_array_i1 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ msum_i1 (gfc_array_i1 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ msum_i1 (gfc_array_i1 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_1 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_1 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ ssum_i1 (gfc_array_i1 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in SUM intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/sum_i16.c b/libgfortran/generated/sum_i16.c index 83857734a00..43a29a2956f 100644 --- a/libgfortran/generated/sum_i16.c +++ b/libgfortran/generated/sum_i16.c @@ -1,5 +1,5 @@ /* Implementation of the SUM intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) @@ -116,7 +115,26 @@ sum_i16 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ sum_i16 (gfc_array_i16 * const restrict retarray, extern void msum_i16 (gfc_array_i16 * const restrict, gfc_array_i16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(msum_i16); void msum_i16 (gfc_array_i16 * const restrict retarray, gfc_array_i16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ msum_i16 (gfc_array_i16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_16 * restrict dest; const GFC_INTEGER_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ msum_i16 (gfc_array_i16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ msum_i16 (gfc_array_i16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ msum_i16 (gfc_array_i16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ msum_i16 (gfc_array_i16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_16 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ ssum_i16 (gfc_array_i16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in SUM intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/sum_i2.c b/libgfortran/generated/sum_i2.c index c4452c3ce9d..6c6fcc1116a 100644 --- a/libgfortran/generated/sum_i2.c +++ b/libgfortran/generated/sum_i2.c @@ -1,5 +1,5 @@ /* Implementation of the SUM intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_2) @@ -116,7 +115,26 @@ sum_i2 (gfc_array_i2 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ sum_i2 (gfc_array_i2 * const restrict retarray, extern void msum_i2 (gfc_array_i2 * const restrict, gfc_array_i2 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(msum_i2); void msum_i2 (gfc_array_i2 * const restrict retarray, gfc_array_i2 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ msum_i2 (gfc_array_i2 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_2 * restrict dest; const GFC_INTEGER_2 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ msum_i2 (gfc_array_i2 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ msum_i2 (gfc_array_i2 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ msum_i2 (gfc_array_i2 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ msum_i2 (gfc_array_i2 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_2 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_2 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ ssum_i2 (gfc_array_i2 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in SUM intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/sum_i4.c b/libgfortran/generated/sum_i4.c index e97d15c62ba..e28d2c96fdf 100644 --- a/libgfortran/generated/sum_i4.c +++ b/libgfortran/generated/sum_i4.c @@ -1,5 +1,5 @@ /* Implementation of the SUM intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) @@ -116,7 +115,26 @@ sum_i4 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ sum_i4 (gfc_array_i4 * const restrict retarray, extern void msum_i4 (gfc_array_i4 * const restrict, gfc_array_i4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(msum_i4); void msum_i4 (gfc_array_i4 * const restrict retarray, gfc_array_i4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ msum_i4 (gfc_array_i4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_4 * restrict dest; const GFC_INTEGER_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ msum_i4 (gfc_array_i4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ msum_i4 (gfc_array_i4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ msum_i4 (gfc_array_i4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ msum_i4 (gfc_array_i4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_4 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ ssum_i4 (gfc_array_i4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in SUM intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/sum_i8.c b/libgfortran/generated/sum_i8.c index da913442b4f..6e824f1ca56 100644 --- a/libgfortran/generated/sum_i8.c +++ b/libgfortran/generated/sum_i8.c @@ -1,5 +1,5 @@ /* Implementation of the SUM intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) @@ -116,7 +115,26 @@ sum_i8 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ sum_i8 (gfc_array_i8 * const restrict retarray, extern void msum_i8 (gfc_array_i8 * const restrict, gfc_array_i8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(msum_i8); void msum_i8 (gfc_array_i8 * const restrict retarray, gfc_array_i8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ msum_i8 (gfc_array_i8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_INTEGER_8 * restrict dest; const GFC_INTEGER_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ msum_i8 (gfc_array_i8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ msum_i8 (gfc_array_i8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ msum_i8 (gfc_array_i8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ msum_i8 (gfc_array_i8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_INTEGER_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_INTEGER_8 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ ssum_i8 (gfc_array_i8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in SUM intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/sum_r10.c b/libgfortran/generated/sum_r10.c index 0433c90f90b..1ebd1ed5425 100644 --- a/libgfortran/generated/sum_r10.c +++ b/libgfortran/generated/sum_r10.c @@ -1,5 +1,5 @@ /* Implementation of the SUM intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_REAL_10) @@ -116,7 +115,26 @@ sum_r10 (gfc_array_r10 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ sum_r10 (gfc_array_r10 * const restrict retarray, extern void msum_r10 (gfc_array_r10 * const restrict, gfc_array_r10 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(msum_r10); void msum_r10 (gfc_array_r10 * const restrict retarray, gfc_array_r10 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ msum_r10 (gfc_array_r10 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_REAL_10 * restrict dest; const GFC_REAL_10 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ msum_r10 (gfc_array_r10 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ msum_r10 (gfc_array_r10 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ msum_r10 (gfc_array_r10 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ msum_r10 (gfc_array_r10 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_10 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_REAL_10 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ ssum_r10 (gfc_array_r10 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in SUM intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/sum_r16.c b/libgfortran/generated/sum_r16.c index 2c9fdf5b221..0038983a6b4 100644 --- a/libgfortran/generated/sum_r16.c +++ b/libgfortran/generated/sum_r16.c @@ -1,5 +1,5 @@ /* Implementation of the SUM intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_REAL_16) @@ -116,7 +115,26 @@ sum_r16 (gfc_array_r16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ sum_r16 (gfc_array_r16 * const restrict retarray, extern void msum_r16 (gfc_array_r16 * const restrict, gfc_array_r16 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(msum_r16); void msum_r16 (gfc_array_r16 * const restrict retarray, gfc_array_r16 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ msum_r16 (gfc_array_r16 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_REAL_16 * restrict dest; const GFC_REAL_16 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ msum_r16 (gfc_array_r16 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ msum_r16 (gfc_array_r16 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ msum_r16 (gfc_array_r16 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ msum_r16 (gfc_array_r16 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_16 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_REAL_16 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ ssum_r16 (gfc_array_r16 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in SUM intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/sum_r4.c b/libgfortran/generated/sum_r4.c index e3c33fbf1d4..1f058dcbda0 100644 --- a/libgfortran/generated/sum_r4.c +++ b/libgfortran/generated/sum_r4.c @@ -1,5 +1,5 @@ /* Implementation of the SUM intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4) @@ -116,7 +115,26 @@ sum_r4 (gfc_array_r4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ sum_r4 (gfc_array_r4 * const restrict retarray, extern void msum_r4 (gfc_array_r4 * const restrict, gfc_array_r4 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(msum_r4); void msum_r4 (gfc_array_r4 * const restrict retarray, gfc_array_r4 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ msum_r4 (gfc_array_r4 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_REAL_4 * restrict dest; const GFC_REAL_4 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ msum_r4 (gfc_array_r4 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ msum_r4 (gfc_array_r4 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ msum_r4 (gfc_array_r4 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ msum_r4 (gfc_array_r4 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_4 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_REAL_4 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ ssum_r4 (gfc_array_r4 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in SUM intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/sum_r8.c b/libgfortran/generated/sum_r8.c index 4d331e277a7..82a03bc81f7 100644 --- a/libgfortran/generated/sum_r8.c +++ b/libgfortran/generated/sum_r8.c @@ -1,5 +1,5 @@ /* Implementation of the SUM intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include "libgfortran.h" #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8) @@ -116,7 +115,26 @@ sum_r8 (gfc_array_r8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -184,14 +202,14 @@ sum_r8 (gfc_array_r8 * const restrict retarray, extern void msum_r8 (gfc_array_r8 * const restrict, gfc_array_r8 * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(msum_r8); void msum_r8 (gfc_array_r8 * const restrict retarray, gfc_array_r8 * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -200,13 +218,14 @@ msum_r8 (gfc_array_r8 * const restrict retarray, index_type mstride[GFC_MAX_DIMENSIONS]; GFC_REAL_8 * restrict dest; const GFC_REAL_8 * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -214,13 +233,27 @@ msum_r8 (gfc_array_r8 * const restrict retarray, len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -230,7 +263,7 @@ msum_r8 (gfc_array_r8 * const restrict retarray, for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -272,7 +305,35 @@ msum_r8 (gfc_array_r8 * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -285,22 +346,11 @@ msum_r8 (gfc_array_r8 * const restrict retarray, dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const GFC_REAL_8 * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; GFC_REAL_8 result; src = base; msrc = mbase; @@ -391,13 +441,21 @@ ssum_r8 (gfc_array_r8 * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in SUM intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/generated/transpose_c10.c b/libgfortran/generated/transpose_c10.c index aec76c647ea..f809f01eb0e 100644 --- a/libgfortran/generated/transpose_c10.c +++ b/libgfortran/generated/transpose_c10.c @@ -1,5 +1,5 @@ /* Implementation of the TRANSPOSE intrinsic - Copyright 2003, 2005, 2006 Free Software Foundation, Inc. + Copyright 2003, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Tobias Schlüter This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" -#include <assert.h> #include "libgfortran.h" +#include <assert.h> + #if defined (HAVE_GFC_COMPLEX_10) diff --git a/libgfortran/generated/transpose_c16.c b/libgfortran/generated/transpose_c16.c index 62d91658021..06adc81d9f1 100644 --- a/libgfortran/generated/transpose_c16.c +++ b/libgfortran/generated/transpose_c16.c @@ -1,5 +1,5 @@ /* Implementation of the TRANSPOSE intrinsic - Copyright 2003, 2005, 2006 Free Software Foundation, Inc. + Copyright 2003, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Tobias Schlüter This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" -#include <assert.h> #include "libgfortran.h" +#include <assert.h> + #if defined (HAVE_GFC_COMPLEX_16) diff --git a/libgfortran/generated/transpose_c4.c b/libgfortran/generated/transpose_c4.c index ac4316c930e..4a2a8c06d93 100644 --- a/libgfortran/generated/transpose_c4.c +++ b/libgfortran/generated/transpose_c4.c @@ -1,5 +1,5 @@ /* Implementation of the TRANSPOSE intrinsic - Copyright 2003, 2005, 2006 Free Software Foundation, Inc. + Copyright 2003, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Tobias Schlüter This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" -#include <assert.h> #include "libgfortran.h" +#include <assert.h> + #if defined (HAVE_GFC_COMPLEX_4) diff --git a/libgfortran/generated/transpose_c8.c b/libgfortran/generated/transpose_c8.c index 401874a8d86..cdfb6c94068 100644 --- a/libgfortran/generated/transpose_c8.c +++ b/libgfortran/generated/transpose_c8.c @@ -1,5 +1,5 @@ /* Implementation of the TRANSPOSE intrinsic - Copyright 2003, 2005, 2006 Free Software Foundation, Inc. + Copyright 2003, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Tobias Schlüter This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" -#include <assert.h> #include "libgfortran.h" +#include <assert.h> + #if defined (HAVE_GFC_COMPLEX_8) diff --git a/libgfortran/generated/transpose_i16.c b/libgfortran/generated/transpose_i16.c index f47a0ee4b44..23183bb27e1 100644 --- a/libgfortran/generated/transpose_i16.c +++ b/libgfortran/generated/transpose_i16.c @@ -1,5 +1,5 @@ /* Implementation of the TRANSPOSE intrinsic - Copyright 2003, 2005, 2006 Free Software Foundation, Inc. + Copyright 2003, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Tobias Schlüter This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" -#include <assert.h> #include "libgfortran.h" +#include <assert.h> + #if defined (HAVE_GFC_INTEGER_16) diff --git a/libgfortran/generated/transpose_i4.c b/libgfortran/generated/transpose_i4.c index 23ed03ff22d..f426ddf9daa 100644 --- a/libgfortran/generated/transpose_i4.c +++ b/libgfortran/generated/transpose_i4.c @@ -1,5 +1,5 @@ /* Implementation of the TRANSPOSE intrinsic - Copyright 2003, 2005, 2006 Free Software Foundation, Inc. + Copyright 2003, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Tobias Schlüter This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" -#include <assert.h> #include "libgfortran.h" +#include <assert.h> + #if defined (HAVE_GFC_INTEGER_4) diff --git a/libgfortran/generated/transpose_i8.c b/libgfortran/generated/transpose_i8.c index 3972032e662..dec4f6b3865 100644 --- a/libgfortran/generated/transpose_i8.c +++ b/libgfortran/generated/transpose_i8.c @@ -1,5 +1,5 @@ /* Implementation of the TRANSPOSE intrinsic - Copyright 2003, 2005, 2006 Free Software Foundation, Inc. + Copyright 2003, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Tobias Schlüter This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" -#include <assert.h> #include "libgfortran.h" +#include <assert.h> + #if defined (HAVE_GFC_INTEGER_8) diff --git a/libgfortran/generated/transpose_r10.c b/libgfortran/generated/transpose_r10.c index 97a988ceea3..6f01d562fab 100644 --- a/libgfortran/generated/transpose_r10.c +++ b/libgfortran/generated/transpose_r10.c @@ -1,5 +1,5 @@ /* Implementation of the TRANSPOSE intrinsic - Copyright 2003, 2005, 2006 Free Software Foundation, Inc. + Copyright 2003, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Tobias Schlüter This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" -#include <assert.h> #include "libgfortran.h" +#include <assert.h> + #if defined (HAVE_GFC_REAL_10) diff --git a/libgfortran/generated/transpose_r16.c b/libgfortran/generated/transpose_r16.c index ba4c09e7470..1991e521013 100644 --- a/libgfortran/generated/transpose_r16.c +++ b/libgfortran/generated/transpose_r16.c @@ -1,5 +1,5 @@ /* Implementation of the TRANSPOSE intrinsic - Copyright 2003, 2005, 2006 Free Software Foundation, Inc. + Copyright 2003, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Tobias Schlüter This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" -#include <assert.h> #include "libgfortran.h" +#include <assert.h> + #if defined (HAVE_GFC_REAL_16) diff --git a/libgfortran/generated/transpose_r4.c b/libgfortran/generated/transpose_r4.c index f441f371b6d..257d6787f36 100644 --- a/libgfortran/generated/transpose_r4.c +++ b/libgfortran/generated/transpose_r4.c @@ -1,5 +1,5 @@ /* Implementation of the TRANSPOSE intrinsic - Copyright 2003, 2005, 2006 Free Software Foundation, Inc. + Copyright 2003, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Tobias Schlüter This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" -#include <assert.h> #include "libgfortran.h" +#include <assert.h> + #if defined (HAVE_GFC_REAL_4) diff --git a/libgfortran/generated/transpose_r8.c b/libgfortran/generated/transpose_r8.c index a97206e9c37..5430845391d 100644 --- a/libgfortran/generated/transpose_r8.c +++ b/libgfortran/generated/transpose_r8.c @@ -1,5 +1,5 @@ /* Implementation of the TRANSPOSE intrinsic - Copyright 2003, 2005, 2006 Free Software Foundation, Inc. + Copyright 2003, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Tobias Schlüter This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" -#include <assert.h> #include "libgfortran.h" +#include <assert.h> + #if defined (HAVE_GFC_REAL_8) diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index c16dd1eee33..7df40163606 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -4,14 +4,18 @@ GFORTRAN_1.0 { _gfortran_access_func; _gfortran_adjustl; _gfortran_adjustr; - _gfortran_alarm_sub; - _gfortran_alarm_sub_int; + _gfortran_alarm_sub_i4; + _gfortran_alarm_sub_i8; + _gfortran_alarm_sub_int_i4; + _gfortran_alarm_sub_int_i8; + _gfortran_all_l1; _gfortran_all_l16; + _gfortran_all_l2; _gfortran_all_l4; _gfortran_all_l8; - _gfortran_allocate; - _gfortran_allocate_array; + _gfortran_any_l1; _gfortran_any_l16; + _gfortran_any_l2; _gfortran_any_l4; _gfortran_any_l8; _gfortran_arandom_r10; @@ -28,15 +32,11 @@ GFORTRAN_1.0 { _gfortran_chmod_i8_sub; _gfortran_compare_string; _gfortran_concat_string; - _gfortran_count_16_l16; - _gfortran_count_16_l4; - _gfortran_count_16_l8; - _gfortran_count_4_l16; - _gfortran_count_4_l4; - _gfortran_count_4_l8; - _gfortran_count_8_l16; - _gfortran_count_8_l4; - _gfortran_count_8_l8; + _gfortran_count_1_l; + _gfortran_count_16_l; + _gfortran_count_2_l; + _gfortran_count_4_l; + _gfortran_count_8_l; _gfortran_cpu_time_10; _gfortran_cpu_time_16; _gfortran_cpu_time_4; @@ -58,7 +58,8 @@ GFORTRAN_1.0 { _gfortran_ctime; _gfortran_ctime_sub; _gfortran_date_and_time; - _gfortran_deallocate; + _gfortran_dtime; + _gfortran_dtime_sub; _gfortran_eoshift0_1; _gfortran_eoshift0_1_char; _gfortran_eoshift0_2; @@ -165,7 +166,6 @@ GFORTRAN_1.0 { _gfortran_ierrno_i4; _gfortran_ierrno_i8; _gfortran_internal_pack; - _gfortran_internal_realloc; _gfortran_internal_unpack; _gfortran_irand; _gfortran_isatty_l4; @@ -551,7 +551,8 @@ GFORTRAN_1.0 { _gfortran_random_r16; _gfortran_random_r4; _gfortran_random_r8; - _gfortran_random_seed; + _gfortran_random_seed_i4; + _gfortran_random_seed_i8; _gfortran_rename_i4; _gfortran_rename_i4_sub; _gfortran_rename_i8; @@ -941,6 +942,7 @@ GFORTRAN_1.0 { _gfortran_st_rewind; _gfortran_string_index; _gfortran_string_len_trim; + _gfortran_string_minmax; _gfortran_string_scan; _gfortran_string_trim; _gfortran_string_verify; @@ -1003,8 +1005,6 @@ GFORTRAN_1.0 { _gfortran_unpack0_char; _gfortran_unpack1; _gfortran_unpack1_char; - __iso_c_binding_c_associated_1; - __iso_c_binding_c_associated_2; __iso_c_binding_c_f_pointer; __iso_c_binding_c_f_pointer_d0; __iso_c_binding_c_f_pointer_i1; @@ -1138,6 +1138,8 @@ GFORTRAN_C99_1.0 { j0f; j1f; jnf; + lgamma; + lgammaf; log10f; log10l; logf; @@ -1152,6 +1154,8 @@ GFORTRAN_C99_1.0 { sqrtf; tanf; tanhf; + tgamma; + tgammaf; trunc; truncf; y0f; diff --git a/libgfortran/intrinsics/abort.c b/libgfortran/intrinsics/abort.c index 6bf313ad364..4e13cb56ad9 100644 --- a/libgfortran/intrinsics/abort.c +++ b/libgfortran/intrinsics/abort.c @@ -1,5 +1,5 @@ /* Implementation of the ABORT intrinsic. - Copyright (C) 2003, 2004, 2005, 2006 Free Software Foundation, Inc. + Copyright (C) 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -27,8 +27,8 @@ 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 <stdlib.h> #include "libgfortran.h" +#include <stdlib.h> void PREFIX(abort) (void); export_proto_np(PREFIX(abort)); diff --git a/libgfortran/intrinsics/access.c b/libgfortran/intrinsics/access.c index 08008bfb728..221c5d5e2c2 100644 --- a/libgfortran/intrinsics/access.c +++ b/libgfortran/intrinsics/access.c @@ -1,5 +1,5 @@ /* Implementation of the ACCESS intrinsic. - Copyright (C) 2006 Free Software Foundation, Inc. + Copyright (C) 2006, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,14 +28,11 @@ 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 "config.h" #include "libgfortran.h" #include <errno.h> - -#ifdef HAVE_STRING_H #include <string.h> -#endif + #ifdef HAVE_UNISTD_H #include <unistd.h> #endif diff --git a/libgfortran/intrinsics/args.c b/libgfortran/intrinsics/args.c index 26a6b20f169..c3435957d26 100644 --- a/libgfortran/intrinsics/args.c +++ b/libgfortran/intrinsics/args.c @@ -1,6 +1,6 @@ /* Implementation of the GETARG and IARGC g77, and corresponding F2003, intrinsics. - Copyright (C) 2004, 2005 Free Software Foundation, Inc. + Copyright (C) 2004, 2005, 2007 Free Software Foundation, Inc. Contributed by Bud Davis and Janne Blomqvist. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -29,9 +29,8 @@ 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 "config.h" -#include <string.h> #include "libgfortran.h" +#include <string.h> /* Get a commandline argument. */ diff --git a/libgfortran/intrinsics/associated.c b/libgfortran/intrinsics/associated.c index d5ef556b80c..0d32fd7d002 100644 --- a/libgfortran/intrinsics/associated.c +++ b/libgfortran/intrinsics/associated.c @@ -30,11 +30,10 @@ Boston, MA 02110-1301, USA. */ #include "libgfortran.h" -extern GFC_LOGICAL_4 associated (const gfc_array_void *, - const gfc_array_void *); +extern int associated (const gfc_array_void *, const gfc_array_void *); export_proto(associated); -GFC_LOGICAL_4 +int associated (const gfc_array_void *pointer, const gfc_array_void *target) { int n, rank; diff --git a/libgfortran/intrinsics/c99_functions.c b/libgfortran/intrinsics/c99_functions.c index 8b82ae3346a..13d55036ac9 100644 --- a/libgfortran/intrinsics/c99_functions.c +++ b/libgfortran/intrinsics/c99_functions.c @@ -341,7 +341,11 @@ log10f(float x) double scalbn(double x, int y) { +#if (FLT_RADIX == 2) && defined(HAVE_LDEXP) + return ldexp (x, y); +#else return x * pow(FLT_RADIX, y); +#endif } #endif @@ -500,6 +504,57 @@ powf(float x, float y) /* Algorithm by Steven G. Kargl. */ +#if !defined(HAVE_ROUNDL) +#define HAVE_ROUNDL 1 +#if defined(HAVE_CEILL) +/* Round to nearest integral value. If the argument is halfway between two + integral values then round away from zero. */ + +long double +roundl(long double x) +{ + long double t; + if (!isfinite (x)) + return (x); + + if (x >= 0.0) + { + t = ceill(x); + if (t - x > 0.5) + t -= 1.0; + return (t); + } + else + { + t = ceill(-x); + if (t + x > 0.5) + t -= 1.0; + return (-t); + } +} +#else + +/* Poor version of roundl for system that don't have ceill. */ +long double +roundl(long double x) +{ + if (x > DBL_MAX || x < -DBL_MAX) + { +#ifdef HAVE_NEXTAFTERL + static long double prechalf = nexafterl (0.5L, LDBL_MAX); +#else + static long double prechalf = 0.5L; +#endif + return (GFC_INTEGER_LARGEST) (x + (x > 0 ? prechalf : -prechalf)); + } + else + /* Use round(). */ + return round((double) x); +} + +#endif +#endif + #ifndef HAVE_ROUND #define HAVE_ROUND 1 /* Round to nearest integral value. If the argument is halfway between two @@ -558,6 +613,64 @@ roundf(float x) } #endif + +/* lround{f,,l} and llround{f,,l} functions. */ + +#if !defined(HAVE_LROUNDF) && defined(HAVE_ROUNDF) +#define HAVE_LROUNDF 1 +long int +lroundf (float x) +{ + return (long int) roundf (x); +} +#endif + +#if !defined(HAVE_LROUND) && defined(HAVE_ROUND) +#define HAVE_LROUND 1 +long int +lround (double x) +{ + return (long int) round (x); +} +#endif + +#if !defined(HAVE_LROUNDL) && defined(HAVE_ROUNDL) +#define HAVE_LROUNDL 1 +long int +lroundl (long double x) +{ + return (long long int) roundl (x); +} +#endif + +#if !defined(HAVE_LLROUNDF) && defined(HAVE_ROUNDF) +#define HAVE_LLROUNDF 1 +long long int +llroundf (float x) +{ + return (long long int) roundf (x); +} +#endif + +#if !defined(HAVE_LLROUND) && defined(HAVE_ROUND) +#define HAVE_LLROUND 1 +long long int +llround (double x) +{ + return (long long int) round (x); +} +#endif + +#if !defined(HAVE_LLROUNDL) && defined(HAVE_ROUNDL) +#define HAVE_LLROUNDL 1 +long long int +llroundl (long double x) +{ + return (long long int) roundl (x); +} +#endif + + #ifndef HAVE_LOG10L #define HAVE_LOG10L 1 /* log10 function for long double variables. The version provided here @@ -1301,3 +1414,335 @@ ctanl (long double complex a) } #endif + +#if !defined(HAVE_TGAMMA) +#define HAVE_TGAMMA 1 + +extern double tgamma (double); + +/* Fallback tgamma() function. Uses the algorithm from + http://www.netlib.org/specfun/gamma and references therein. */ + +#undef SQRTPI +#define SQRTPI 0.9189385332046727417803297 + +#undef PI +#define PI 3.1415926535897932384626434 + +double +tgamma (double x) +{ + int i, n, parity; + double fact, res, sum, xden, xnum, y, y1, ysq, z; + + static double p[8] = { + -1.71618513886549492533811e0, 2.47656508055759199108314e1, + -3.79804256470945635097577e2, 6.29331155312818442661052e2, + 8.66966202790413211295064e2, -3.14512729688483675254357e4, + -3.61444134186911729807069e4, 6.64561438202405440627855e4 }; + + static double q[8] = { + -3.08402300119738975254353e1, 3.15350626979604161529144e2, + -1.01515636749021914166146e3, -3.10777167157231109440444e3, + 2.25381184209801510330112e4, 4.75584627752788110767815e3, + -1.34659959864969306392456e5, -1.15132259675553483497211e5 }; + + static double c[7] = { -1.910444077728e-03, + 8.4171387781295e-04, -5.952379913043012e-04, + 7.93650793500350248e-04, -2.777777777777681622553e-03, + 8.333333333333333331554247e-02, 5.7083835261e-03 }; + + static const double xminin = 2.23e-308; + static const double xbig = 171.624; + static const double xnan = __builtin_nan ("0x0"), xinf = __builtin_inf (); + static double eps = 0; + + if (eps == 0) + eps = nextafter(1., 2.) - 1.; + + parity = 0; + fact = 1; + n = 0; + y = x; + + if (__builtin_isnan (x)) + return x; + + if (y <= 0) + { + y = -x; + y1 = trunc(y); + res = y - y1; + + if (res != 0) + { + if (y1 != trunc(y1*0.5l)*2) + parity = 1; + fact = -PI / sin(PI*res); + y = y + 1; + } + else + return x == 0 ? copysign (xinf, x) : xnan; + } + + if (y < eps) + { + if (y >= xminin) + res = 1 / y; + else + return xinf; + } + else if (y < 13) + { + y1 = y; + if (y < 1) + { + z = y; + y = y + 1; + } + else + { + n = (int)y - 1; + y = y - n; + z = y - 1; + } + + xnum = 0; + xden = 1; + for (i = 0; i < 8; i++) + { + xnum = (xnum + p[i]) * z; + xden = xden * z + q[i]; + } + + res = xnum / xden + 1; + + if (y1 < y) + res = res / y1; + else if (y1 > y) + for (i = 1; i <= n; i++) + { + res = res * y; + y = y + 1; + } + } + else + { + if (y < xbig) + { + ysq = y * y; + sum = c[6]; + for (i = 0; i < 6; i++) + sum = sum / ysq + c[i]; + + sum = sum/y - y + SQRTPI; + sum = sum + (y - 0.5) * log(y); + res = exp(sum); + } + else + return x < 0 ? xnan : xinf; + } + + if (parity) + res = -res; + if (fact != 1) + res = fact / res; + + return res; +} +#endif + + + +#if !defined(HAVE_LGAMMA) +#define HAVE_LGAMMA 1 + +extern double lgamma (double); + +/* Fallback lgamma() function. Uses the algorithm from + http://www.netlib.org/specfun/algama and references therein, + except for negative arguments (where netlib would return +Inf) + where we use the following identity: + lgamma(y) = log(pi/(|y*sin(pi*y)|)) - lgamma(-y) + */ + +double +lgamma (double y) +{ + +#undef SQRTPI +#define SQRTPI 0.9189385332046727417803297 + +#undef PI +#define PI 3.1415926535897932384626434 + +#define PNT68 0.6796875 +#define D1 -0.5772156649015328605195174 +#define D2 0.4227843350984671393993777 +#define D4 1.791759469228055000094023 + + static double p1[8] = { + 4.945235359296727046734888e0, 2.018112620856775083915565e2, + 2.290838373831346393026739e3, 1.131967205903380828685045e4, + 2.855724635671635335736389e4, 3.848496228443793359990269e4, + 2.637748787624195437963534e4, 7.225813979700288197698961e3 }; + static double q1[8] = { + 6.748212550303777196073036e1, 1.113332393857199323513008e3, + 7.738757056935398733233834e3, 2.763987074403340708898585e4, + 5.499310206226157329794414e4, 6.161122180066002127833352e4, + 3.635127591501940507276287e4, 8.785536302431013170870835e3 }; + static double p2[8] = { + 4.974607845568932035012064e0, 5.424138599891070494101986e2, + 1.550693864978364947665077e4, 1.847932904445632425417223e5, + 1.088204769468828767498470e6, 3.338152967987029735917223e6, + 5.106661678927352456275255e6, 3.074109054850539556250927e6 }; + static double q2[8] = { + 1.830328399370592604055942e2, 7.765049321445005871323047e3, + 1.331903827966074194402448e5, 1.136705821321969608938755e6, + 5.267964117437946917577538e6, 1.346701454311101692290052e7, + 1.782736530353274213975932e7, 9.533095591844353613395747e6 }; + static double p4[8] = { + 1.474502166059939948905062e4, 2.426813369486704502836312e6, + 1.214755574045093227939592e8, 2.663432449630976949898078e9, + 2.940378956634553899906876e10, 1.702665737765398868392998e11, + 4.926125793377430887588120e11, 5.606251856223951465078242e11 }; + static double q4[8] = { + 2.690530175870899333379843e3, 6.393885654300092398984238e5, + 4.135599930241388052042842e7, 1.120872109616147941376570e9, + 1.488613728678813811542398e10, 1.016803586272438228077304e11, + 3.417476345507377132798597e11, 4.463158187419713286462081e11 }; + static double c[7] = { + -1.910444077728e-03, 8.4171387781295e-04, + -5.952379913043012e-04, 7.93650793500350248e-04, + -2.777777777777681622553e-03, 8.333333333333333331554247e-02, + 5.7083835261e-03 }; + + static double xbig = 2.55e305, xinf = __builtin_inf (), eps = 0, + frtbig = 2.25e76; + + int i; + double corr, res, xden, xm1, xm2, xm4, xnum, ysq; + + if (eps == 0) + eps = __builtin_nextafter(1., 2.) - 1.; + + if ((y > 0) && (y <= xbig)) + { + if (y <= eps) + res = -log(y); + else if (y <= 1.5) + { + if (y < PNT68) + { + corr = -log(y); + xm1 = y; + } + else + { + corr = 0; + xm1 = (y - 0.5) - 0.5; + } + + if ((y <= 0.5) || (y >= PNT68)) + { + xden = 1; + xnum = 0; + for (i = 0; i < 8; i++) + { + xnum = xnum*xm1 + p1[i]; + xden = xden*xm1 + q1[i]; + } + res = corr + (xm1 * (D1 + xm1*(xnum/xden))); + } + else + { + xm2 = (y - 0.5) - 0.5; + xden = 1; + xnum = 0; + for (i = 0; i < 8; i++) + { + xnum = xnum*xm2 + p2[i]; + xden = xden*xm2 + q2[i]; + } + res = corr + xm2 * (D2 + xm2*(xnum/xden)); + } + } + else if (y <= 4) + { + xm2 = y - 2; + xden = 1; + xnum = 0; + for (i = 0; i < 8; i++) + { + xnum = xnum*xm2 + p2[i]; + xden = xden*xm2 + q2[i]; + } + res = xm2 * (D2 + xm2*(xnum/xden)); + } + else if (y <= 12) + { + xm4 = y - 4; + xden = -1; + xnum = 0; + for (i = 0; i < 8; i++) + { + xnum = xnum*xm4 + p4[i]; + xden = xden*xm4 + q4[i]; + } + res = D4 + xm4*(xnum/xden); + } + else + { + res = 0; + if (y <= frtbig) + { + res = c[6]; + ysq = y * y; + for (i = 0; i < 6; i++) + res = res / ysq + c[i]; + } + res = res/y; + corr = log(y); + res = res + SQRTPI - 0.5*corr; + res = res + y*(corr-1); + } + } + else if (y < 0 && __builtin_floor (y) != y) + { + /* lgamma(y) = log(pi/(|y*sin(pi*y)|)) - lgamma(-y) + For abs(y) very close to zero, we use a series expansion to + the first order in y to avoid overflow. */ + if (y > -1.e-100) + res = -2 * log (fabs (y)) - lgamma (-y); + else + res = log (PI / fabs (y * sin (PI * y))) - lgamma (-y); + } + else + res = xinf; + + return res; +} +#endif + + +#if defined(HAVE_TGAMMA) && !defined(HAVE_TGAMMAF) +#define HAVE_TGAMMAF 1 +extern float tgammaf (float); + +float +tgammaf (float x) +{ + return (float) tgamma ((double) x); +} +#endif + +#if defined(HAVE_LGAMMA) && !defined(HAVE_LGAMMAF) +#define HAVE_LGAMMAF 1 +extern float lgammaf (float); + +float +lgammaf (float x) +{ + return (float) lgamma ((double) x); +} +#endif diff --git a/libgfortran/intrinsics/chdir.c b/libgfortran/intrinsics/chdir.c index e365a6afed8..c5eb13dd9be 100644 --- a/libgfortran/intrinsics/chdir.c +++ b/libgfortran/intrinsics/chdir.c @@ -1,5 +1,5 @@ /* Implementation of the CHDIR intrinsic. - Copyright (C) 2005 Free Software Foundation, Inc. + Copyright (C) 2005, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,14 +28,11 @@ 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 "config.h" #include "libgfortran.h" #include <errno.h> - -#ifdef HAVE_STRING_H #include <string.h> -#endif + #ifdef HAVE_UNISTD_H #include <unistd.h> #endif diff --git a/libgfortran/intrinsics/chmod.c b/libgfortran/intrinsics/chmod.c index fd0542fa1bb..0f44efe6644 100644 --- a/libgfortran/intrinsics/chmod.c +++ b/libgfortran/intrinsics/chmod.c @@ -1,5 +1,5 @@ /* Implementation of the CHMOD intrinsic. - Copyright (C) 2006 Free Software Foundation, Inc. + Copyright (C) 2006, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,14 +28,11 @@ 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 "config.h" #include "libgfortran.h" #include <errno.h> - -#ifdef HAVE_STRING_H #include <string.h> -#endif + #ifdef HAVE_UNISTD_H #include <unistd.h> #endif diff --git a/libgfortran/intrinsics/clock.c b/libgfortran/intrinsics/clock.c index 73e50634e36..ba5514358c8 100644 --- a/libgfortran/intrinsics/clock.c +++ b/libgfortran/intrinsics/clock.c @@ -1,5 +1,5 @@ /* Implementation of the MCLOCK and MCLOCK8 g77 intrinsics. - Copyright (C) 2006 Free Software Foundation, Inc. + Copyright (C) 2006, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" #ifdef TIME_WITH_SYS_TIME diff --git a/libgfortran/intrinsics/cpu_time.c b/libgfortran/intrinsics/cpu_time.c index c94cb4c5ce7..c1020dcca40 100644 --- a/libgfortran/intrinsics/cpu_time.c +++ b/libgfortran/intrinsics/cpu_time.c @@ -1,5 +1,5 @@ /* Implementation of the CPU_TIME intrinsic. - Copyright (C) 2003 Free Software Foundation, Inc. + Copyright (C) 2003, 2007 Free Software Foundation, Inc. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -27,39 +27,12 @@ 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 "config.h" #include "libgfortran.h" - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - -/* The CPU_TIME intrinsic to "compare different algorithms on the same - computer or discover which parts are the most expensive", so we - need a way to get the CPU time with the finest resolution possible. - We can only be accurate up to microseconds. - - As usual with UNIX systems, unfortunately no single way is - available for all systems. */ - -#ifdef TIME_WITH_SYS_TIME -# include <sys/time.h> -# include <time.h> -#else -# if HAVE_SYS_TIME_H -# include <sys/time.h> -# else -# ifdef HAVE_TIME_H -# include <time.h> -# endif -# endif -#endif +#include "time_1.h" /* The most accurate way to get the CPU time is getrusage (). If we have times(), that's good enough, too. */ -#if defined (HAVE_GETRUSAGE) && defined (HAVE_SYS_RESOURCE_H) -# include <sys/resource.h> -#else +#if !defined (HAVE_GETRUSAGE) || !defined (HAVE_SYS_RESOURCE_H) /* For times(), we _must_ know the number of clock ticks per second. */ # if defined (HAVE_TIMES) && (defined (HZ) || defined (_SC_CLK_TCK) || defined (CLK_TCK)) # ifdef HAVE_SYS_PARAM_H @@ -76,65 +49,18 @@ Boston, MA 02110-1301, USA. */ # endif # endif # endif /* HAVE_TIMES etc. */ -#endif /* HAVE_GETRUSAGE && HAVE_SYS_RESOURCE_H */ - -#if defined (__GNUC__) && (__GNUC__ >= 3) -# define ATTRIBUTE_ALWAYS_INLINE __attribute__ ((__always_inline__)) -#else -# define ATTRIBUTE_ALWAYS_INLINE -#endif +#endif /* !HAVE_GETRUSAGE || !HAVE_SYS_RESOURCE_H */ static inline void __cpu_time_1 (long *, long *) ATTRIBUTE_ALWAYS_INLINE; -/* Helper function for the actual implementation of the CPU_TIME - intrinsic. Returns a CPU time in microseconds or -1 if no CPU time - could be computed. */ - -#ifdef __MINGW32__ - -#define WIN32_LEAN_AND_MEAN -#include <windows.h> - -static void -__cpu_time_1 (long *sec, long *usec) -{ - union { - FILETIME ft; - unsigned long long ulltime; - } kernel_time, user_time; - - FILETIME unused1, unused2; - unsigned long long total_time; - - /* No support for Win9x. The high order bit of the DWORD - returned by GetVersion is 0 for NT and higher. */ - if (GetVersion () >= 0x80000000) - { - *sec = -1; - *usec = 0; - return; - } - - /* The FILETIME structs filled in by GetProcessTimes represent - time in 100 nanosecond units. */ - GetProcessTimes (GetCurrentProcess (), &unused1, &unused2, - &kernel_time.ft, &user_time.ft); - - total_time = (kernel_time.ulltime + user_time.ulltime)/10; - *sec = total_time / 1000000; - *usec = total_time % 1000000; -} - -#else - static inline void __cpu_time_1 (long *sec, long *usec) { -#if defined (HAVE_GETRUSAGE) && defined (HAVE_SYS_RESOURCE_H) - struct rusage usage; - getrusage (0, &usage); - *sec = usage.ru_utime.tv_sec + usage.ru_stime.tv_sec; - *usec = usage.ru_utime.tv_usec + usage.ru_stime.tv_usec; +#if defined(__MINGW32__) || defined (HAVE_GETRUSAGE) && defined (HAVE_SYS_RESOURCE_H) + long user_sec, user_usec, system_sec, system_usec; + __time_1 (&user_sec, &user_usec, &system_sec, &system_usec); + *sec = user_sec + system_sec; + *usec = user_usec + system_usec; #else /* ! HAVE_GETRUSAGE || ! HAVE_SYS_RESOURCE_H */ #ifdef HAVE_TIMES struct tms buf; @@ -146,10 +72,9 @@ __cpu_time_1 (long *sec, long *usec) *sec = -1; *usec = 0; #endif /* HAVE_TIMES */ -#endif /* HAVE_GETRUSAGE */ +#endif /* __MINGW32__ || HAVE_GETRUSAGE */ } -#endif extern void cpu_time_4 (GFC_REAL_4 *); iexport_proto(cpu_time_4); diff --git a/libgfortran/intrinsics/cshift0.c b/libgfortran/intrinsics/cshift0.c index 2ecf30e5f76..75762a8158f 100644 --- a/libgfortran/intrinsics/cshift0.c +++ b/libgfortran/intrinsics/cshift0.c @@ -1,5 +1,5 @@ /* Generic implementation of the CSHIFT intrinsic - Copyright 2003, 2005, 2006 Free Software Foundation, Inc. + Copyright 2003, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Feng Wang <wf_cs@yahoo.com> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" /* "Templatized" helper function for the inner shift loop. */ diff --git a/libgfortran/intrinsics/ctime.c b/libgfortran/intrinsics/ctime.c index 1499fd970e4..ab9cfffe3f3 100644 --- a/libgfortran/intrinsics/ctime.c +++ b/libgfortran/intrinsics/ctime.c @@ -1,5 +1,5 @@ /* Implementation of the CTIME and FDATE g77 intrinsics. - Copyright (C) 2005 Free Software Foundation, Inc. + Copyright (C) 2005, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" #ifdef TIME_WITH_SYS_TIME diff --git a/libgfortran/intrinsics/date_and_time.c b/libgfortran/intrinsics/date_and_time.c index 2346b928d23..4e52b2ff272 100644 --- a/libgfortran/intrinsics/date_and_time.c +++ b/libgfortran/intrinsics/date_and_time.c @@ -1,5 +1,5 @@ /* Implementation of the DATE_AND_TIME intrinsic. - Copyright (C) 2003, 2004, 2005, 2006 Free Software Foundation, Inc. + Copyright (C) 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Steven Bosscher. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,12 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <string.h> #include <assert.h> -#include <stdio.h> #include <stdlib.h> -#include "libgfortran.h" #undef HAVE_NO_DATE_TIME #if TIME_WITH_SYS_TIME diff --git a/libgfortran/intrinsics/dtime.c b/libgfortran/intrinsics/dtime.c new file mode 100644 index 00000000000..52be4913869 --- /dev/null +++ b/libgfortran/intrinsics/dtime.c @@ -0,0 +1,86 @@ +/* Implementation of the dtime intrinsic. + Copyright (C) 2004, 2005, 2006, 2007 Free Software Foundation, Inc. + +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 "time_1.h" +#include <gthr.h> + +#ifdef __GTHREAD_MUTEX_INIT +static __gthread_mutex_t dtime_update_lock = __GTHREAD_MUTEX_INIT; +#else +static __gthread_mutex_t dtime_update_lock; +#endif + +extern void dtime_sub (gfc_array_r4 *t, GFC_REAL_4 *result); +iexport_proto(dtime_sub); + +void +dtime_sub (gfc_array_r4 *t, GFC_REAL_4 *result) +{ + static GFC_REAL_4 tu = 0.0, ts = 0.0, tt = 0.0; + GFC_REAL_4 *tp; + long user_sec, user_usec, system_sec, system_usec; + + if (((t->dim[0].ubound + 1 - t->dim[0].lbound)) < 2) + runtime_error ("Insufficient number of elements in TARRAY."); + + __gthread_mutex_lock (&dtime_update_lock); + if (__time_1 (&user_sec, &user_usec, &system_sec, &system_usec) == 0) + { + tu = (GFC_REAL_4)(user_sec + 1.e-6 * user_usec) - tu; + ts = (GFC_REAL_4)(system_sec + 1.e-6 * system_usec) - ts; + tt = tu + ts; + } + else + { + tu = (GFC_REAL_4)-1.0; + ts = (GFC_REAL_4)-1.0; + tt = (GFC_REAL_4)-1.0; + } + + tp = t->data; + + *tp = tu; + tp += t->dim[0].stride; + *tp = ts; + *result = tt; + __gthread_mutex_unlock (&dtime_update_lock); +} +iexport(dtime_sub); + +extern GFC_REAL_4 dtime (gfc_array_r4 *t); +export_proto(dtime); + +GFC_REAL_4 +dtime (gfc_array_r4 *t) +{ + GFC_REAL_4 val; + dtime_sub (t, &val); + return val; +} diff --git a/libgfortran/intrinsics/env.c b/libgfortran/intrinsics/env.c index c4cc4f41ace..4d6e037b5e5 100644 --- a/libgfortran/intrinsics/env.c +++ b/libgfortran/intrinsics/env.c @@ -1,6 +1,6 @@ /* Implementation of the GETENV g77, and GET_ENVIRONMENT_VARIABLE F2003, intrinsics. - Copyright (C) 2004 Free Software Foundation, Inc. + Copyright (C) 2004, 2007 Free Software Foundation, Inc. Contributed by Janne Blomqvist. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -29,10 +29,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <string.h> -#include "libgfortran.h" /* GETENV (NAME, VALUE), g77 intrinsic for retrieving the value of diff --git a/libgfortran/intrinsics/eoshift0.c b/libgfortran/intrinsics/eoshift0.c index 74f13dfa313..594944d4508 100644 --- a/libgfortran/intrinsics/eoshift0.c +++ b/libgfortran/intrinsics/eoshift0.c @@ -1,5 +1,5 @@ /* Generic implementation of the EOSHIFT intrinsic - Copyright 2002, 2005 Free Software Foundation, Inc. + Copyright 2002, 2005, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" /* TODO: make this work for large shifts when sizeof(int) < sizeof (index_type). */ diff --git a/libgfortran/intrinsics/eoshift2.c b/libgfortran/intrinsics/eoshift2.c index c41301ec26e..bfbcc3e6a80 100644 --- a/libgfortran/intrinsics/eoshift2.c +++ b/libgfortran/intrinsics/eoshift2.c @@ -1,5 +1,5 @@ /* Generic implementation of the EOSHIFT intrinsic - Copyright 2002, 2005 Free Software Foundation, Inc. + Copyright 2002, 2005, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" /* TODO: make this work for large shifts when sizeof(int) < sizeof (index_type). */ diff --git a/libgfortran/intrinsics/etime.c b/libgfortran/intrinsics/etime.c index 8929158b809..0ecba26359a 100644 --- a/libgfortran/intrinsics/etime.c +++ b/libgfortran/intrinsics/etime.c @@ -1,5 +1,5 @@ /* Implementation of the ETIME intrinsic. - Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc. + Copyright (C) 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargls@comcast.net>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,15 +28,8 @@ 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 "config.h" #include "libgfortran.h" - -#include <stdio.h> - -#if defined (HAVE_SYS_TIME_H) && defined (HAVE_SYS_RESOURCE_H) -#include <sys/time.h> -#include <sys/resource.h> -#endif +#include "time_1.h" extern void etime_sub (gfc_array_r4 *t, GFC_REAL_4 *result); iexport_proto(etime_sub); @@ -45,30 +38,23 @@ void etime_sub (gfc_array_r4 *t, GFC_REAL_4 *result) { GFC_REAL_4 tu, ts, tt, *tp; + long user_sec, user_usec, system_sec, system_usec; -#if defined(HAVE_SYS_TIME_H) && defined(HAVE_SYS_RESOURCE_H) - struct rusage rt; + if (((t->dim[0].ubound + 1 - t->dim[0].lbound)) < 2) + runtime_error ("Insufficient number of elements in TARRAY."); - if (getrusage(RUSAGE_SELF, &rt) == 0) + if (__time_1 (&user_sec, &user_usec, &system_sec, &system_usec) == 0) { - tu = (GFC_REAL_4)(rt.ru_utime.tv_sec + 1.e-6 * rt.ru_utime.tv_usec); - ts = (GFC_REAL_4)(rt.ru_stime.tv_sec + 1.e-6 * rt.ru_stime.tv_usec); + tu = (GFC_REAL_4)(user_sec + 1.e-6 * user_usec); + ts = (GFC_REAL_4)(system_sec + 1.e-6 * system_usec); tt = tu + ts; } else { - tu = -1.; - ts = -1.; - tt = -1.; + tu = (GFC_REAL_4)-1.0; + ts = (GFC_REAL_4)-1.0; + tt = (GFC_REAL_4)-1.0; } -#else - tu = -1.; - ts = -1.; - tt = -1.; -#endif - - if (((t->dim[0].ubound + 1 - t->dim[0].lbound)) < 2) - runtime_error ("Insufficient number of elements in TARRAY."); tp = t->data; diff --git a/libgfortran/intrinsics/exit.c b/libgfortran/intrinsics/exit.c index 772772191a4..c5123078792 100644 --- a/libgfortran/intrinsics/exit.c +++ b/libgfortran/intrinsics/exit.c @@ -1,5 +1,5 @@ /* Implementation of the EXIT intrinsic. - Copyright (C) 2004 Free Software Foundation, Inc. + Copyright (C) 2004, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargls@comcast.net>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -29,7 +29,6 @@ write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ -#include "config.h" #include "libgfortran.h" #ifdef HAVE_STDLIB_H diff --git a/libgfortran/intrinsics/fnum.c b/libgfortran/intrinsics/fnum.c index 02a6bb5e169..1849e1d8394 100644 --- a/libgfortran/intrinsics/fnum.c +++ b/libgfortran/intrinsics/fnum.c @@ -1,5 +1,5 @@ /* Implementation of the FNUM intrinsics. - Copyright (C) 2004 Free Software Foundation, Inc. + Copyright (C) 2004, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargls@comcast.net>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" /* FUNCTION FNUM(UNIT) diff --git a/libgfortran/intrinsics/gerror.c b/libgfortran/intrinsics/gerror.c index 0ec354a0bac..68ad7fe7a42 100644 --- a/libgfortran/intrinsics/gerror.c +++ b/libgfortran/intrinsics/gerror.c @@ -1,5 +1,5 @@ /* Implementation of the GERROR g77 intrinsic. - Copyright (C) 2005 Free Software Foundation, Inc. + Copyright (C) 2005, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,14 +28,10 @@ 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 "config.h" #include "libgfortran.h" #include <errno.h> - -#ifdef HAVE_STRING_H #include <string.h> -#endif /* GERROR (MESSAGE), g77 intrinsic for retrieving the system error diff --git a/libgfortran/intrinsics/getXid.c b/libgfortran/intrinsics/getXid.c index 9bcc9e47ecf..cac8711aca1 100644 --- a/libgfortran/intrinsics/getXid.c +++ b/libgfortran/intrinsics/getXid.c @@ -1,5 +1,5 @@ /* Wrapper for the unix get{g,p,u}id functions. - Copyright (C) 2004 Free Software Foundation, Inc. + Copyright (C) 2004, 2007 Free Software Foundation, Inc. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -27,14 +27,12 @@ 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 "config.h" +#include "libgfortran.h" #if HAVE_UNISTD_H #include <unistd.h> #endif -#include "libgfortran.h" - #ifdef __MINGW32__ #define HAVE_GETPID 1 #include <process.h> diff --git a/libgfortran/intrinsics/getcwd.c b/libgfortran/intrinsics/getcwd.c index d3bd8811229..60ec6feb1fe 100644 --- a/libgfortran/intrinsics/getcwd.c +++ b/libgfortran/intrinsics/getcwd.c @@ -1,5 +1,5 @@ /* Implementation of the GETCWD intrinsic. - Copyright (C) 2004, 2005 Free Software Foundation, Inc. + Copyright (C) 2004, 2005, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargls@comcast.net>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,17 +28,16 @@ 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 "config.h" #include "libgfortran.h" +#include <string.h> +#include <errno.h> + #ifdef HAVE_UNISTD_H #include <unistd.h> #endif -#ifdef HAVE_STRING_H -#include <string.h> -#endif -#include <errno.h> +#ifdef HAVE_GETCWD extern void getcwd_i4_sub (char *, GFC_INTEGER_4 *, gfc_charlen_type); iexport_proto(getcwd_i4_sub); @@ -85,3 +84,5 @@ PREFIX(getcwd) (char *cwd, gfc_charlen_type cwd_len) getcwd_i4_sub (cwd, &status, cwd_len); return status; } + +#endif diff --git a/libgfortran/intrinsics/getlog.c b/libgfortran/intrinsics/getlog.c index 417b0f28f99..f25f49f3670 100644 --- a/libgfortran/intrinsics/getlog.c +++ b/libgfortran/intrinsics/getlog.c @@ -1,5 +1,5 @@ /* Implementation of the GETLOG g77 intrinsic. - Copyright (C) 2005 Free Software Foundation, Inc. + Copyright (C) 2005, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,18 +28,13 @@ 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 "config.h" #include "libgfortran.h" -#ifdef HAVE_STRING_H #include <string.h> -#endif + #ifdef HAVE_UNISTD_H #include <unistd.h> #endif -#ifdef HAVE_SYS_TYPES_H -#include <sys/types.h> -#endif #ifdef HAVE_PWD_H #include <pwd.h> #endif diff --git a/libgfortran/intrinsics/hostnm.c b/libgfortran/intrinsics/hostnm.c index 0df39ea46f3..296f7ac6b65 100644 --- a/libgfortran/intrinsics/hostnm.c +++ b/libgfortran/intrinsics/hostnm.c @@ -1,5 +1,5 @@ /* Implementation of the HOSTNM intrinsic. - Copyright (C) 2005 Free Software Foundation, Inc. + Copyright (C) 2005, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" #include <errno.h> diff --git a/libgfortran/intrinsics/ierrno.c b/libgfortran/intrinsics/ierrno.c index 4b0c6da8edc..6171d526da9 100644 --- a/libgfortran/intrinsics/ierrno.c +++ b/libgfortran/intrinsics/ierrno.c @@ -1,5 +1,5 @@ /* Implementation of the IERRNO intrinsic. - Copyright (C) 2005 Free Software Foundation, Inc. + Copyright (C) 2005, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" #include <errno.h> diff --git a/libgfortran/intrinsics/iso_c_binding.c b/libgfortran/intrinsics/iso_c_binding.c index 29fb5181706..2a1e994d4d9 100644 --- a/libgfortran/intrinsics/iso_c_binding.c +++ b/libgfortran/intrinsics/iso_c_binding.c @@ -32,11 +32,11 @@ Boston, MA 02110-1301, USA. */ /* Implement the functions and subroutines provided by the intrinsic iso_c_binding module. */ -#include <stdlib.h> - #include "libgfortran.h" #include "iso_c_binding.h" +#include <stdlib.h> + /* Set the fields of a Fortran pointer descriptor to point to the given C address. It uses c_f_pointer_u0 for the common @@ -193,42 +193,3 @@ ISO_C_BINDING_PREFIX (c_f_procpointer) (void *c_ptr_in, } -/* Test if the given c_ptr is associated or not. This function is - called if the user only supplied one c_ptr parameter to the - c_associated function. The second argument is optional, and the - Fortran compiler will resolve the function to this version if only - one arg was given. Associated here simply means whether or not the - c_ptr is NULL or not. */ - -GFC_LOGICAL_4 -ISO_C_BINDING_PREFIX (c_associated_1) (void *c_ptr_in_1) -{ - if (c_ptr_in_1 != NULL) - return 1; - else - return 0; -} - - -/* Test if the two c_ptr arguments are associated with one another. - This version of the c_associated function is called if the user - supplied two c_ptr args in the Fortran source. According to the - draft standard (J3/04-007), if c_ptr_in_1 is NULL, the two pointers - are NOT associated. If c_ptr_in_1 is non-NULL and it is not equal - to c_ptr_in_2, then either c_ptr_in_2 is NULL or is associated with - another address; either way, the two pointers are not associated - with each other then. */ - -GFC_LOGICAL_4 -ISO_C_BINDING_PREFIX (c_associated_2) (void *c_ptr_in_1, void *c_ptr_in_2) -{ - /* Since we have the second arg, if it doesn't equal the first, - return false; true otherwise. However, if the first one is null, - then return false; otherwise compare the two ptrs for equality. */ - if (c_ptr_in_1 == NULL) - return 0; - else if (c_ptr_in_1 != c_ptr_in_2) - return 0; - else - return 1; -} diff --git a/libgfortran/intrinsics/iso_c_binding.h b/libgfortran/intrinsics/iso_c_binding.h index 206359ad8c9..4679c2aba02 100644 --- a/libgfortran/intrinsics/iso_c_binding.h +++ b/libgfortran/intrinsics/iso_c_binding.h @@ -56,9 +56,6 @@ void ISO_C_BINDING_PREFIX(c_f_pointer)(void *, gfc_array_void *, implemented. */ void ISO_C_BINDING_PREFIX(c_f_procpointer) (void *, gfc_array_void *); -GFC_LOGICAL_4 ISO_C_BINDING_PREFIX(c_associated_1) (void *); -GFC_LOGICAL_4 ISO_C_BINDING_PREFIX(c_associated_2) (void *, void *); - void ISO_C_BINDING_PREFIX(c_f_pointer_u0) (void *, gfc_array_void *, const array_t *); void ISO_C_BINDING_PREFIX(c_f_pointer_d0) (void *, gfc_array_void *, diff --git a/libgfortran/intrinsics/kill.c b/libgfortran/intrinsics/kill.c index 718713133cb..c8df6256dae 100644 --- a/libgfortran/intrinsics/kill.c +++ b/libgfortran/intrinsics/kill.c @@ -1,5 +1,5 @@ /* Implementation of the KILL g77 intrinsic. - Copyright (C) 2005 Free Software Foundation, Inc. + Copyright (C) 2005, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,15 +28,13 @@ 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 "config.h" #include "libgfortran.h" +#include <errno.h> #ifdef HAVE_SIGNAL_H #include <signal.h> #endif -#include <errno.h> - /* SUBROUTINE KILL(PID, SIGNAL, STATUS) INTEGER, INTENT(IN) :: PID, SIGNAL INTEGER(KIND=1), INTENT(OUT), OPTIONAL :: STATUS diff --git a/libgfortran/intrinsics/link.c b/libgfortran/intrinsics/link.c index 4627d47d02d..d180cf4d96a 100644 --- a/libgfortran/intrinsics/link.c +++ b/libgfortran/intrinsics/link.c @@ -1,5 +1,5 @@ /* Implementation of the LINK intrinsic. - Copyright (C) 2005 Free Software Foundation, Inc. + Copyright (C) 2005, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,14 +28,11 @@ 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 "config.h" #include "libgfortran.h" #include <errno.h> - -#ifdef HAVE_STRING_H #include <string.h> -#endif + #ifdef HAVE_UNISTD_H #include <unistd.h> #endif diff --git a/libgfortran/intrinsics/malloc.c b/libgfortran/intrinsics/malloc.c index 2f53d992002..b040c851c39 100644 --- a/libgfortran/intrinsics/malloc.c +++ b/libgfortran/intrinsics/malloc.c @@ -1,5 +1,5 @@ /* Implementation of the MALLOC and FREE intrinsics - Copyright (C) 2005 Free Software Foundation, Inc. + Copyright (C) 2005, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" #ifdef HAVE_STDLIB_H diff --git a/libgfortran/intrinsics/move_alloc.c b/libgfortran/intrinsics/move_alloc.c index 24baf3971cd..82281976ff0 100644 --- a/libgfortran/intrinsics/move_alloc.c +++ b/libgfortran/intrinsics/move_alloc.c @@ -1,5 +1,5 @@ /* Generic implementation of the MOVE_ALLOC intrinsic - Copyright (C) 2006 Free Software Foundation, Inc. + Copyright (C) 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Thomas This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" #ifdef HAVE_STDLIB_H diff --git a/libgfortran/intrinsics/pack_generic.c b/libgfortran/intrinsics/pack_generic.c index 104c59f6e4d..61b41e53e65 100644 --- a/libgfortran/intrinsics/pack_generic.c +++ b/libgfortran/intrinsics/pack_generic.c @@ -1,5 +1,5 @@ /* Generic implementation of the PACK intrinsic - Copyright (C) 2002, 2004, 2005, 2006 Free Software Foundation, Inc. + Copyright (C) 2002, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" /* PACK is specified as follows: @@ -76,7 +75,7 @@ array valued, and the other one where MASK is scalar. */ static void pack_internal (gfc_array_char *ret, const gfc_array_char *array, - const gfc_array_l4 *mask, const gfc_array_char *vector, + const gfc_array_l1 *mask, const gfc_array_char *vector, index_type size) { /* r.* indicates the return array. */ @@ -89,7 +88,7 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array, /* m.* indicates the mask array. */ index_type mstride[GFC_MAX_DIMENSIONS]; index_type mstride0; - const GFC_LOGICAL_4 *mptr; + const GFC_LOGICAL_1 *mptr; index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -98,8 +97,31 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array, index_type dim; index_type nelem; index_type total; + int mask_kind; dim = GFC_DESCRIPTOR_RANK (array); + + sptr = array->data; + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Don't convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + zero_sized = 0; for (n = 0; n < dim; n++) { @@ -108,25 +130,12 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array, if (extent[n] <= 0) zero_sized = 1; sstride[n] = array->dim[n].stride * size; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; } if (sstride[0] == 0) sstride[0] = size; if (mstride[0] == 0) - mstride[0] = 1; - - sptr = array->data; - mptr = mask->data; - - /* Use the same loop for both logical types. */ - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - if (GFC_DESCRIPTOR_SIZE (mask) != 8) - runtime_error ("Funny sized logical array"); - for (n = 0; n < dim; n++) - mstride[n] <<= 1; - mptr = GFOR_POINTER_L8_TO_L4 (mptr); - } + mstride[0] = mask_kind; if (ret->data == NULL || compile_options.bounds_check) { @@ -156,7 +165,7 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array, cache behavior in the case where our cache is not big enough to hold all elements that have to be copied. */ - const GFC_LOGICAL_4 *m = mptr; + const GFC_LOGICAL_1 *m = mptr; total = 0; if (zero_sized) @@ -217,9 +226,13 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array, else { /* We come here because of range checking. */ - if (total != ret->dim[0].ubound + 1 - ret->dim[0].lbound) - runtime_error ("Incorrect extent in return value of" - " PACK intrinsic"); + index_type ret_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); } } @@ -293,25 +306,25 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array, } extern void pack (gfc_array_char *, const gfc_array_char *, - const gfc_array_l4 *, const gfc_array_char *); + const gfc_array_l1 *, const gfc_array_char *); export_proto(pack); void pack (gfc_array_char *ret, const gfc_array_char *array, - const gfc_array_l4 *mask, const gfc_array_char *vector) + const gfc_array_l1 *mask, const gfc_array_char *vector) { pack_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array)); } extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *, - const gfc_array_l4 *, const gfc_array_char *, + const gfc_array_l1 *, const gfc_array_char *, GFC_INTEGER_4, GFC_INTEGER_4); export_proto(pack_char); void pack_char (gfc_array_char *ret, GFC_INTEGER_4 ret_length __attribute__((unused)), - const gfc_array_char *array, const gfc_array_l4 *mask, + const gfc_array_char *array, const gfc_array_l1 *mask, const gfc_array_char *vector, GFC_INTEGER_4 array_length, GFC_INTEGER_4 vector_length __attribute__((unused))) { diff --git a/libgfortran/intrinsics/perror.c b/libgfortran/intrinsics/perror.c index 823ee485ca9..0365764eef2 100644 --- a/libgfortran/intrinsics/perror.c +++ b/libgfortran/intrinsics/perror.c @@ -1,5 +1,5 @@ /* Implementation of the PERROR intrinsic. - Copyright (C) 2005 Free Software Foundation, Inc. + Copyright (C) 2005, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,15 +28,10 @@ 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 "config.h" #include "libgfortran.h" -#include <stdio.h> #include <errno.h> - -#ifdef HAVE_STRING_H #include <string.h> -#endif /* SUBROUTINE PERROR(STRING) CHARACTER(len=*), INTENT(IN) :: STRING */ diff --git a/libgfortran/intrinsics/rand.c b/libgfortran/intrinsics/rand.c index e6a11b2e4d7..06c1cc8cedb 100644 --- a/libgfortran/intrinsics/rand.c +++ b/libgfortran/intrinsics/rand.c @@ -1,5 +1,5 @@ /* Implementation of the IRAND, RAND, and SRAND intrinsics. - Copyright (C) 2004, 2005 Free Software Foundation, Inc. + Copyright (C) 2004, 2005, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargls@comcast.net>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -35,7 +35,6 @@ Boston, MA 02110-1301, USA. */ 31, 1192-1201 (1988). It is also provided solely for compatibility with G77. */ -#include "config.h" #include "libgfortran.h" #include <gthr.h> diff --git a/libgfortran/intrinsics/random.c b/libgfortran/intrinsics/random.c index 9a31a0e2995..bc41eca9ab5 100644 --- a/libgfortran/intrinsics/random.c +++ b/libgfortran/intrinsics/random.c @@ -1,5 +1,5 @@ /* Implementation of the RANDOM intrinsics - Copyright 2002, 2004, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Lars Segerlund <seger@linuxmail.org> and Steve Kargl. @@ -29,9 +29,9 @@ 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 "config.h" #include "libgfortran.h" #include <gthr.h> +#include <string.h> extern void random_r4 (GFC_REAL_4 *); iexport_proto(random_r4); @@ -644,22 +644,22 @@ arandom_r16 (gfc_array_r16 *x) must be called with no argument or exactly one argument. */ void -random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get) +random_seed_i4 (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get) { int i; __gthread_mutex_lock (&random_lock); - if (size == NULL && put == NULL && get == NULL) - { - /* From the standard: "If no argument is present, the processor assigns - a processor-dependent value to the seed." */ + /* Check that we only have one argument present. */ + if ((size ? 1 : 0) + (put ? 1 : 0) + (get ? 1 : 0) > 1) + runtime_error ("RANDOM_SEED should have at most one argument present."); - for (i=0; i<kiss_size; i++) + /* From the standard: "If no argument is present, the processor assigns + a processor-dependent value to the seed." */ + if (size == NULL && put == NULL && get == NULL) + for (i = 0; i < kiss_size; i++) kiss_seed[i] = kiss_default_seed[i]; - } - if (size != NULL) *size = kiss_size; @@ -675,7 +675,7 @@ random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get) /* This code now should do correct strides. */ for (i = 0; i < kiss_size; i++) - kiss_seed[i] =(GFC_UINTEGER_4) put->data[i * put->dim[0].stride]; + kiss_seed[i] = (GFC_UINTEGER_4) put->data[i * put->dim[0].stride]; } /* Return the seed to GET data. */ @@ -696,7 +696,65 @@ random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get) __gthread_mutex_unlock (&random_lock); } -iexport(random_seed); +iexport(random_seed_i4); + + +void +random_seed_i8 (GFC_INTEGER_8 *size, gfc_array_i8 *put, gfc_array_i8 *get) +{ + int i; + + __gthread_mutex_lock (&random_lock); + + /* Check that we only have one argument present. */ + if ((size ? 1 : 0) + (put ? 1 : 0) + (get ? 1 : 0) > 1) + runtime_error ("RANDOM_SEED should have at most one argument present."); + + /* From the standard: "If no argument is present, the processor assigns + a processor-dependent value to the seed." */ + if (size == NULL && put == NULL && get == NULL) + for (i = 0; i < kiss_size; i++) + kiss_seed[i] = kiss_default_seed[i]; + + if (size != NULL) + *size = kiss_size / 2; + + if (put != NULL) + { + /* If the rank of the array is not 1, abort. */ + if (GFC_DESCRIPTOR_RANK (put) != 1) + runtime_error ("Array rank of PUT is not 1."); + + /* If the array is too small, abort. */ + if (((put->dim[0].ubound + 1 - put->dim[0].lbound)) < kiss_size / 2) + runtime_error ("Array size of PUT is too small."); + + /* This code now should do correct strides. */ + for (i = 0; i < kiss_size / 2; i++) + memcpy (&kiss_seed[2*i], &(put->data[i * put->dim[0].stride]), + sizeof (GFC_UINTEGER_8)); + } + + /* Return the seed to GET data. */ + if (get != NULL) + { + /* If the rank of the array is not 1, abort. */ + if (GFC_DESCRIPTOR_RANK (get) != 1) + runtime_error ("Array rank of GET is not 1."); + + /* If the array is too small, abort. */ + if (((get->dim[0].ubound + 1 - get->dim[0].lbound)) < kiss_size / 2) + runtime_error ("Array size of GET is too small."); + + /* This code now should do correct strides. */ + for (i = 0; i < kiss_size / 2; i++) + memcpy (&(get->data[i * get->dim[0].stride]), &kiss_seed[2*i], + sizeof (GFC_UINTEGER_8)); + } + + __gthread_mutex_unlock (&random_lock); +} +iexport(random_seed_i8); #ifndef __GTHREAD_MUTEX_INIT diff --git a/libgfortran/intrinsics/rename.c b/libgfortran/intrinsics/rename.c index c1be29bd79b..3db33a03350 100644 --- a/libgfortran/intrinsics/rename.c +++ b/libgfortran/intrinsics/rename.c @@ -1,5 +1,5 @@ /* Implementation of the RENAME intrinsic. - Copyright (C) 2005 Free Software Foundation, Inc. + Copyright (C) 2005, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,9 @@ 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 "config.h" #include "libgfortran.h" #include <errno.h> -#include <stdio.h> #include <string.h> /* SUBROUTINE RENAME(PATH1, PATH2, STATUS) diff --git a/libgfortran/intrinsics/reshape_generic.c b/libgfortran/intrinsics/reshape_generic.c index 9a20c197201..333f99d2610 100644 --- a/libgfortran/intrinsics/reshape_generic.c +++ b/libgfortran/intrinsics/reshape_generic.c @@ -1,5 +1,5 @@ /* Generic implementation of the RESHAPE intrinsic - Copyright 2002, 2006 Free Software Foundation, Inc. + Copyright 2002, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <string.h> #include <assert.h> -#include "libgfortran.h" typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) parray; diff --git a/libgfortran/intrinsics/reshape_packed.c b/libgfortran/intrinsics/reshape_packed.c index a6a193774b2..cf61f31d4d1 100644 --- a/libgfortran/intrinsics/reshape_packed.c +++ b/libgfortran/intrinsics/reshape_packed.c @@ -1,5 +1,5 @@ /* Implementation of the RESHAPE intrinsic for packed arrays - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" #include <string.h> diff --git a/libgfortran/intrinsics/signal.c b/libgfortran/intrinsics/signal.c index 2c2f38d2969..27d6222cf4e 100644 --- a/libgfortran/intrinsics/signal.c +++ b/libgfortran/intrinsics/signal.c @@ -1,4 +1,5 @@ /* Implementation of the SIGNAL and ALARM g77 intrinsics + Copyright (C) 2005, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -27,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" #ifdef HAVE_UNISTD_H @@ -132,11 +132,13 @@ iexport(signal_func_int); /* ALARM intrinsic with PROCEDURE as handler */ -extern void alarm_sub (int *, void (*)(int), int *); -iexport_proto(alarm_sub); +extern void alarm_sub_i4 (int *, void (*)(int), GFC_INTEGER_4 *); +iexport_proto(alarm_sub_i4); void -alarm_sub (int *seconds, void (*handler)(int), int *status) +alarm_sub_i4 (int * seconds __attribute__ ((unused)), + void (*handler)(int) __attribute__ ((unused)), + GFC_INTEGER_4 *status) { #if defined (SIGALRM) && defined (HAVE_ALARM) && defined (HAVE_SIGNAL) if (status != NULL) @@ -157,27 +159,89 @@ alarm_sub (int *seconds, void (*handler)(int), int *status) *status = -1; #endif } -iexport(alarm_sub); +iexport(alarm_sub_i4); + + +extern void alarm_sub_i8 (int *, void (*)(int), GFC_INTEGER_8 *); +iexport_proto(alarm_sub_i8); + +void +alarm_sub_i8 (int *seconds __attribute__ ((unused)), + void (*handler)(int) __attribute__ ((unused)), + GFC_INTEGER_8 *status) +{ +#if defined (SIGALRM) && defined (HAVE_ALARM) && defined (HAVE_SIGNAL) + if (status != NULL) + { + if (signal (SIGALRM, handler) == SIG_ERR) + *status = -1; + else + *status = alarm (*seconds); + } + else + { + signal (SIGALRM, handler); + alarm (*seconds); + } +#else + errno = ENOSYS; + if (status != NULL) + *status = -1; +#endif +} +iexport(alarm_sub_i8); /* ALARM intrinsic with INTEGER as handler */ -extern void alarm_sub_int (int *, int *, int *); -iexport_proto(alarm_sub_int); +extern void alarm_sub_int_i4 (int *, int *, GFC_INTEGER_4 *); +iexport_proto(alarm_sub_int_i4); + +void +alarm_sub_int_i4 (int *seconds __attribute__ ((unused)), + int *handler __attribute__ ((unused)), + GFC_INTEGER_4 *status) +{ +#if defined (SIGALRM) && defined (HAVE_ALARM) && defined (HAVE_SIGNAL) + if (status != NULL) + { + if (signal (SIGALRM, (void (*)(int)) (INTPTR_T) *handler) == SIG_ERR) + *status = -1; + else + *status = alarm (*seconds); + } + else + { + signal (SIGALRM, (void (*)(int)) (INTPTR_T) *handler); + alarm (*seconds); + } +#else + errno = ENOSYS; + if (status != NULL) + *status = -1; +#endif +} +iexport(alarm_sub_int_i4); + + +extern void alarm_sub_int_i8 (int *, int *, GFC_INTEGER_8 *); +iexport_proto(alarm_sub_int_i8); void -alarm_sub_int (int *seconds, int *handler, int *status) +alarm_sub_int_i8 (int *seconds __attribute__ ((unused)), + int *handler __attribute__ ((unused)), + GFC_INTEGER_8 *status) { #if defined (SIGALRM) && defined (HAVE_ALARM) && defined (HAVE_SIGNAL) if (status != NULL) { - if (signal (SIGALRM, (void (*)(int)) *handler) == SIG_ERR) + if (signal (SIGALRM, (void (*)(int)) (INTPTR_T) *handler) == SIG_ERR) *status = -1; else *status = alarm (*seconds); } else { - signal (SIGALRM, (void (*)(int)) *handler); + signal (SIGALRM, (void (*)(int)) (INTPTR_T) *handler); alarm (*seconds); } #else @@ -186,5 +250,5 @@ alarm_sub_int (int *seconds, int *handler, int *status) *status = -1; #endif } -iexport(alarm_sub_int); +iexport(alarm_sub_int_i8); diff --git a/libgfortran/intrinsics/sleep.c b/libgfortran/intrinsics/sleep.c index a344085c8c6..568a8421aa6 100644 --- a/libgfortran/intrinsics/sleep.c +++ b/libgfortran/intrinsics/sleep.c @@ -1,5 +1,5 @@ /* Implementation of the SLEEP intrinsic. - Copyright (C) 2005 Free Software Foundation, Inc. + Copyright (C) 2005, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" #include <errno.h> diff --git a/libgfortran/intrinsics/spread_generic.c b/libgfortran/intrinsics/spread_generic.c index 9ea6b12ef16..4be0a164c8a 100644 --- a/libgfortran/intrinsics/spread_generic.c +++ b/libgfortran/intrinsics/spread_generic.c @@ -1,5 +1,5 @@ /* Generic implementation of the SPREAD intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" static void spread_internal (gfc_array_char *ret, const gfc_array_char *source, @@ -111,26 +110,76 @@ spread_internal (gfc_array_char *ret, const gfc_array_char *source, } else { + int zero_sized; + + zero_sized = 0; + dim = 0; if (GFC_DESCRIPTOR_RANK(ret) != rrank) runtime_error ("rank mismatch in spread()"); - for (n = 0; n < rrank; n++) + if (compile_options.bounds_check) { - if (n == *along - 1) + for (n = 0; n < rrank; n++) { - rdelta = ret->dim[n].stride * size; + index_type ret_extent; + + ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound; + if (n == *along - 1) + { + rdelta = ret->dim[n].stride * size; + + if (ret_extent != ncopies) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) ncopies); + } + else + { + count[dim] = 0; + extent[dim] = source->dim[dim].ubound + 1 + - source->dim[dim].lbound; + if (ret_extent != extent[dim]) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, + (long int) extent[dim]); + + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = source->dim[dim].stride * size; + rstride[dim] = ret->dim[n].stride * size; + dim++; + } } - else + } + else + { + for (n = 0; n < rrank; n++) { - count[dim] = 0; - extent[dim] = source->dim[dim].ubound + 1 - - source->dim[dim].lbound; - sstride[dim] = source->dim[dim].stride * size; - rstride[dim] = ret->dim[n].stride * size; - dim++; + if (n == *along - 1) + { + rdelta = ret->dim[n].stride * size; + } + else + { + count[dim] = 0; + extent[dim] = source->dim[dim].ubound + 1 + - source->dim[dim].lbound; + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = source->dim[dim].stride * size; + rstride[dim] = ret->dim[n].stride * size; + dim++; + } } } + + if (zero_sized) + return; + if (sstride[0] == 0) sstride[0] = size; } diff --git a/libgfortran/intrinsics/stat.c b/libgfortran/intrinsics/stat.c index 9bca80fad15..11d59a884c3 100644 --- a/libgfortran/intrinsics/stat.c +++ b/libgfortran/intrinsics/stat.c @@ -1,5 +1,5 @@ /* Implementation of the STAT and FSTAT intrinsics. - Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc. + Copyright (C) 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargls@comcast.net>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,11 @@ 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 "config.h" #include "libgfortran.h" +#include <string.h> +#include <errno.h> + #ifdef HAVE_SYS_STAT_H #include <sys/stat.h> #endif @@ -39,12 +41,6 @@ Boston, MA 02110-1301, USA. */ #include <stdlib.h> #endif -#ifdef HAVE_STRING_H -#include <string.h> -#endif - -#include <errno.h> - #ifdef HAVE_STAT @@ -64,7 +60,7 @@ internal_proto(stat_i4_sub_0);*/ static void stat_i4_sub_0 (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status, - gfc_charlen_type name_len, int is_lstat) + gfc_charlen_type name_len, int is_lstat __attribute__ ((unused))) { int val; char *str; @@ -183,7 +179,7 @@ iexport(lstat_i4_sub); static void stat_i8_sub_0 (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status, - gfc_charlen_type name_len, int is_lstat) + gfc_charlen_type name_len, int is_lstat __attribute__ ((unused))) { int val; char *str; diff --git a/libgfortran/intrinsics/string_intrinsics.c b/libgfortran/intrinsics/string_intrinsics.c index 7c22c16abfe..1a769451b26 100644 --- a/libgfortran/intrinsics/string_intrinsics.c +++ b/libgfortran/intrinsics/string_intrinsics.c @@ -1,5 +1,5 @@ /* String intrinsics helper functions. - Copyright 2002, 2005 Free Software Foundation, Inc. + Copyright 2002, 2005, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -36,11 +36,11 @@ Boston, MA 02110-1301, USA. */ compiler translates the actual intrinsics calls to calls to functions in this file. */ +#include "libgfortran.h" + #include <stdlib.h> #include <string.h> -#include "libgfortran.h" - /* String functions. */ @@ -73,9 +73,17 @@ export_proto(string_verify); extern void string_trim (GFC_INTEGER_4 *, void **, GFC_INTEGER_4, const char *); export_proto(string_trim); +extern void string_minmax (GFC_INTEGER_4 *, void **, int, int, ...); +export_proto(string_minmax); + + +/* Use for functions which can return a zero-length string. */ +static char zero_length_string = '\0'; + + /* Strings of unequal length are extended with pad characters. */ -GFC_INTEGER_4 +int compare_string (GFC_INTEGER_4 len1, const char * s1, GFC_INTEGER_4 len2, const char * s2) { @@ -163,16 +171,16 @@ string_trim (GFC_INTEGER_4 * len, void ** dest, GFC_INTEGER_4 slen, } *len = i + 1; - if (*len > 0) + if (*len == 0) + *dest = &zero_length_string; + else { /* Allocate space for result string. */ *dest = internal_malloc_size (*len); - /* copy string if necessary. */ + /* Copy string if necessary. */ memmove (*dest, src, *len); } - else - *dest = NULL; } @@ -351,3 +359,61 @@ string_verify (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen, return 0; } + + +/* MIN and MAX intrinsics for strings. The front-end makes sure that + nargs is at least 2. */ + +void +string_minmax (GFC_INTEGER_4 *rlen, void **dest, int op, int nargs, ...) +{ + va_list ap; + int i; + char * next, * res; + GFC_INTEGER_4 nextlen, reslen; + + va_start (ap, nargs); + reslen = va_arg (ap, GFC_INTEGER_4); + res = va_arg (ap, char *); + *rlen = reslen; + + if (res == NULL) + runtime_error ("First argument of '%s' intrinsic should be present", + op > 0 ? "MAX" : "MIN"); + + for (i = 1; i < nargs; i++) + { + nextlen = va_arg (ap, GFC_INTEGER_4); + next = va_arg (ap, char *); + + + if (next == NULL) + { + if (i == 1) + runtime_error ("Second argument of '%s' intrinsic should be " + "present", op > 0 ? "MAX" : "MIN"); + else + continue; + } + + if (nextlen > *rlen) + *rlen = nextlen; + + if (op * compare_string (reslen, res, nextlen, next) < 0) + { + reslen = nextlen; + res = next; + } + } + va_end (ap); + + if (*rlen == 0) + *dest = &zero_length_string; + else + { + char * tmp = internal_malloc_size (*rlen); + memcpy (tmp, res, reslen); + memset (&tmp[reslen], ' ', *rlen - reslen); + *dest = tmp; + } +} diff --git a/libgfortran/intrinsics/symlnk.c b/libgfortran/intrinsics/symlnk.c index 76835884a17..b6f887a61d1 100644 --- a/libgfortran/intrinsics/symlnk.c +++ b/libgfortran/intrinsics/symlnk.c @@ -1,5 +1,5 @@ /* Implementation of the SYMLNK intrinsic. - Copyright (C) 2005 Free Software Foundation, Inc. + Copyright (C) 2005, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,14 +28,11 @@ 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 "config.h" #include "libgfortran.h" #include <errno.h> - -#ifdef HAVE_STRING_H #include <string.h> -#endif + #ifdef HAVE_UNISTD_H #include <unistd.h> #endif diff --git a/libgfortran/intrinsics/system.c b/libgfortran/intrinsics/system.c index 49a5ba2a6d5..5b8ebabf425 100644 --- a/libgfortran/intrinsics/system.c +++ b/libgfortran/intrinsics/system.c @@ -1,5 +1,5 @@ /* Implementation of the SYSTEM intrinsic. - Copyright (C) 2004 Free Software Foundation, Inc. + Copyright (C) 2004, 2007 Free Software Foundation, Inc. Contributed by Tobias Schlüter. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,17 +28,13 @@ along with libgfortran; see the file COPYING. If not, write to the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ -#include "config.h" - -#ifdef HAVE_STRING_H +#include "libgfortran.h" #include <string.h> -#endif + #ifdef HAVE_STDLIB_H #include <stdlib.h> #endif -#include "libgfortran.h" - extern void system_sub (const char *fcmd, GFC_INTEGER_4 * status, gfc_charlen_type cmd_len); iexport_proto(system_sub); diff --git a/libgfortran/intrinsics/system_clock.c b/libgfortran/intrinsics/system_clock.c index 274259cc589..2c98be6faaa 100644 --- a/libgfortran/intrinsics/system_clock.c +++ b/libgfortran/intrinsics/system_clock.c @@ -1,5 +1,5 @@ /* Implementation of the SYSTEM_CLOCK intrinsic. - Copyright (C) 2004, 2005 Free Software Foundation, Inc. + Copyright (C) 2004, 2005, 2007 Free Software Foundation, Inc. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -27,7 +27,6 @@ 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 "config.h" #include "libgfortran.h" #include <limits.h> @@ -60,7 +59,6 @@ system_clock_4(GFC_INTEGER_4 *count, GFC_INTEGER_4 *count_rate, GFC_INTEGER_4 *count_max) { GFC_INTEGER_4 cnt; - GFC_INTEGER_4 rate; GFC_INTEGER_4 mx; #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY) @@ -78,7 +76,6 @@ system_clock_4(GFC_INTEGER_4 *count, GFC_INTEGER_4 *count_rate, cnt = ucnt - GFC_INTEGER_4_HUGE - 1; else cnt = ucnt; - rate = TCK; mx = GFC_INTEGER_4_HUGE; } else @@ -123,7 +120,6 @@ system_clock_8 (GFC_INTEGER_8 *count, GFC_INTEGER_8 *count_rate, GFC_INTEGER_8 *count_max) { GFC_INTEGER_8 cnt; - GFC_INTEGER_8 rate; GFC_INTEGER_8 mx; #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY) @@ -155,7 +151,6 @@ system_clock_8 (GFC_INTEGER_8 *count, GFC_INTEGER_8 *count_rate, cnt = ucnt; mx = GFC_INTEGER_8_HUGE; } - rate = TCK; } else { diff --git a/libgfortran/intrinsics/time.c b/libgfortran/intrinsics/time.c index 6c91e45b3f5..ca5798fd057 100644 --- a/libgfortran/intrinsics/time.c +++ b/libgfortran/intrinsics/time.c @@ -1,5 +1,5 @@ /* Implementation of the TIME and TIME8 g77 intrinsics. - Copyright (C) 2005 Free Software Foundation, Inc. + Copyright (C) 2005, 2007 Free Software Foundation, Inc. Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h" #ifdef TIME_WITH_SYS_TIME diff --git a/libgfortran/intrinsics/time_1.h b/libgfortran/intrinsics/time_1.h new file mode 100644 index 00000000000..43e6d8960c1 --- /dev/null +++ b/libgfortran/intrinsics/time_1.h @@ -0,0 +1,142 @@ +/* Implementation of the CPU_TIME intrinsic. + Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +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. */ + +#ifndef LIBGFORTRAN_TIME_H +#define LIBGFORTRAN_TIME_H + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +/* The time related intrinsics (DTIME, ETIME, CPU_TIME) to "compare + different algorithms on the same computer or discover which parts + are the most expensive", need a way to get the CPU time with the + finest resolution possible. We can only be accurate up to + microseconds. + + As usual with UNIX systems, unfortunately no single way is + available for all systems. */ + +#ifdef TIME_WITH_SYS_TIME +# include <sys/time.h> +# include <time.h> +#else +# if HAVE_SYS_TIME_H +# include <sys/time.h> +# else +# ifdef HAVE_TIME_H +# include <time.h> +# endif +# endif +#endif + +/* The most accurate way to get the CPU time is getrusage (). */ +#if defined (HAVE_GETRUSAGE) && defined (HAVE_SYS_RESOURCE_H) +# include <sys/resource.h> +#endif /* HAVE_GETRUSAGE && HAVE_SYS_RESOURCE_H */ + +#if defined (__GNUC__) && (__GNUC__ >= 3) +# define ATTRIBUTE_ALWAYS_INLINE __attribute__ ((__always_inline__)) +#else +# define ATTRIBUTE_ALWAYS_INLINE +#endif + +static inline int __time_1 (long *, long *, long *, long *) ATTRIBUTE_ALWAYS_INLINE; + +/* Helper function for the actual implementation of the DTIME, ETIME and + CPU_TIME intrinsics. Returns a CPU time in microseconds or -1 if no + CPU time could be computed. */ + +#ifdef __MINGW32__ + +#define WIN32_LEAN_AND_MEAN +#include <windows.h> + +static int +__time_1 (long *user_sec, long *user_usec, long *system_sec, long *system_usec) +{ + union { + FILETIME ft; + unsigned long long ulltime; + } kernel_time, user_time; + + FILETIME unused1, unused2; + unsigned long long total_time; + + /* No support for Win9x. The high order bit of the DWORD + returned by GetVersion is 0 for NT and higher. */ + if (GetVersion () >= 0x80000000) + { + *user_sec = *system_sec = 0; + *user_usec = *system_usec = 0; + return -1; + } + + /* The FILETIME structs filled in by GetProcessTimes represent + time in 100 nanosecond units. */ + GetProcessTimes (GetCurrentProcess (), &unused1, &unused2, + &kernel_time.ft, &user_time.ft); + + *user_sec = user_time.ulltime / 10000000; + *user_usec = user_time.ulltime % 10000000; + + *system_sec = kernel_time.ulltime / 10000000; + *system_usec = kernel_time.ulltime % 10000000; + return 0; +} + +#else + +static inline int +__time_1 (long *user_sec, long *user_usec, long *system_sec, long *system_usec) +{ +#if defined (HAVE_GETRUSAGE) && defined (HAVE_SYS_RESOURCE_H) + struct rusage usage; + getrusage (0, &usage); + + *user_sec = usage.ru_utime.tv_sec; + *user_usec = usage.ru_utime.tv_usec; + *system_sec = usage.ru_stime.tv_sec; + *system_usec = usage.ru_stime.tv_usec; + return 0; + +#else /* ! HAVE_GETRUSAGE || ! HAVE_SYS_RESOURCE_H */ + + /* We have nothing to go on. Return -1. */ + *user_sec = *system_sec = 0; + *user_usec = *system_usec = 0; + return -1; + +#endif +} + +#endif + + +#endif /* LIBGFORTRAN_TIME_H */ diff --git a/libgfortran/intrinsics/transpose_generic.c b/libgfortran/intrinsics/transpose_generic.c index 1daae8bb5b7..97b97133698 100644 --- a/libgfortran/intrinsics/transpose_generic.c +++ b/libgfortran/intrinsics/transpose_generic.c @@ -1,5 +1,5 @@ /* Implementation of the TRANSPOSE intrinsic - Copyright 2003, 2006 Free Software Foundation, Inc. + Copyright 2003, 2006, 2007 Free Software Foundation, Inc. Contributed by Tobias Schlüter This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <string.h> #include <assert.h> -#include "libgfortran.h" extern void transpose (gfc_array_char *, gfc_array_char *); export_proto(transpose); diff --git a/libgfortran/intrinsics/umask.c b/libgfortran/intrinsics/umask.c index 721272dc485..81f84d26462 100644 --- a/libgfortran/intrinsics/umask.c +++ b/libgfortran/intrinsics/umask.c @@ -1,5 +1,5 @@ /* Implementation of the UMASK intrinsic. - Copyright (C) 2004 Free Software Foundation, Inc. + Copyright (C) 2004, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargls@comcast.net>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -29,7 +29,6 @@ write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ -#include "config.h" #include "libgfortran.h" #ifdef HAVE_STDLIB_H @@ -40,6 +39,11 @@ Boston, MA 02110-1301, USA. */ #include <sys/stat.h> #endif +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + + /* SUBROUTINE UMASK(MASK, OLD) INTEGER, INTENT(IN) :: MASK INTEGER, INTENT(OUT), OPTIONAL :: OLD */ diff --git a/libgfortran/intrinsics/unlink.c b/libgfortran/intrinsics/unlink.c index 2f7a5ca8b49..cf95529acee 100644 --- a/libgfortran/intrinsics/unlink.c +++ b/libgfortran/intrinsics/unlink.c @@ -1,5 +1,5 @@ /* Implementation of the UNLINK intrinsic. - Copyright (C) 2004, 2005 Free Software Foundation, Inc. + Copyright (C) 2004, 2005, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargls@comcast.net>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,17 +28,14 @@ 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 "config.h" #include "libgfortran.h" +#include <string.h> +#include <errno.h> + #ifdef HAVE_UNISTD_H #include <unistd.h> #endif -#ifdef HAVE_STRING_H -#include <string.h> -#endif - -#include <errno.h> /* SUBROUTINE UNLINK(NAME, STATUS) CHARACTER(LEN= ), INTENT(IN) :: NAME diff --git a/libgfortran/intrinsics/unpack_generic.c b/libgfortran/intrinsics/unpack_generic.c index b349f0d60fd..05141edd959 100644 --- a/libgfortran/intrinsics/unpack_generic.c +++ b/libgfortran/intrinsics/unpack_generic.c @@ -1,5 +1,5 @@ /* Generic implementation of the UNPACK intrinsic - Copyright 2002, 2003, 2004, 2005 Free Software Foundation, Inc. + Copyright 2002, 2003, 2004, 2005, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,15 +28,14 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" static void unpack_internal (gfc_array_char *ret, const gfc_array_char *vector, - const gfc_array_l4 *mask, const gfc_array_char *field, + const gfc_array_l1 *mask, const gfc_array_char *field, index_type size, index_type fsize) { /* r.* indicates the return array. */ @@ -54,7 +53,7 @@ unpack_internal (gfc_array_char *ret, const gfc_array_char *vector, /* m.* indicates the mask array. */ index_type mstride[GFC_MAX_DIMENSIONS]; index_type mstride0; - const GFC_LOGICAL_4 *mptr; + const GFC_LOGICAL_1 *mptr; index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -62,8 +61,30 @@ unpack_internal (gfc_array_char *ret, const gfc_array_char *vector, index_type dim; int empty; + int mask_kind; empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Don't convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + if (ret->data == NULL) { /* The front end has signalled that we need to populate the @@ -80,7 +101,7 @@ unpack_internal (gfc_array_char *ret, const gfc_array_char *vector, empty = empty || extent[n] <= 0; rstride[n] = ret->dim[n].stride * size; fstride[n] = field->dim[n].stride * fsize; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; rs *= extent[n]; } ret->offset = 0; @@ -96,7 +117,7 @@ unpack_internal (gfc_array_char *ret, const gfc_array_char *vector, empty = empty || extent[n] <= 0; rstride[n] = ret->dim[n].stride * size; fstride[n] = field->dim[n].stride * fsize; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; } if (rstride[0] == 0) rstride[0] = size; @@ -118,20 +139,8 @@ unpack_internal (gfc_array_char *ret, const gfc_array_char *vector, mstride0 = mstride[0]; rptr = ret->data; fptr = field->data; - mptr = mask->data; vptr = vector->data; - /* Use the same loop for both logical types. */ - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - if (GFC_DESCRIPTOR_SIZE (mask) != 8) - runtime_error ("Funny sized logical array"); - for (n = 0; n < dim; n++) - mstride[n] <<= 1; - mstride0 <<= 1; - mptr = GFOR_POINTER_L8_TO_L4 (mptr); - } - while (rptr) { if (*mptr) @@ -180,12 +189,12 @@ unpack_internal (gfc_array_char *ret, const gfc_array_char *vector, } extern void unpack1 (gfc_array_char *, const gfc_array_char *, - const gfc_array_l4 *, const gfc_array_char *); + const gfc_array_l1 *, const gfc_array_char *); export_proto(unpack1); void unpack1 (gfc_array_char *ret, const gfc_array_char *vector, - const gfc_array_l4 *mask, const gfc_array_char *field) + const gfc_array_l1 *mask, const gfc_array_char *field) { unpack_internal (ret, vector, mask, field, GFC_DESCRIPTOR_SIZE (vector), @@ -193,7 +202,7 @@ unpack1 (gfc_array_char *ret, const gfc_array_char *vector, } extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4, - const gfc_array_char *, const gfc_array_l4 *, + const gfc_array_char *, const gfc_array_l1 *, const gfc_array_char *, GFC_INTEGER_4, GFC_INTEGER_4); export_proto(unpack1_char); @@ -201,7 +210,7 @@ export_proto(unpack1_char); void unpack1_char (gfc_array_char *ret, GFC_INTEGER_4 ret_length __attribute__((unused)), - const gfc_array_char *vector, const gfc_array_l4 *mask, + const gfc_array_char *vector, const gfc_array_l1 *mask, const gfc_array_char *field, GFC_INTEGER_4 vector_length, GFC_INTEGER_4 field_length) { @@ -209,12 +218,12 @@ unpack1_char (gfc_array_char *ret, } extern void unpack0 (gfc_array_char *, const gfc_array_char *, - const gfc_array_l4 *, char *); + const gfc_array_l1 *, char *); export_proto(unpack0); void unpack0 (gfc_array_char *ret, const gfc_array_char *vector, - const gfc_array_l4 *mask, char *field) + const gfc_array_l1 *mask, char *field) { gfc_array_char tmp; @@ -225,14 +234,14 @@ unpack0 (gfc_array_char *ret, const gfc_array_char *vector, } extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4, - const gfc_array_char *, const gfc_array_l4 *, + const gfc_array_char *, const gfc_array_l1 *, char *, GFC_INTEGER_4, GFC_INTEGER_4); export_proto(unpack0_char); void unpack0_char (gfc_array_char *ret, GFC_INTEGER_4 ret_length __attribute__((unused)), - const gfc_array_char *vector, const gfc_array_l4 *mask, + const gfc_array_char *vector, const gfc_array_l1 *mask, char *field, GFC_INTEGER_4 vector_length, GFC_INTEGER_4 field_length __attribute__((unused))) { diff --git a/libgfortran/io/close.c b/libgfortran/io/close.c index 66ea6c3fb69..eb66f66507e 100644 --- a/libgfortran/io/close.c +++ b/libgfortran/io/close.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc. +/* Copyright (C) 2002, 2003, 2005, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -27,8 +27,6 @@ along with Libgfortran; see the file COPYING. If not, write to the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ -#include "config.h" -#include "libgfortran.h" #include "io.h" #include <limits.h> @@ -75,7 +73,7 @@ st_close (st_parameter_close *clp) if (u->flags.status == STATUS_SCRATCH) { if (status == CLOSE_KEEP) - generate_error (&clp->common, ERROR_BAD_OPTION, + generate_error (&clp->common, LIBERROR_BAD_OPTION, "Can't KEEP a scratch file on CLOSE"); #if !HAVE_UNLINK_OPEN_FILE path = (char *) gfc_alloca (u->file_len + 1); diff --git a/libgfortran/io/file_pos.c b/libgfortran/io/file_pos.c index c9034e8c8ca..94e29899fb1 100644 --- a/libgfortran/io/file_pos.c +++ b/libgfortran/io/file_pos.c @@ -27,10 +27,8 @@ along with Libgfortran; see the file COPYING. If not, write to the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ -#include "config.h" -#include <string.h> -#include "libgfortran.h" #include "io.h" +#include <string.h> /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE, ENDFILE, and REWIND as well as the FLUSH statement. */ @@ -92,7 +90,7 @@ formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u) return; io_error: - generate_error (&fpp->common, ERROR_OS, NULL); + generate_error (&fpp->common, LIBERROR_OS, NULL); } @@ -124,8 +122,8 @@ unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u) if (p == NULL || length_read != length) goto io_error; - /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */ - if (u->flags.convert == CONVERT_NATIVE) + /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */ + if (u->flags.convert == GFC_CONVERT_NATIVE) { switch (length) { @@ -180,7 +178,7 @@ unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u) return; io_error: - generate_error (&fpp->common, ERROR_OS, NULL); + generate_error (&fpp->common, LIBERROR_OS, NULL); } @@ -197,16 +195,26 @@ st_backspace (st_parameter_filepos *fpp) u = find_unit (fpp->common.unit); if (u == NULL) { - generate_error (&fpp->common, ERROR_BAD_UNIT, NULL); + generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL); goto done; } - /* Ignore direct access. Non-advancing I/O is only allowed for formatted - sequential I/O and the next direct access transfer repositions the file - anyway. */ + /* Direct access is prohibited, and so is unformatted stream access. */ + - if (u->flags.access == ACCESS_DIRECT || u->flags.access == ACCESS_STREAM) - goto done; + if (u->flags.access == ACCESS_DIRECT) + { + generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT, + "Cannot BACKSPACE a file opened for DIRECT access"); + goto done; + } + + if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED) + { + generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT, + "Cannot BACKSPACE an unformatted stream file"); + goto done; + } /* Check for special cases involving the ENDFILE record first. */ @@ -215,7 +223,6 @@ st_backspace (st_parameter_filepos *fpp) u->endfile = AT_ENDFILE; u->flags.position = POSITION_APPEND; flush (u->s); - struncate (u->s); } else { @@ -227,6 +234,15 @@ st_backspace (st_parameter_filepos *fpp) if (u->mode == WRITING) { + /* If there are previously written bytes from a write with + ADVANCE="no", add a record marker before performing the + BACKSPACE. */ + + if (u->previous_nonadvancing_write) + finish_last_advance_record (u); + + u->previous_nonadvancing_write = 0; + flush (u->s); struncate (u->s); u->mode = READING; @@ -264,6 +280,22 @@ st_endfile (st_parameter_filepos *fpp) u = find_unit (fpp->common.unit); if (u != NULL) { + if (u->flags.access == ACCESS_DIRECT) + { + generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT, + "Cannot perform ENDFILE on a file opened" + " for DIRECT access"); + goto done; + } + + /* If there are previously written bytes from a write with ADVANCE="no", + add a record marker before performing the ENDFILE. */ + + if (u->previous_nonadvancing_write) + finish_last_advance_record (u); + + u->previous_nonadvancing_write = 0; + if (u->current_record) { st_parameter_dt dtp; @@ -277,6 +309,7 @@ st_endfile (st_parameter_filepos *fpp) struncate (u->s); u->endfile = AFTER_ENDFILE; update_position (u); + done: unlock_unit (u); } @@ -298,10 +331,18 @@ st_rewind (st_parameter_filepos *fpp) if (u != NULL) { if (u->flags.access == ACCESS_DIRECT) - generate_error (&fpp->common, ERROR_BAD_OPTION, + generate_error (&fpp->common, LIBERROR_BAD_OPTION, "Cannot REWIND a file opened for DIRECT access"); else { + /* If there are previously written bytes from a write with ADVANCE="no", + add a record marker before performing the ENDFILE. */ + + if (u->previous_nonadvancing_write) + finish_last_advance_record (u); + + u->previous_nonadvancing_write = 0; + /* Flush the buffers. If we have been writing to the file, the last written record is the last record in the file, so truncate the file now. Reset to read mode so two consecutive rewind @@ -314,7 +355,7 @@ st_rewind (st_parameter_filepos *fpp) u->last_record = 0; if (file_position (u->s) != 0 && sseek (u->s, 0) == FAILURE) - generate_error (&fpp->common, ERROR_OS, NULL); + generate_error (&fpp->common, LIBERROR_OS, NULL); /* Handle special files like /dev/null differently. */ if (!is_special (u->s)) @@ -361,7 +402,7 @@ st_flush (st_parameter_filepos *fpp) } else /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */ - generate_error (&fpp->common, ERROR_BAD_OPTION, + generate_error (&fpp->common, LIBERROR_BAD_OPTION, "Specified UNIT in FLUSH is not connected"); library_end (); diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c index 36ab89b63aa..0f7a2e5bb84 100644 --- a/libgfortran/io/format.c +++ b/libgfortran/io/format.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2002, 2003, 2004, 2005, 2006 +/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -32,11 +32,9 @@ Boston, MA 02110-1301, USA. */ /* format.c-- parse a FORMAT string into a binary format suitable for * interpretation during I/O statements */ -#include "config.h" +#include "io.h" #include <ctype.h> #include <string.h> -#include "libgfortran.h" -#include "io.h" #define FARRAY_SIZE 64 @@ -92,7 +90,7 @@ next_char (format_data *fmt, int literal) fmt->format_string_len--; c = toupper (*fmt->format_string++); } - while (c == ' ' && !literal); + while ((c == ' ' || c == '\t') && !literal); return c; } @@ -915,7 +913,7 @@ format_error (st_parameter_dt *dtp, const fnode *f, const char *message) if (f != NULL) fmt->format_string = f->source; - st_sprintf (buffer, "%s\n", message); + sprintf (buffer, "%s\n", message); j = fmt->format_string - dtp->format; @@ -944,7 +942,7 @@ format_error (st_parameter_dt *dtp, const fnode *f, const char *message) *p++ = '^'; *p = '\0'; - generate_error (&dtp->common, ERROR_FORMAT, buffer); + generate_error (&dtp->common, LIBERROR_FORMAT, buffer); } diff --git a/libgfortran/io/inquire.c b/libgfortran/io/inquire.c index b1f4a14f6c4..ec462858f67 100644 --- a/libgfortran/io/inquire.c +++ b/libgfortran/io/inquire.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc. +/* Copyright (C) 2002, 2003, 2005, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -30,8 +30,6 @@ Boston, MA 02110-1301, USA. */ /* Implement the non-IOLENGTH variant of the INQUIRY statement */ -#include "config.h" -#include "libgfortran.h" #include "io.h" @@ -47,7 +45,18 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) GFC_INTEGER_4 cf = iqp->common.flags; if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0) - *iqp->exist = iqp->common.unit >= 0; + { + *iqp->exist = (iqp->common.unit >= 0 + && iqp->common.unit <= GFC_INTEGER_4_HUGE); + + if ((cf & IOPARM_INQUIRE_HAS_FILE) == 0) + { + if (!(*iqp->exist)) + *iqp->common.iostat = LIBERROR_BAD_UNIT; + *iqp->exist = *iqp->exist + && (*iqp->common.iostat != LIBERROR_BAD_UNIT); + } + } if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0) *iqp->opened = (u != NULL); @@ -90,21 +99,39 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) if (u == NULL) p = inquire_sequential (NULL, 0); else - { - /* disallow an open direct access file to be accessed sequentially */ - if (u->flags.access == ACCESS_DIRECT) - p = "NO"; - else - p = inquire_sequential (u->file, u->file_len); - } + switch (u->flags.access) + { + case ACCESS_DIRECT: + case ACCESS_STREAM: + p = "NO"; + break; + case ACCESS_SEQUENTIAL: + p = "YES"; + break; + default: + internal_error (&iqp->common, "inquire_via_unit(): Bad access"); + } cf_strcpy (iqp->sequential, iqp->sequential_len, p); } if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0) { - p = (u == NULL) ? inquire_direct (NULL, 0) : - inquire_direct (u->file, u->file_len); + if (u == NULL) + p = inquire_direct (NULL, 0); + else + switch (u->flags.access) + { + case ACCESS_SEQUENTIAL: + case ACCESS_STREAM: + p = "NO"; + break; + case ACCESS_DIRECT: + p = "YES"; + break; + default: + internal_error (&iqp->common, "inquire_via_unit(): Bad access"); + } cf_strcpy (iqp->direct, iqp->direct_len, p); } @@ -131,16 +158,40 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0) { - p = (u == NULL) ? inquire_formatted (NULL, 0) : - inquire_formatted (u->file, u->file_len); + if (u == NULL) + p = inquire_formatted (NULL, 0); + else + switch (u->flags.form) + { + case FORM_FORMATTED: + p = "YES"; + break; + case FORM_UNFORMATTED: + p = "NO"; + break; + default: + internal_error (&iqp->common, "inquire_via_unit(): Bad form"); + } cf_strcpy (iqp->formatted, iqp->formatted_len, p); } if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0) { - p = (u == NULL) ? inquire_unformatted (NULL, 0) : - inquire_unformatted (u->file, u->file_len); + if (u == NULL) + p = inquire_unformatted (NULL, 0); + else + switch (u->flags.form) + { + case FORM_FORMATTED: + p = "NO"; + break; + case FORM_UNFORMATTED: + p = "YES"; + break; + default: + internal_error (&iqp->common, "inquire_via_unit(): Bad form"); + } cf_strcpy (iqp->unformatted, iqp->unformatted_len, p); } @@ -304,11 +355,11 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) switch (u->flags.convert) { /* l8_to_l4_offset is 0 for little-endian, 1 for big-endian. */ - case CONVERT_NATIVE: + case GFC_CONVERT_NATIVE: p = l8_to_l4_offset ? "BIG_ENDIAN" : "LITTLE_ENDIAN"; break; - case CONVERT_SWAP: + case GFC_CONVERT_SWAP: p = l8_to_l4_offset ? "LITTLE_ENDIAN" : "BIG_ENDIAN"; break; @@ -350,13 +401,13 @@ inquire_via_filename (st_parameter_inquire *iqp) if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0) { - p = inquire_sequential (iqp->file, iqp->file_len); + p = "UNKNOWN"; cf_strcpy (iqp->sequential, iqp->sequential_len, p); } if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0) { - p = inquire_direct (iqp->file, iqp->file_len); + p = "UNKNOWN"; cf_strcpy (iqp->direct, iqp->direct_len, p); } @@ -365,13 +416,13 @@ inquire_via_filename (st_parameter_inquire *iqp) if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0) { - p = inquire_formatted (iqp->file, iqp->file_len); + p = "UNKNOWN"; cf_strcpy (iqp->formatted, iqp->formatted_len, p); } if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0) { - p = inquire_unformatted (iqp->file, iqp->file_len); + p = "UNKNOWN"; cf_strcpy (iqp->unformatted, iqp->unformatted_len, p); } diff --git a/libgfortran/io/intrinsics.c b/libgfortran/io/intrinsics.c index 2402f486926..03493cf0625 100644 --- a/libgfortran/io/intrinsics.c +++ b/libgfortran/io/intrinsics.c @@ -28,8 +28,7 @@ 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 "config.h" -#include "libgfortran.h" +#include "io.h" #ifdef HAVE_STDLIB_H #include <stdlib.h> @@ -37,8 +36,6 @@ Boston, MA 02110-1301, USA. */ #include <string.h> -#include "io.h" - static const int five = 5; static const int six = 6; diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index a1138cffac0..3e020ec90de 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -31,9 +31,9 @@ Boston, MA 02110-1301, USA. */ /* IO library include. */ -#include <setjmp.h> #include "libgfortran.h" +#include <setjmp.h> #include <gthr.h> /* Basic types used in data transfers. */ @@ -54,7 +54,7 @@ typedef struct stream try (*sfree) (struct stream *); try (*close) (struct stream *); try (*seek) (struct stream *, gfc_offset); - try (*truncate) (struct stream *); + try (*trunc) (struct stream *); int (*read) (struct stream *, void *, size_t *); int (*write) (struct stream *, const void *, size_t *); try (*set) (struct stream *, int, size_t); @@ -74,7 +74,7 @@ stream; #define salloc_w_at(s, len, where) ((s)->alloc_w_at)(s, len, where) #define sseek(s, pos) ((s)->seek)(s, pos) -#define struncate(s) ((s)->truncate)(s) +#define struncate(s) ((s)->trunc)(s) #define sread(s, buf, nbytes) ((s)->read)(s, buf, nbytes) #define swrite(s, buf, nbytes) ((s)->write)(s, buf, nbytes) @@ -451,7 +451,8 @@ typedef struct gfc_unit struct gfc_unit *left, *right; int priority; - int read_bad, current_record, saved_pos; + int read_bad, current_record, saved_pos, previous_nonadvancing_write; + enum { NO_ENDFILE, AT_ENDFILE, AFTER_ENDFILE } endfile; @@ -568,7 +569,7 @@ internal_proto(compare_files); extern stream *open_external (st_parameter_open *, unit_flags *); internal_proto(open_external); -extern stream *open_internal (char *, int); +extern stream *open_internal (char *, int, gfc_offset); internal_proto(open_internal); extern stream *input_stream (void); @@ -692,6 +693,9 @@ internal_proto(unlock_unit); extern void update_position (gfc_unit *); internal_proto(update_position); +extern void finish_last_advance_record (gfc_unit *u); +internal_proto (finish_last_advance_record); + /* open.c */ extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *); @@ -730,10 +734,12 @@ internal_proto(read_sf); extern void *write_block (st_parameter_dt *, int); internal_proto(write_block); -extern gfc_offset next_array_record (st_parameter_dt *, array_loop_spec *); +extern gfc_offset next_array_record (st_parameter_dt *, array_loop_spec *, + int*); internal_proto(next_array_record); -extern gfc_offset init_loop_spec (gfc_array_char *, array_loop_spec *); +extern gfc_offset init_loop_spec (gfc_array_char *, array_loop_spec *, + gfc_offset *); internal_proto(init_loop_spec); extern void next_record (st_parameter_dt *, int); diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index b06b1cab929..f1d0e6961e1 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -29,11 +29,9 @@ the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ -#include "config.h" +#include "io.h" #include <string.h> #include <ctype.h> -#include "libgfortran.h" -#include "io.h" /* List directed input. Several parsing subroutines are practically @@ -173,11 +171,14 @@ next_char (st_parameter_dt *dtp) /* Check for "end-of-record" condition. */ if (dtp->u.p.current_unit->bytes_left == 0) { + int finished; + c = '\n'; - record = next_array_record (dtp, dtp->u.p.current_unit->ls); + record = next_array_record (dtp, dtp->u.p.current_unit->ls, + &finished); /* Check for "end-of-file" condition. */ - if (record == 0) + if (finished) { dtp->u.p.at_eof = 1; goto done; @@ -209,7 +210,7 @@ next_char (st_parameter_dt *dtp) check for NULL here is cautionary. */ if (p == NULL) { - generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL); + generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return '\0'; } @@ -230,12 +231,23 @@ next_char (st_parameter_dt *dtp) { if (p == NULL) { - generate_error (&dtp->common, ERROR_OS, NULL); + generate_error (&dtp->common, LIBERROR_OS, NULL); return '\0'; } if (length == 0) - longjmp (*dtp->u.p.eof_jump, 1); - c = *p; + { + if (dtp->u.p.advance_status == ADVANCE_NO) + { + if (dtp->u.p.current_unit->endfile == AT_ENDFILE) + longjmp (*dtp->u.p.eof_jump, 1); + dtp->u.p.current_unit->endfile = AT_ENDFILE; + c = '\n'; + } + else + longjmp (*dtp->u.p.eof_jump, 1); + } + else + c = *p; } done: dtp->u.p.at_eol = (c == '\n' || c == '\r'); @@ -271,6 +283,20 @@ eat_spaces (st_parameter_dt *dtp) } +/* This function reads characters through to the end of the current line and + just ignores them. */ + +static void +eat_line (st_parameter_dt *dtp) +{ + char c; + if (!is_internal_unit (dtp)) + do + c = next_char (dtp); + while (c != '\n'); +} + + /* Skip over a separator. Technically, we don't always eat the whole separator. This is because if we've processed the last input item, then a separator is unnecessary. Plus the fact that operating @@ -303,15 +329,38 @@ eat_separator (st_parameter_dt *dtp) break; case '\r': + dtp->u.p.at_eol = 1; n = next_char(dtp); if (n == '\n') - dtp->u.p.at_eol = 1; + { + if (dtp->u.p.namelist_mode) + { + do + c = next_char (dtp); + while (c == '\n' || c == '\r' || c == ' '); + unget_char (dtp, c); + } + } else unget_char (dtp, n); break; case '\n': dtp->u.p.at_eol = 1; + if (dtp->u.p.namelist_mode) + { + do + { + c = next_char (dtp); + if (c == '!') + { + eat_line (dtp); + c = next_char (dtp); + } + } + while (c == '\n' || c == '\r' || c == ' '); + unget_char (dtp, c); + } break; case '!': @@ -387,20 +436,6 @@ finish_separator (st_parameter_dt *dtp) } -/* This function reads characters through to the end of the current line and - just ignores them. */ - -static void -eat_line (st_parameter_dt *dtp) -{ - char c; - if (!is_internal_unit (dtp)) - do - c = next_char (dtp); - while (c != '\n'); -} - - /* This function is needed to catch bad conversions so that namelist can attempt to see if dtp->u.p.saved_string contains a new object name rather than a bad value. */ @@ -464,10 +499,10 @@ convert_integer (st_parameter_dt *dtp, int length, int negative) if (dtp->u.p.repeat_count == 0) { - st_sprintf (message, "Zero repeat count in item %d of list input", - dtp->u.p.item_count); + sprintf (message, "Zero repeat count in item %d of list input", + dtp->u.p.item_count); - generate_error (&dtp->common, ERROR_READ_VALUE, message); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); m = 1; } } @@ -477,14 +512,14 @@ convert_integer (st_parameter_dt *dtp, int length, int negative) overflow: if (length == -1) - st_sprintf (message, "Repeat count overflow in item %d of list input", - dtp->u.p.item_count); + sprintf (message, "Repeat count overflow in item %d of list input", + dtp->u.p.item_count); else - st_sprintf (message, "Integer overflow while reading item %d", - dtp->u.p.item_count); + sprintf (message, "Integer overflow while reading item %d", + dtp->u.p.item_count); free_saved (dtp); - generate_error (&dtp->common, ERROR_READ_VALUE, message); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); return 1; } @@ -527,11 +562,11 @@ parse_repeat (st_parameter_dt *dtp) if (repeat > MAX_REPEAT) { - st_sprintf (message, - "Repeat count overflow in item %d of list input", - dtp->u.p.item_count); + sprintf (message, + "Repeat count overflow in item %d of list input", + dtp->u.p.item_count); - generate_error (&dtp->common, ERROR_READ_VALUE, message); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); return 1; } @@ -540,11 +575,11 @@ parse_repeat (st_parameter_dt *dtp) case '*': if (repeat == 0) { - st_sprintf (message, - "Zero repeat count in item %d of list input", - dtp->u.p.item_count); + sprintf (message, + "Zero repeat count in item %d of list input", + dtp->u.p.item_count); - generate_error (&dtp->common, ERROR_READ_VALUE, message); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); return 1; } @@ -563,9 +598,9 @@ parse_repeat (st_parameter_dt *dtp) eat_line (dtp); free_saved (dtp); - st_sprintf (message, "Bad repeat count in item %d of list input", - dtp->u.p.item_count); - generate_error (&dtp->common, ERROR_READ_VALUE, message); + sprintf (message, "Bad repeat count in item %d of list input", + dtp->u.p.item_count); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); return 1; } @@ -708,9 +743,9 @@ read_logical (st_parameter_dt *dtp, int length) eat_line (dtp); free_saved (dtp); - st_sprintf (message, "Bad logical value while reading item %d", + sprintf (message, "Bad logical value while reading item %d", dtp->u.p.item_count); - generate_error (&dtp->common, ERROR_READ_VALUE, message); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); return; logical_done: @@ -840,9 +875,9 @@ read_integer (st_parameter_dt *dtp, int length) eat_line (dtp); free_saved (dtp); - st_sprintf (message, "Bad integer for item %d in list input", + sprintf (message, "Bad integer for item %d in list input", dtp->u.p.item_count); - generate_error (&dtp->common, ERROR_READ_VALUE, message); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); return; @@ -891,9 +926,54 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused))) default: if (dtp->u.p.namelist_mode) { - unget_char (dtp,c); - return; + if (dtp->u.p.current_unit->flags.delim == DELIM_APOSTROPHE + || dtp->u.p.current_unit->flags.delim == DELIM_QUOTE + || c == '&' || c == '$' || c == '/') + { + unget_char (dtp, c); + return; + } + + /* Check to see if we are seeing a namelist object name by using the + line buffer and looking ahead for an '=' or '('. */ + l_push_char (dtp, c); + + int i; + for(i = 0; i < 63; i++) + { + c = next_char (dtp); + if (is_separator(c)) + { + unget_char (dtp, c); + eat_separator (dtp); + c = next_char (dtp); + if (c != '=') + { + l_push_char (dtp, c); + dtp->u.p.item_count = 0; + dtp->u.p.line_buffer_enabled = 1; + goto get_string; + } + } + + l_push_char (dtp, c); + + if (c == '=' || c == '(') + { + dtp->u.p.item_count = 0; + dtp->u.p.nml_read_error = 1; + dtp->u.p.line_buffer_enabled = 1; + return; + } + } + + /* The string is too long to be a valid object name so assume that it + is a string to be read in as a value. */ + dtp->u.p.item_count = 0; + dtp->u.p.line_buffer_enabled = 1; + goto get_string; } + push_char (dtp, c); goto get_string; } @@ -1000,13 +1080,14 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused))) unget_char (dtp, c); eat_separator (dtp); dtp->u.p.saved_type = BT_CHARACTER; + free_line (dtp); } else { free_saved (dtp); - st_sprintf (message, "Invalid string input in item %d", + sprintf (message, "Invalid string input in item %d", dtp->u.p.item_count); - generate_error (&dtp->common, ERROR_READ_VALUE, message); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); } } @@ -1028,7 +1109,12 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length) } if (!isdigit (c) && c != '.') - goto bad; + { + if (c == 'i' || c == 'I' || c == 'n' || c == 'N') + goto inf_nan; + else + goto bad; + } push_char (dtp, c); @@ -1087,6 +1173,7 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length) exp2: if (!isdigit (c)) goto bad; + push_char (dtp, c); for (;;) @@ -1116,6 +1203,41 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length) return m; + inf_nan: + /* Match INF and Infinity. */ + if ((c == 'i' || c == 'I') + && ((c = next_char (dtp)) == 'n' || c == 'N') + && ((c = next_char (dtp)) == 'f' || c == 'F')) + { + c = next_char (dtp); + if ((c != 'i' && c != 'I') + || ((c == 'i' || c == 'I') + && ((c = next_char (dtp)) == 'n' || c == 'N') + && ((c = next_char (dtp)) == 'i' || c == 'I') + && ((c = next_char (dtp)) == 't' || c == 'T') + && ((c = next_char (dtp)) == 'y' || c == 'Y') + && (c = next_char (dtp)))) + { + if (is_separator (c)) + unget_char (dtp, c); + push_char (dtp, 'i'); + push_char (dtp, 'n'); + push_char (dtp, 'f'); + goto done; + } + } /* Match NaN. */ + else if (((c = next_char (dtp)) == 'a' || c == 'A') + && ((c = next_char (dtp)) == 'n' || c == 'N') + && (c = next_char (dtp))) + { + if (is_separator (c)) + unget_char (dtp, c); + push_char (dtp, 'n'); + push_char (dtp, 'a'); + push_char (dtp, 'n'); + goto done; + } + bad: if (nml_bad_return (dtp, c)) @@ -1123,9 +1245,9 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length) eat_line (dtp); free_saved (dtp); - st_sprintf (message, "Bad floating point number for item %d", + sprintf (message, "Bad floating point number for item %d", dtp->u.p.item_count); - generate_error (&dtp->common, ERROR_READ_VALUE, message); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); return 1; } @@ -1206,9 +1328,9 @@ eol_2: eat_line (dtp); free_saved (dtp); - st_sprintf (message, "Bad complex value in item %d of list input", + sprintf (message, "Bad complex value in item %d of list input", dtp->u.p.item_count); - generate_error (&dtp->common, ERROR_READ_VALUE, message); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); } @@ -1219,6 +1341,7 @@ read_real (st_parameter_dt *dtp, int length) { char c, message[100]; int seen_dp; + int is_inf; seen_dp = 0; @@ -1243,6 +1366,12 @@ read_real (st_parameter_dt *dtp, int length) eat_separator (dtp); return; + case 'i': + case 'I': + case 'n': + case 'N': + goto inf_nan; + default: goto bad_real; } @@ -1317,7 +1446,12 @@ read_real (st_parameter_dt *dtp, int length) } if (!isdigit (c) && c != '.') - goto bad_real; + { + if (c == 'i' || c == 'I' || c == 'n' || c == 'N') + goto inf_nan; + else + goto bad_real; + } if (c == '.') { @@ -1414,6 +1548,107 @@ read_real (st_parameter_dt *dtp, int length) dtp->u.p.saved_type = BT_REAL; return; + inf_nan: + l_push_char (dtp, c); + is_inf = 0; + + /* Match INF and Infinity. */ + if (c == 'i' || c == 'I') + { + c = next_char (dtp); + l_push_char (dtp, c); + if (c != 'n' && c != 'N') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + if (c != 'f' && c != 'F') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + if (!is_separator (c)) + { + if (c != 'i' && c != 'I') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + if (c != 'n' && c != 'N') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + if (c != 'i' && c != 'I') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + if (c != 't' && c != 'T') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + if (c != 'y' && c != 'Y') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + } + is_inf = 1; + } /* Match NaN. */ + else + { + c = next_char (dtp); + l_push_char (dtp, c); + if (c != 'a' && c != 'A') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + if (c != 'n' && c != 'N') + goto unwind; + c = next_char (dtp); + l_push_char (dtp, c); + } + + if (!is_separator (c)) + goto unwind; + + if (dtp->u.p.namelist_mode) + { + if (c == ' ' || c =='\n' || c == '\r') + { + do + c = next_char (dtp); + while (c == ' ' || c =='\n' || c == '\r'); + + l_push_char (dtp, c); + + if (c == '=') + goto unwind; + } + } + + if (is_inf) + { + push_char (dtp, 'i'); + push_char (dtp, 'n'); + push_char (dtp, 'f'); + } + else + { + push_char (dtp, 'n'); + push_char (dtp, 'a'); + push_char (dtp, 'n'); + } + + dtp->u.p.item_count = 0; + dtp->u.p.line_buffer_enabled = 0; + free_line (dtp); + goto done; + + unwind: + if (dtp->u.p.namelist_mode) + { + dtp->u.p.nml_read_error = 1; + dtp->u.p.line_buffer_enabled = 1; + dtp->u.p.item_count = 0; + return; + } + bad_real: if (nml_bad_return (dtp, c)) @@ -1421,9 +1656,9 @@ read_real (st_parameter_dt *dtp, int length) eat_line (dtp); free_saved (dtp); - st_sprintf (message, "Bad real number in item %d of list input", + sprintf (message, "Bad real number in item %d of list input", dtp->u.p.item_count); - generate_error (&dtp->common, ERROR_READ_VALUE, message); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); } @@ -1437,11 +1672,11 @@ check_type (st_parameter_dt *dtp, bt type, int len) if (dtp->u.p.saved_type != BT_NULL && dtp->u.p.saved_type != type) { - st_sprintf (message, "Read type %s where %s was expected for item %d", + sprintf (message, "Read type %s where %s was expected for item %d", type_name (dtp->u.p.saved_type), type_name (type), dtp->u.p.item_count); - generate_error (&dtp->common, ERROR_READ_VALUE, message); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); return 1; } @@ -1450,11 +1685,11 @@ check_type (st_parameter_dt *dtp, bt type, int len) if (dtp->u.p.saved_length != len) { - st_sprintf (message, + sprintf (message, "Read kind %d %s where kind %d is required for item %d", dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len, dtp->u.p.item_count); - generate_error (&dtp->common, ERROR_READ_VALUE, message); + generate_error (&dtp->common, LIBERROR_READ_VALUE, message); return 1; } @@ -1480,7 +1715,7 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, dtp->u.p.eof_jump = &eof_jump; if (setjmp (eof_jump)) { - generate_error (&dtp->common, ERROR_END, NULL); + generate_error (&dtp->common, LIBERROR_END, NULL); goto cleanup; } @@ -1666,18 +1901,27 @@ calls: static try nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad, - array_loop_spec *ls, int rank, char *parse_err_msg) + array_loop_spec *ls, int rank, char *parse_err_msg, + int *parsed_rank) { int dim; int indx; int neg; int null_flag; - int is_array_section; + int is_array_section, is_char; char c; + is_char = 0; is_array_section = 0; dtp->u.p.expanded_read = 0; + /* See if this is a character substring qualifier we are looking for. */ + if (rank == -1) + { + rank = 1; + is_char = 1; + } + /* The next character in the stream should be the '('. */ c = next_char (dtp); @@ -1723,8 +1967,10 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad, if ((c==',' && dim == rank -1) || (c==')' && dim < rank -1)) { - st_sprintf (parse_err_msg, - "Bad number of index fields"); + if (is_char) + sprintf (parse_err_msg, "Bad substring qualifier"); + else + sprintf (parse_err_msg, "Bad number of index fields"); goto err_ret; } break; @@ -1739,21 +1985,38 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad, break; default: - st_sprintf (parse_err_msg, "Bad character in index"); + if (is_char) + sprintf (parse_err_msg, + "Bad character in substring qualifier"); + else + sprintf (parse_err_msg, "Bad character in index"); goto err_ret; } if ((c == ',' || c == ')') && indx == 0 && dtp->u.p.saved_string == 0) { - st_sprintf (parse_err_msg, "Null index field"); + if (is_char) + sprintf (parse_err_msg, "Null substring qualifier"); + else + sprintf (parse_err_msg, "Null index field"); goto err_ret; } if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0) || (indx == 2 && dtp->u.p.saved_string == 0)) { - st_sprintf(parse_err_msg, "Bad index triplet"); + if (is_char) + sprintf (parse_err_msg, "Bad substring qualifier"); + else + sprintf (parse_err_msg, "Bad index triplet"); + goto err_ret; + } + + if (is_char && !is_array_section) + { + sprintf (parse_err_msg, + "Missing colon in substring qualifier"); goto err_ret; } @@ -1769,7 +2032,10 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad, /* Now read the index. */ if (convert_integer (dtp, sizeof(ssize_t), neg)) { - st_sprintf (parse_err_msg, "Bad integer in index"); + if (is_char) + sprintf (parse_err_msg, "Bad integer substring qualifier"); + else + sprintf (parse_err_msg, "Bad integer in index"); goto err_ret; } break; @@ -1801,6 +2067,11 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad, else dtp->u.p.expanded_read = 1; } + + /* Check for non-zero rank. */ + if (is_array_section == 1 && ls[dim].start != ls[dim].end) + *parsed_rank = 1; + break; } } @@ -1811,13 +2082,17 @@ nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad, || (ls[dim].end > (ssize_t)ad[dim].ubound) || (ls[dim].end < (ssize_t)ad[dim].lbound)) { - st_sprintf (parse_err_msg, "Index %d out of range", dim + 1); + if (is_char) + sprintf (parse_err_msg, "Substring out of range"); + else + sprintf (parse_err_msg, "Index %d out of range", dim + 1); goto err_ret; } + if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0) || (ls[dim].step == 0)) { - st_sprintf (parse_err_msg, "Bad range in index %d", dim + 1); + sprintf (parse_err_msg, "Bad range in index %d", dim + 1); goto err_ret; } @@ -1948,7 +2223,6 @@ nml_query (st_parameter_dt *dtp, char c) else { - /* "&namelist_name\n" */ len = dtp->namelist_name_len; @@ -1968,7 +2242,6 @@ nml_query (st_parameter_dt *dtp, char c) #endif for (nl = dtp->u.p.ionml; nl; nl = nl->next) { - /* " var_name\n" */ len = strlen (nl->var_name); @@ -2034,7 +2307,6 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset, namelist_info **pprev_nl, char *nml_err_msg, index_type clow, index_type chigh) { - namelist_info * cmp; char * obj_name; int nml_carry; @@ -2056,7 +2328,6 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset, len = nl->len; switch (nl->type) { - case GFC_DTYPE_INTEGER: case GFC_DTYPE_LOGICAL: dlen = len; @@ -2080,7 +2351,6 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset, do { - /* Update the pointer to the data, using the current index vector */ pdata = (void*)(nl->mem_pos + offset); @@ -2171,7 +2441,7 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset, goto incr_idx; default: - st_sprintf (nml_err_msg, "Bad type for namelist object %s", + sprintf (nml_err_msg, "Bad type for namelist object %s", nl->var_name); internal_error (&dtp->common, nml_err_msg); goto nml_err_ret; @@ -2260,7 +2530,7 @@ incr_idx: if (dtp->u.p.repeat_count > 1) { - st_sprintf (nml_err_msg, "Repeat count too large for namelist object %s" , + sprintf (nml_err_msg, "Repeat count too large for namelist object %s" , nl->var_name ); goto nml_err_ret; } @@ -2286,10 +2556,11 @@ nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl, namelist_info * nl; namelist_info * first_nl = NULL; namelist_info * root_nl = NULL; - int dim; + int dim, parsed_rank; int component_flag; char parse_err_msg[30]; index_type clow, chigh; + int non_zero_rank_count; /* Look for end of input or object name. If '?' or '=?' are encountered in stdin, print the node names or the namelist to stdout. */ @@ -2310,7 +2581,7 @@ nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl, c = next_char (dtp); if (c != '?') { - st_sprintf (nml_err_msg, "namelist read: misplaced = sign"); + sprintf (nml_err_msg, "namelist read: misplaced = sign"); goto nml_err_ret; } nml_query (dtp, '='); @@ -2325,7 +2596,7 @@ nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl, nml_match_name (dtp, "end", 3); if (dtp->u.p.nml_read_error) { - st_sprintf (nml_err_msg, "namelist not terminated with / or &end"); + sprintf (nml_err_msg, "namelist not terminated with / or &end"); goto nml_err_ret; } case '/': @@ -2341,6 +2612,7 @@ nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl, nml_untouch_nodes (dtp); component_flag = 0; + non_zero_rank_count = 0; /* Get the object name - should '!' and '\n' be permitted separators? */ @@ -2350,7 +2622,8 @@ get_name: do { - push_char (dtp, tolower(c)); + if (!is_separator (c)) + push_char (dtp, tolower(c)); c = next_char (dtp); } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' )); @@ -2384,11 +2657,11 @@ get_name: if (nl == NULL) { if (dtp->u.p.nml_read_error && *pprev_nl) - st_sprintf (nml_err_msg, "Bad data for namelist object %s", + sprintf (nml_err_msg, "Bad data for namelist object %s", (*pprev_nl)->var_name); else - st_sprintf (nml_err_msg, "Cannot match namelist object name %s", + sprintf (nml_err_msg, "Cannot match namelist object name %s", dtp->u.p.saved_string); goto nml_err_ret; @@ -2409,16 +2682,23 @@ get_name: if (c == '(' && nl->var_rank) { + parsed_rank = 0; if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank, - parse_err_msg) == FAILURE) + parse_err_msg, &parsed_rank) == FAILURE) { - st_sprintf (nml_err_msg, "%s for namelist variable %s", + sprintf (nml_err_msg, "%s for namelist variable %s", parse_err_msg, nl->var_name); goto nml_err_ret; } + + if (parsed_rank > 0) + non_zero_rank_count++; + c = next_char (dtp); unget_char (dtp, c); } + else if (nl->var_rank > 0) + non_zero_rank_count++; /* Now parse a derived type component. The root namelist_info address is backed up, as is the previous component level. The component flag @@ -2426,10 +2706,9 @@ get_name: if (c == '%') { - if (nl->type != GFC_DTYPE_DERIVED) { - st_sprintf (nml_err_msg, "Attempt to get derived component for %s", + sprintf (nml_err_msg, "Attempt to get derived component for %s", nl->var_name); goto nml_err_ret; } @@ -2441,7 +2720,6 @@ get_name: component_flag = 1; c = next_char (dtp); goto get_name; - } /* Parse a character qualifier, if present. chigh = 0 is a default @@ -2455,9 +2733,10 @@ get_name: descriptor_dimension chd[1] = { {1, clow, nl->string_length} }; array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} }; - if (nml_parse_qualifier (dtp, chd, ind, 1, parse_err_msg) == FAILURE) + if (nml_parse_qualifier (dtp, chd, ind, -1, parse_err_msg, &parsed_rank) + == FAILURE) { - st_sprintf (nml_err_msg, "%s for namelist variable %s", + sprintf (nml_err_msg, "%s for namelist variable %s", parse_err_msg, nl->var_name); goto nml_err_ret; } @@ -2467,9 +2746,9 @@ get_name: if (ind[0].step != 1) { - st_sprintf (nml_err_msg, - "Bad step in substring for namelist object %s", - nl->var_name); + sprintf (nml_err_msg, + "Step not allowed in substring qualifier" + " for namelist object %s", nl->var_name); goto nml_err_ret; } @@ -2486,15 +2765,24 @@ get_name: if (component_flag) nl = first_nl; - /*make sure no extraneous qualifiers are there.*/ + /* Make sure no extraneous qualifiers are there. */ if (c == '(') { - st_sprintf (nml_err_msg, "Qualifier for a scalar or non-character" + sprintf (nml_err_msg, "Qualifier for a scalar or non-character" " namelist object %s", nl->var_name); goto nml_err_ret; } + /* Make sure there is no more than one non-zero rank object. */ + if (non_zero_rank_count > 1) + { + sprintf (nml_err_msg, "Multiple sub-objects with non-zero rank in" + " namelist object %s", nl->var_name); + non_zero_rank_count = 0; + goto nml_err_ret; + } + /* According to the standard, an equal sign MUST follow an object name. The following is possibly lax - it allows comments, blank lines and so on to intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/ @@ -2514,7 +2802,7 @@ get_name: if (c != '=') { - st_sprintf (nml_err_msg, "Equal sign must follow namelist object name %s", + sprintf (nml_err_msg, "Equal sign must follow namelist object name %s", nl->var_name); goto nml_err_ret; } @@ -2552,7 +2840,7 @@ namelist_read (st_parameter_dt *dtp) if (setjmp (eof_jump)) { dtp->u.p.eof_jump = NULL; - generate_error (&dtp->common, ERROR_END, NULL); + generate_error (&dtp->common, LIBERROR_END, NULL); return; } @@ -2593,6 +2881,14 @@ find_nml_name: if (dtp->u.p.nml_read_error) goto find_nml_name; + /* A trailing space is required, we give a little lattitude here, 10.9.1. */ + c = next_char (dtp); + if (!is_separator(c)) + { + unget_char (dtp, c); + goto find_nml_name; + } + /* Ready to read namelist objects. If there is an error in input from stdin, output the error message and continue. */ @@ -2628,6 +2924,6 @@ nml_err_ret: dtp->u.p.eof_jump = NULL; free_saved (dtp); free_line (dtp); - generate_error (&dtp->common, ERROR_READ_VALUE, nml_err_msg); + generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg); return; } diff --git a/libgfortran/io/lock.c b/libgfortran/io/lock.c index 39bb67090d8..88aed00165c 100644 --- a/libgfortran/io/lock.c +++ b/libgfortran/io/lock.c @@ -1,5 +1,5 @@ /* Thread/recursion locking - Copyright 2002, 2003, 2004, 2005 Free Software Foundation, Inc. + Copyright 2002, 2003, 2004, 2005, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> and Andy Vaught This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,8 @@ 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 "config.h" -#include <string.h> -#include "libgfortran.h" #include "io.h" +#include <string.h> /* library_start()-- Called with a library call is entered. */ diff --git a/libgfortran/io/open.c b/libgfortran/io/open.c index 68be74b978f..0a409ed4ad3 100644 --- a/libgfortran/io/open.c +++ b/libgfortran/io/open.c @@ -28,13 +28,10 @@ along with Libgfortran; see the file COPYING. If not, write to the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ -#include "config.h" +#include "io.h" #include <unistd.h> -#include <stdio.h> #include <string.h> #include <errno.h> -#include "libgfortran.h" -#include "io.h" static const st_option access_opt[] = { @@ -102,10 +99,10 @@ static const st_option pad_opt[] = static const st_option convert_opt[] = { - { "native", CONVERT_NATIVE}, - { "swap", CONVERT_SWAP}, - { "big_endian", CONVERT_BIG}, - { "little_endian", CONVERT_LITTLE}, + { "native", GFC_CONVERT_NATIVE}, + { "swap", GFC_CONVERT_SWAP}, + { "big_endian", GFC_CONVERT_BIG}, + { "little_endian", GFC_CONVERT_LITTLE}, { NULL, 0} }; @@ -133,24 +130,24 @@ edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags) if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD && u->flags.status != flags->status) - generate_error (&opp->common, ERROR_BAD_OPTION, + generate_error (&opp->common, LIBERROR_BAD_OPTION, "Cannot change STATUS parameter in OPEN statement"); if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access) - generate_error (&opp->common, ERROR_BAD_OPTION, + generate_error (&opp->common, LIBERROR_BAD_OPTION, "Cannot change ACCESS parameter in OPEN statement"); if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form) - generate_error (&opp->common, ERROR_BAD_OPTION, + generate_error (&opp->common, LIBERROR_BAD_OPTION, "Cannot change FORM parameter in OPEN statement"); if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in != u->recl) - generate_error (&opp->common, ERROR_BAD_OPTION, + generate_error (&opp->common, LIBERROR_BAD_OPTION, "Cannot change RECL parameter in OPEN statement"); if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action) - generate_error (&opp->common, ERROR_BAD_OPTION, + generate_error (&opp->common, LIBERROR_BAD_OPTION, "Cannot change ACTION parameter in OPEN statement"); /* Status must be OLD if present. */ @@ -162,24 +159,24 @@ edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags) notify_std (&opp->common, GFC_STD_GNU, "OPEN statement must have a STATUS of OLD or UNKNOWN"); else - generate_error (&opp->common, ERROR_BAD_OPTION, + generate_error (&opp->common, LIBERROR_BAD_OPTION, "OPEN statement must have a STATUS of OLD or UNKNOWN"); } if (u->flags.form == FORM_UNFORMATTED) { if (flags->delim != DELIM_UNSPECIFIED) - generate_error (&opp->common, ERROR_OPTION_CONFLICT, + generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, "DELIM parameter conflicts with UNFORMATTED form in " "OPEN statement"); if (flags->blank != BLANK_UNSPECIFIED) - generate_error (&opp->common, ERROR_OPTION_CONFLICT, + generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, "BLANK parameter conflicts with UNFORMATTED form in " "OPEN statement"); if (flags->pad != PAD_UNSPECIFIED) - generate_error (&opp->common, ERROR_OPTION_CONFLICT, + generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, "PAD parameter conflicts with UNFORMATTED form in " "OPEN statement"); } @@ -224,7 +221,7 @@ edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags) break; seek_error: - generate_error (&opp->common, ERROR_OS, NULL); + generate_error (&opp->common, LIBERROR_OS, NULL); break; } @@ -259,7 +256,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags) { if (flags->form == FORM_UNFORMATTED) { - generate_error (&opp->common, ERROR_OPTION_CONFLICT, + generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, "DELIM parameter conflicts with UNFORMATTED form in " "OPEN statement"); goto fail; @@ -272,7 +269,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags) { if (flags->form == FORM_UNFORMATTED) { - generate_error (&opp->common, ERROR_OPTION_CONFLICT, + generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, "BLANK parameter conflicts with UNFORMATTED form in " "OPEN statement"); goto fail; @@ -285,7 +282,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags) { if (flags->form == FORM_UNFORMATTED) { - generate_error (&opp->common, ERROR_OPTION_CONFLICT, + generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, "PAD parameter conflicts with UNFORMATTED form in " "OPEN statement"); goto fail; @@ -294,7 +291,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags) if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT) { - generate_error (&opp->common, ERROR_OPTION_CONFLICT, + generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, "ACCESS parameter conflicts with SEQUENTIAL access in " "OPEN statement"); goto fail; @@ -312,14 +309,14 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags) if (flags->access == ACCESS_DIRECT && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0) { - generate_error (&opp->common, ERROR_MISSING_OPTION, + generate_error (&opp->common, LIBERROR_MISSING_OPTION, "Missing RECL parameter in OPEN statement"); goto fail; } if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0) { - generate_error (&opp->common, ERROR_BAD_OPTION, + generate_error (&opp->common, LIBERROR_BAD_OPTION, "RECL parameter is non-positive in OPEN statement"); goto fail; } @@ -333,7 +330,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags) break; } - generate_error (&opp->common, ERROR_BAD_OPTION, + generate_error (&opp->common, LIBERROR_BAD_OPTION, "FILE parameter must not be present in OPEN statement"); goto fail; @@ -369,7 +366,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags) && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit)) { unlock_unit (u2); - generate_error (&opp->common, ERROR_ALREADY_OPEN, NULL); + generate_error (&opp->common, LIBERROR_ALREADY_OPEN, NULL); goto cleanup; } @@ -389,26 +386,26 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags) switch (errno) { case ENOENT: - st_sprintf (msg, "File '%s' does not exist", path); + sprintf (msg, "File '%s' does not exist", path); break; case EEXIST: - st_sprintf (msg, "File '%s' already exists", path); + sprintf (msg, "File '%s' already exists", path); break; case EACCES: - st_sprintf (msg, "Permission denied trying to open file '%s'", path); + sprintf (msg, "Permission denied trying to open file '%s'", path); break; case EISDIR: - st_sprintf (msg, "'%s' is a directory", path); + sprintf (msg, "'%s' is a directory", path); break; default: msg = NULL; } - generate_error (&opp->common, ERROR_OS, msg); + generate_error (&opp->common, LIBERROR_OS, msg); goto cleanup; } @@ -434,7 +431,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags) if (flags->position == POSITION_APPEND) { if (sseek (u->s, file_length (u->s)) == FAILURE) - generate_error (&opp->common, ERROR_OS, NULL); + generate_error (&opp->common, LIBERROR_OS, NULL); u->endfile = AT_ENDFILE; } @@ -547,7 +544,7 @@ already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags) if (sclose (u->s) == FAILURE) { unlock_unit (u); - generate_error (&opp->common, ERROR_OS, + generate_error (&opp->common, LIBERROR_OS, "Error closing file in OPEN statement"); return; } @@ -627,7 +624,7 @@ st_open (st_parameter_open *opp) conv = get_unformatted_convert (opp->common.unit); - if (conv == CONVERT_NONE) + if (conv == GFC_CONVERT_NONE) { /* Nothing has been set by environment variable, check the convert tag. */ if (cf & IOPARM_OPEN_HAS_CONVERT) @@ -642,16 +639,16 @@ st_open (st_parameter_open *opp) and 1 on big-endian machines. */ switch (conv) { - case CONVERT_NATIVE: - case CONVERT_SWAP: + case GFC_CONVERT_NATIVE: + case GFC_CONVERT_SWAP: break; - case CONVERT_BIG: - conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP; + case GFC_CONVERT_BIG: + conv = l8_to_l4_offset ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP; break; - case CONVERT_LITTLE: - conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE; + case GFC_CONVERT_LITTLE: + conv = l8_to_l4_offset ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE; break; default: @@ -662,19 +659,19 @@ st_open (st_parameter_open *opp) flags.convert = conv; if (opp->common.unit < 0) - generate_error (&opp->common, ERROR_BAD_OPTION, + generate_error (&opp->common, LIBERROR_BAD_OPTION, "Bad unit number in OPEN statement"); if (flags.position != POSITION_UNSPECIFIED && flags.access == ACCESS_DIRECT) - generate_error (&opp->common, ERROR_BAD_OPTION, + generate_error (&opp->common, LIBERROR_BAD_OPTION, "Cannot use POSITION with direct access files"); if (flags.access == ACCESS_APPEND) { if (flags.position != POSITION_UNSPECIFIED && flags.position != POSITION_APPEND) - generate_error (&opp->common, ERROR_BAD_OPTION, + generate_error (&opp->common, LIBERROR_BAD_OPTION, "Conflicting ACCESS and POSITION flags in" " OPEN statement"); diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c index 0f7d9a6dcfc..b5f16ac7260 100644 --- a/libgfortran/io/read.c +++ b/libgfortran/io/read.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc. +/* Copyright (C) 2002, 2003, 2005, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -27,15 +27,11 @@ along with Libgfortran; see the file COPYING. If not, write to the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ - -#include "config.h" +#include "io.h" #include <string.h> #include <errno.h> #include <ctype.h> #include <stdlib.h> -#include <stdio.h> -#include "libgfortran.h" -#include "io.h" /* read.c -- Deal with formatted reads */ @@ -179,8 +175,9 @@ convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length) if (errno == EINVAL) { - generate_error (&dtp->common, ERROR_READ_VALUE, + generate_error (&dtp->common, LIBERROR_READ_VALUE, "Error during floating point read"); + next_record (dtp, 1); return 1; } @@ -227,8 +224,9 @@ read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length) break; default: bad: - generate_error (&dtp->common, ERROR_READ_VALUE, + generate_error (&dtp->common, LIBERROR_READ_VALUE, "Bad value on logical read"); + next_record (dtp, 1); break; } } @@ -397,13 +395,15 @@ read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length) return; bad: - generate_error (&dtp->common, ERROR_READ_VALUE, + generate_error (&dtp->common, LIBERROR_READ_VALUE, "Bad value during integer read"); + next_record (dtp, 1); return; overflow: - generate_error (&dtp->common, ERROR_READ_OVERFLOW, + generate_error (&dtp->common, LIBERROR_READ_OVERFLOW, "Value overflowed during integer read"); + next_record (dtp, 1); return; } @@ -541,13 +541,15 @@ read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length, return; bad: - generate_error (&dtp->common, ERROR_READ_VALUE, + generate_error (&dtp->common, LIBERROR_READ_VALUE, "Bad value during integer read"); + next_record (dtp, 1); return; overflow: - generate_error (&dtp->common, ERROR_READ_OVERFLOW, + generate_error (&dtp->common, LIBERROR_READ_OVERFLOW, "Value overflowed during integer read"); + next_record (dtp, 1); return; } @@ -661,8 +663,9 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length) goto done; bad_float: - generate_error (&dtp->common, ERROR_READ_VALUE, + generate_error (&dtp->common, LIBERROR_READ_VALUE, "Bad value during floating point read"); + next_record (dtp, 1); return; /* The value read is zero */ diff --git a/libgfortran/io/size_from_kind.c b/libgfortran/io/size_from_kind.c index 033b554c614..882c6776c93 100644 --- a/libgfortran/io/size_from_kind.c +++ b/libgfortran/io/size_from_kind.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2005 Free Software Foundation, Inc. +/* Copyright (C) 2005, 2007 Free Software Foundation, Inc. Contributed by Janne Blomqvist This file is part of the GNU Fortran runtime library (libgfortran). @@ -31,8 +31,6 @@ Boston, MA 02110-1301, USA. */ /* This file contains utility functions for determining the size of a variable given its kind. */ -#include "config.h" -#include "libgfortran.h" #include "io.h" size_t diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 3feae04df59..52c6314349d 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -32,11 +32,9 @@ Boston, MA 02110-1301, USA. */ /* transfer.c -- Top level handling of data transfer statements. */ -#include "config.h" +#include "io.h" #include <string.h> #include <assert.h> -#include "libgfortran.h" -#include "io.h" /* Calling conventions: Data transfer statements are unlike other @@ -168,7 +166,14 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error) { readlen = *length; q = salloc_r (dtp->u.p.current_unit->s, &readlen); - memcpy (p, q, readlen); + if (readlen < *length) + { + generate_error (&dtp->common, LIBERROR_END, NULL); + return NULL; + } + + if (q != NULL) + memcpy (p, q, readlen); goto done; } @@ -187,7 +192,7 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error) { if (no_error) break; - generate_error (&dtp->common, ERROR_END, NULL); + generate_error (&dtp->common, LIBERROR_END, NULL); return NULL; } @@ -220,7 +225,7 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error) { if (no_error) break; - generate_error (&dtp->common, ERROR_EOR, NULL); + generate_error (&dtp->common, LIBERROR_EOR, NULL); return NULL; } @@ -274,10 +279,12 @@ read_block (st_parameter_dt *dtp, int *length) if (is_stream_io (dtp)) { - if (sseek (dtp->u.p.current_unit->s, - dtp->u.p.current_unit->strm_pos - 1) == FAILURE) + if (dtp->u.p.current_unit->strm_pos - 1 + != file_position (dtp->u.p.current_unit->s) + && sseek (dtp->u.p.current_unit->s, + dtp->u.p.current_unit->strm_pos - 1) == FAILURE) { - generate_error (&dtp->common, ERROR_END, NULL); + generate_error (&dtp->common, LIBERROR_END, NULL); return NULL; } } @@ -295,7 +302,7 @@ read_block (st_parameter_dt *dtp, int *length) if (dtp->u.p.current_unit->flags.pad == PAD_NO) { /* Not enough data left. */ - generate_error (&dtp->common, ERROR_EOR, NULL); + generate_error (&dtp->common, LIBERROR_EOR, NULL); return NULL; } } @@ -303,7 +310,7 @@ read_block (st_parameter_dt *dtp, int *length) if (dtp->u.p.current_unit->bytes_left == 0) { dtp->u.p.current_unit->endfile = AT_ENDFILE; - generate_error (&dtp->common, ERROR_END, NULL); + generate_error (&dtp->common, LIBERROR_END, NULL); return NULL; } @@ -334,7 +341,7 @@ read_block (st_parameter_dt *dtp, int *length) *length = nread; else { - generate_error (&dtp->common, ERROR_EOR, NULL); + generate_error (&dtp->common, LIBERROR_EOR, NULL); source = NULL; } } @@ -359,10 +366,12 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) if (is_stream_io (dtp)) { - if (sseek (dtp->u.p.current_unit->s, - dtp->u.p.current_unit->strm_pos - 1) == FAILURE) + if (dtp->u.p.current_unit->strm_pos - 1 + != file_position (dtp->u.p.current_unit->s) + && sseek (dtp->u.p.current_unit->s, + dtp->u.p.current_unit->strm_pos - 1) == FAILURE) { - generate_error (&dtp->common, ERROR_END, NULL); + generate_error (&dtp->common, LIBERROR_END, NULL); return; } @@ -370,7 +379,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) have_read_record = to_read_record; if (sread (dtp->u.p.current_unit->s, buf, &have_read_record) != 0) { - generate_error (&dtp->common, ERROR_OS, NULL); + generate_error (&dtp->common, LIBERROR_OS, NULL); return; } @@ -380,7 +389,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) { /* Short read, e.g. if we hit EOF. For stream files, we have to set the end-of-file condition. */ - generate_error (&dtp->common, ERROR_END, NULL); + generate_error (&dtp->common, LIBERROR_END, NULL); return; } return; @@ -405,7 +414,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) if (sread (dtp->u.p.current_unit->s, buf, &to_read_record) != 0) { - generate_error (&dtp->common, ERROR_OS, NULL); + generate_error (&dtp->common, LIBERROR_OS, NULL); return; } @@ -419,7 +428,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) if (short_record) { - generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL); + generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); return; } return; @@ -431,7 +440,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) if (dtp->u.p.current_unit->endfile == AT_ENDFILE) { - generate_error (&dtp->common, ERROR_END, NULL); + generate_error (&dtp->common, LIBERROR_END, NULL); return; } @@ -470,7 +479,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) if (sread (dtp->u.p.current_unit->s, buf + have_read_record, &have_read_subrecord) != 0) { - generate_error (&dtp->common, ERROR_OS, NULL); + generate_error (&dtp->common, LIBERROR_OS, NULL); return; } @@ -484,7 +493,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) marker would still be present. */ *nbytes = have_read_record; - generate_error (&dtp->common, ERROR_CORRUPT_FILE, NULL); + generate_error (&dtp->common, LIBERROR_CORRUPT_FILE, NULL); return; } @@ -502,7 +511,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) dtp->u.p.current_unit->current_record = 0; next_record_r_unf (dtp, 0); - generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL); + generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); return; } } @@ -516,7 +525,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) dtp->u.p.current_unit->bytes_left -= have_read_record; if (short_record) { - generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL); + generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); return; } return; @@ -535,10 +544,12 @@ write_block (st_parameter_dt *dtp, int length) if (is_stream_io (dtp)) { - if (sseek (dtp->u.p.current_unit->s, - dtp->u.p.current_unit->strm_pos - 1) == FAILURE) + if (dtp->u.p.current_unit->strm_pos - 1 + != file_position (dtp->u.p.current_unit->s) + && sseek (dtp->u.p.current_unit->s, + dtp->u.p.current_unit->strm_pos - 1) == FAILURE) { - generate_error (&dtp->common, ERROR_OS, NULL); + generate_error (&dtp->common, LIBERROR_OS, NULL); return NULL; } } @@ -554,7 +565,7 @@ write_block (st_parameter_dt *dtp, int length) dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; else { - generate_error (&dtp->common, ERROR_EOR, NULL); + generate_error (&dtp->common, LIBERROR_EOR, NULL); return NULL; } } @@ -566,12 +577,12 @@ write_block (st_parameter_dt *dtp, int length) if (dest == NULL) { - generate_error (&dtp->common, ERROR_END, NULL); + generate_error (&dtp->common, LIBERROR_END, NULL); return NULL; } if (is_internal_unit (dtp) && dtp->u.p.current_unit->endfile == AT_ENDFILE) - generate_error (&dtp->common, ERROR_END, NULL); + generate_error (&dtp->common, LIBERROR_END, NULL); if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) dtp->u.p.size_used += (gfc_offset) length; @@ -593,21 +604,22 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) size_t have_written, to_write_subrecord; int short_record; - /* Stream I/O. */ if (is_stream_io (dtp)) { - if (sseek (dtp->u.p.current_unit->s, - dtp->u.p.current_unit->strm_pos - 1) == FAILURE) + if (dtp->u.p.current_unit->strm_pos - 1 + != file_position (dtp->u.p.current_unit->s) + && sseek (dtp->u.p.current_unit->s, + dtp->u.p.current_unit->strm_pos - 1) == FAILURE) { - generate_error (&dtp->common, ERROR_OS, NULL); + generate_error (&dtp->common, LIBERROR_OS, NULL); return FAILURE; } if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0) { - generate_error (&dtp->common, ERROR_OS, NULL); + generate_error (&dtp->common, LIBERROR_OS, NULL); return FAILURE; } @@ -622,13 +634,21 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) { if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes) { - generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL); + generate_error (&dtp->common, LIBERROR_DIRECT_EOR, NULL); return FAILURE; } + if (buf == NULL && nbytes == 0) + { + char *p; + p = write_block (dtp, dtp->u.p.current_unit->recl); + memset (p, 0, dtp->u.p.current_unit->recl); + return SUCCESS; + } + if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0) { - generate_error (&dtp->common, ERROR_OS, NULL); + generate_error (&dtp->common, LIBERROR_OS, NULL); return FAILURE; } @@ -636,7 +656,6 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes; return SUCCESS; - } /* Unformatted sequential. */ @@ -667,7 +686,7 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) if (swrite (dtp->u.p.current_unit->s, buf + have_written, &to_write_subrecord) != 0) { - generate_error (&dtp->common, ERROR_OS, NULL); + generate_error (&dtp->common, LIBERROR_OS, NULL); return FAILURE; } @@ -684,7 +703,7 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) dtp->u.p.current_unit->bytes_left -= have_written; if (short_record) { - generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL); + generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); return FAILURE; } return SUCCESS; @@ -701,7 +720,7 @@ unformatted_read (st_parameter_dt *dtp, bt type, size_t i, sz; /* Currently, character implies size=1. */ - if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE + if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE || size == 1 || type == BT_CHARACTER) { sz = size * nelems; @@ -743,7 +762,7 @@ unformatted_write (st_parameter_dt *dtp, bt type, void *source, int kind __attribute__((unused)), size_t size, size_t nelems) { - if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE || + if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE || size == 1 || type == BT_CHARACTER) { size *= nelems; @@ -852,8 +871,8 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f) if (actual == expected) return 0; - st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s", - type_name (expected), dtp->u.p.item_count, type_name (actual)); + sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s", + type_name (expected), dtp->u.p.item_count, type_name (actual)); format_error (dtp, f, buffer); return 1; @@ -918,7 +937,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len, { /* No data descriptors left. */ if (n > 0) - generate_error (&dtp->common, ERROR_FORMAT, + generate_error (&dtp->common, LIBERROR_FORMAT, "Insufficient data descriptors in format after reversion"); return; } @@ -936,9 +955,12 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len, { if (dtp->u.p.skips > 0) { + int tmp; write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces); - dtp->u.p.max_pos = (int)(dtp->u.p.current_unit->recl - - dtp->u.p.current_unit->bytes_left); + tmp = (int)(dtp->u.p.current_unit->recl + - dtp->u.p.current_unit->bytes_left); + dtp->u.p.max_pos = + dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp; } if (dtp->u.p.skips < 0) { @@ -1492,9 +1514,15 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind, extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound; /* If the extent of even one dimension is zero, then the entire - array section contains zero elements, so we return. */ + array section contains zero elements, so we return after writing + a zero array record. */ if (extent[n] <= 0) - return; + { + data = NULL; + tsize = 0; + dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize); + return; + } } stride0 = stride[0]; @@ -1566,12 +1594,12 @@ us_read (st_parameter_dt *dtp, int continued) if (p == NULL || n != nr) { - generate_error (&dtp->common, ERROR_BAD_US, NULL); + generate_error (&dtp->common, LIBERROR_BAD_US, NULL); return; } - /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */ - if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE) + /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */ + if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE) { switch (nr) { @@ -1641,7 +1669,7 @@ us_write (st_parameter_dt *dtp, int continued) nbytes = compile_options.record_marker ; if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0) - generate_error (&dtp->common, ERROR_OS, NULL); + generate_error (&dtp->common, LIBERROR_OS, NULL); /* For sequential unformatted, if RECL= was not specified in the OPEN we write until we have more bytes than can fit in the subrecord @@ -1723,7 +1751,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) { close_unit (dtp->u.p.current_unit); dtp->u.p.current_unit = NULL; - generate_error (&dtp->common, ERROR_BAD_OPTION, + generate_error (&dtp->common, LIBERROR_BAD_OPTION, "Bad unit number in OPEN statement"); return; } @@ -1745,23 +1773,23 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) conv = get_unformatted_convert (dtp->common.unit); - if (conv == CONVERT_NONE) + if (conv == GFC_CONVERT_NONE) conv = compile_options.convert; /* We use l8_to_l4_offset, which is 0 on little-endian machines and 1 on big-endian machines. */ switch (conv) { - case CONVERT_NATIVE: - case CONVERT_SWAP: + case GFC_CONVERT_NATIVE: + case GFC_CONVERT_SWAP: break; - case CONVERT_BIG: - conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP; + case GFC_CONVERT_BIG: + conv = l8_to_l4_offset ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP; break; - case CONVERT_LITTLE: - conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE; + case GFC_CONVERT_LITTLE: + conv = l8_to_l4_offset ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE; break; default: @@ -1784,14 +1812,14 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE) { - generate_error (&dtp->common, ERROR_BAD_ACTION, + generate_error (&dtp->common, LIBERROR_BAD_ACTION, "Cannot read from file opened for WRITE"); return; } if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ) { - generate_error (&dtp->common, ERROR_BAD_ACTION, + generate_error (&dtp->common, LIBERROR_BAD_ACTION, "Cannot write to file opened for READ"); return; } @@ -1807,7 +1835,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)) != 0) { - generate_error (&dtp->common, ERROR_OPTION_CONFLICT, + generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "Format present for UNFORMATTED data transfer"); return; } @@ -1815,20 +1843,20 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL) { if ((cf & IOPARM_DT_HAS_FORMAT) != 0) - generate_error (&dtp->common, ERROR_OPTION_CONFLICT, + generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "A format cannot be specified with a namelist"); } else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED && !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))) { - generate_error (&dtp->common, ERROR_OPTION_CONFLICT, + generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "Missing format for FORMATTED data transfer"); } if (is_internal_unit (dtp) && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) { - generate_error (&dtp->common, ERROR_OPTION_CONFLICT, + generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "Internal file cannot be accessed by UNFORMATTED " "data transfer"); return; @@ -1839,7 +1867,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT && (cf & IOPARM_DT_HAS_REC) == 0) { - generate_error (&dtp->common, ERROR_MISSING_OPTION, + generate_error (&dtp->common, LIBERROR_MISSING_OPTION, "Direct access data transfer requires record number"); return; } @@ -1847,7 +1875,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL && (cf & IOPARM_DT_HAS_REC) != 0) { - generate_error (&dtp->common, ERROR_OPTION_CONFLICT, + generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "Record number not allowed for sequential access data transfer"); return; } @@ -1863,14 +1891,14 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) { if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) { - generate_error (&dtp->common, ERROR_OPTION_CONFLICT, + generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "ADVANCE specification conflicts with sequential access"); return; } if (is_internal_unit (dtp)) { - generate_error (&dtp->common, ERROR_OPTION_CONFLICT, + generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "ADVANCE specification conflicts with internal file"); return; } @@ -1878,7 +1906,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)) != IOPARM_DT_HAS_FORMAT) { - generate_error (&dtp->common, ERROR_OPTION_CONFLICT, + generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "ADVANCE specification requires an explicit format"); return; } @@ -1886,9 +1914,11 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) if (read_flag) { + dtp->u.p.current_unit->previous_nonadvancing_write = 0; + if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO) { - generate_error (&dtp->common, ERROR_MISSING_OPTION, + generate_error (&dtp->common, LIBERROR_MISSING_OPTION, "EOR specification requires an ADVANCE specification " "of NO"); return; @@ -1896,7 +1926,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO) { - generate_error (&dtp->common, ERROR_MISSING_OPTION, + generate_error (&dtp->common, LIBERROR_MISSING_OPTION, "SIZE specification requires an ADVANCE specification of NO"); return; } @@ -1905,21 +1935,21 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) { /* Write constraints. */ if ((cf & IOPARM_END) != 0) { - generate_error (&dtp->common, ERROR_OPTION_CONFLICT, + generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "END specification cannot appear in a write statement"); return; } if ((cf & IOPARM_EOR) != 0) { - generate_error (&dtp->common, ERROR_OPTION_CONFLICT, + generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "EOR specification cannot appear in a write statement"); return; } if ((cf & IOPARM_DT_HAS_SIZE) != 0) { - generate_error (&dtp->common, ERROR_OPTION_CONFLICT, + generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, "SIZE specification cannot appear in a write statement"); return; } @@ -1933,14 +1963,14 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) { if (dtp->rec <= 0) { - generate_error (&dtp->common, ERROR_BAD_OPTION, + generate_error (&dtp->common, LIBERROR_BAD_OPTION, "Record number must be positive"); return; } if (dtp->rec >= dtp->u.p.current_unit->maxrec) { - generate_error (&dtp->common, ERROR_BAD_OPTION, + generate_error (&dtp->common, LIBERROR_BAD_OPTION, "Record number too large"); return; } @@ -1958,7 +1988,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) if (dtp->u.p.mode == READING && (dtp->rec -1) * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s)) { - generate_error (&dtp->common, ERROR_BAD_OPTION, + generate_error (&dtp->common, LIBERROR_BAD_OPTION, "Non-existing record number"); return; } @@ -1969,7 +1999,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1) * dtp->u.p.current_unit->recl) == FAILURE) { - generate_error (&dtp->common, ERROR_OS, NULL); + generate_error (&dtp->common, LIBERROR_OS, NULL); return; } } @@ -2035,7 +2065,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) { if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp)) { - generate_error (&dtp->common, ERROR_BAD_OPTION, + generate_error (&dtp->common, LIBERROR_BAD_OPTION, "Cannot READ after a nonadvancing WRITE"); return; } @@ -2054,42 +2084,63 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) } /* Initialize an array_loop_spec given the array descriptor. The function - returns the index of the last element of the array. */ + returns the index of the last element of the array, and also returns + starting record, where the first I/O goes to (necessary in case of + negative strides). */ gfc_offset -init_loop_spec (gfc_array_char *desc, array_loop_spec *ls) +init_loop_spec (gfc_array_char *desc, array_loop_spec *ls, + gfc_offset *start_record) { int rank = GFC_DESCRIPTOR_RANK(desc); int i; gfc_offset index; + int empty; + empty = 0; index = 1; + *start_record = 0; + for (i=0; i<rank; i++) { ls[i].idx = desc->dim[i].lbound; ls[i].start = desc->dim[i].lbound; ls[i].end = desc->dim[i].ubound; ls[i].step = desc->dim[i].stride; - - index += (desc->dim[i].ubound - desc->dim[i].lbound) - * desc->dim[i].stride; + empty = empty || (desc->dim[i].ubound < desc->dim[i].lbound); + + if (desc->dim[i].stride > 0) + { + index += (desc->dim[i].ubound - desc->dim[i].lbound) + * desc->dim[i].stride; + } + else + { + index -= (desc->dim[i].ubound - desc->dim[i].lbound) + * desc->dim[i].stride; + *start_record -= (desc->dim[i].ubound - desc->dim[i].lbound) + * desc->dim[i].stride; + } } - return index; + + if (empty) + return 0; + else + return index; } /* Determine the index to the next record in an internal unit array by - by incrementing through the array_loop_spec. TODO: Implement handling - negative strides. */ + by incrementing through the array_loop_spec. */ gfc_offset -next_array_record (st_parameter_dt *dtp, array_loop_spec *ls) +next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished) { int i, carry; gfc_offset index; carry = 1; index = 0; - + for (i = 0; i < dtp->u.p.current_unit->rank; i++) { if (carry) @@ -2106,6 +2157,8 @@ next_array_record (st_parameter_dt *dtp, array_loop_spec *ls) index = index + (ls[i].idx - ls[i].start) * ls[i].step; } + *finished = carry; + return index; } @@ -2137,7 +2190,7 @@ skip_record (st_parameter_dt *dtp, size_t bytes) /* Direct access files do not generate END conditions, only I/O errors. */ if (sseek (dtp->u.p.current_unit->s, new) == FAILURE) - generate_error (&dtp->common, ERROR_OS, NULL); + generate_error (&dtp->common, LIBERROR_OS, NULL); } else { /* Seek by reading data. */ @@ -2150,7 +2203,7 @@ skip_record (st_parameter_dt *dtp, size_t bytes) p = salloc_r (dtp->u.p.current_unit->s, &rlength); if (p == NULL) { - generate_error (&dtp->common, ERROR_OS, NULL); + generate_error (&dtp->common, LIBERROR_OS, NULL); return; } @@ -2227,13 +2280,16 @@ next_record_r (st_parameter_dt *dtp) { if (is_array_io (dtp)) { - record = next_array_record (dtp, dtp->u.p.current_unit->ls); + int finished; + + record = next_array_record (dtp, dtp->u.p.current_unit->ls, + &finished); /* Now seek to this record. */ record = record * dtp->u.p.current_unit->recl; if (sseek (dtp->u.p.current_unit->s, record) == FAILURE) { - generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL); + generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); break; } dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; @@ -2254,7 +2310,7 @@ next_record_r (st_parameter_dt *dtp) if (p == NULL) { - generate_error (&dtp->common, ERROR_OS, NULL); + generate_error (&dtp->common, LIBERROR_OS, NULL); break; } @@ -2298,8 +2354,8 @@ write_us_marker (st_parameter_dt *dtp, const gfc_offset buf) else len = compile_options.record_marker; - /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */ - if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE) + /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */ + if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE) { switch (len) { @@ -2395,7 +2451,7 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord) return; io_error: - generate_error (&dtp->common, ERROR_OS, NULL); + generate_error (&dtp->common, LIBERROR_OS, NULL); return; } @@ -2446,6 +2502,8 @@ next_record_w (st_parameter_dt *dtp, int done) { if (is_array_io (dtp)) { + int finished; + length = (int) dtp->u.p.current_unit->bytes_left; /* If the farthest position reached is greater than current @@ -2463,14 +2521,15 @@ next_record_w (st_parameter_dt *dtp, int done) if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE) { - generate_error (&dtp->common, ERROR_END, NULL); + generate_error (&dtp->common, LIBERROR_END, NULL); return; } /* Now that the current record has been padded out, determine where the next record in the array is. */ - record = next_array_record (dtp, dtp->u.p.current_unit->ls); - if (record == 0) + record = next_array_record (dtp, dtp->u.p.current_unit->ls, + &finished); + if (finished) dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Now seek to this record */ @@ -2478,7 +2537,7 @@ next_record_w (st_parameter_dt *dtp, int done) if (sseek (dtp->u.p.current_unit->s, record) == FAILURE) { - generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL); + generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return; } @@ -2507,28 +2566,25 @@ next_record_w (st_parameter_dt *dtp, int done) if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE) { - generate_error (&dtp->common, ERROR_END, NULL); + generate_error (&dtp->common, LIBERROR_END, NULL); return; } } } else { - /* If this is the last call to next_record move to the farthest - position reached in preparation for completing the record. - (for file unit) */ - if (done) - { - m = dtp->u.p.current_unit->recl - - dtp->u.p.current_unit->bytes_left; - if (max_pos > m) - { - length = (int) (max_pos - m); - p = salloc_w (dtp->u.p.current_unit->s, &length); - } - } size_t len; const char crlf[] = "\r\n"; + + /* Move to the farthest position reached in preparation for + completing the record. (for file unit) */ + m = dtp->u.p.current_unit->recl - + dtp->u.p.current_unit->bytes_left; + if (max_pos > m) + { + length = (int) (max_pos - m); + p = salloc_w (dtp->u.p.current_unit->s, &length); + } #ifdef HAVE_CRLF len = 2; #else @@ -2544,7 +2600,7 @@ next_record_w (st_parameter_dt *dtp, int done) break; io_error: - generate_error (&dtp->common, ERROR_OS, NULL); + generate_error (&dtp->common, LIBERROR_OS, NULL); break; } } @@ -2605,7 +2661,7 @@ finalize_transfer (st_parameter_dt *dtp) if (dtp->u.p.eor_condition) { - generate_error (&dtp->common, ERROR_EOR, NULL); + generate_error (&dtp->common, LIBERROR_EOR, NULL); return; } @@ -2628,7 +2684,7 @@ finalize_transfer (st_parameter_dt *dtp) dtp->u.p.eof_jump = &eof_jump; if (setjmp (eof_jump)) { - generate_error (&dtp->common, ERROR_END, NULL); + generate_error (&dtp->common, LIBERROR_END, NULL); return; } @@ -2639,12 +2695,22 @@ finalize_transfer (st_parameter_dt *dtp) return; } + if (dtp->u.p.mode == WRITING) + dtp->u.p.current_unit->previous_nonadvancing_write + = dtp->u.p.advance_status == ADVANCE_NO; + if (is_stream_io (dtp)) { - if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED) + if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED + && dtp->u.p.advance_status != ADVANCE_NO) next_record (dtp, 1); - flush (dtp->u.p.current_unit->s); - sfree (dtp->u.p.current_unit->s); + + if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED + && file_position (dtp->u.p.current_unit->s) >= dtp->rec) + { + flush (dtp->u.p.current_unit->s); + sfree (dtp->u.p.current_unit->s); + } return; } @@ -2758,14 +2824,14 @@ st_read (st_parameter_dt *dtp) case AT_ENDFILE: if (!is_internal_unit (dtp)) { - generate_error (&dtp->common, ERROR_END, NULL); + generate_error (&dtp->common, LIBERROR_END, NULL); dtp->u.p.current_unit->endfile = AFTER_ENDFILE; dtp->u.p.current_unit->current_record = 0; } break; case AFTER_ENDFILE: - generate_error (&dtp->common, ERROR_ENDFILE, NULL); + generate_error (&dtp->common, LIBERROR_ENDFILE, NULL); dtp->u.p.current_unit->current_record = 0; break; } @@ -2827,7 +2893,7 @@ st_write_done (st_parameter_dt *dtp) { flush (dtp->u.p.current_unit->s); if (struncate (dtp->u.p.current_unit->s) == FAILURE) - generate_error (&dtp->common, ERROR_OS, NULL); + generate_error (&dtp->common, LIBERROR_OS, NULL); } dtp->u.p.current_unit->endfile = AT_ENDFILE; break; diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c index fac67bdaf7e..2ec776f0d68 100644 --- a/libgfortran/io/unit.c +++ b/libgfortran/io/unit.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc. +/* Copyright (C) 2002, 2003, 2005, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -27,11 +27,9 @@ along with Libgfortran; see the file COPYING. If not, write to the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ -#include "config.h" +#include "io.h" #include <stdlib.h> #include <string.h> -#include "libgfortran.h" -#include "io.h" /* IO locking rules: @@ -206,6 +204,22 @@ insert_unit (int n) } +/* destroy_unit_mutex()-- Destroy the mutex and free memory of unit. */ + +static void +destroy_unit_mutex (gfc_unit * u) +{ +#ifdef __GTHREAD_MUTEX_DESTROY_FUNCTION + __GTHREAD_MUTEX_DESTROY_FUNCTION (&u->lock); +#else +#ifdef __CYGWIN__ + pthread_mutex_destroy (&u->lock); +#endif +#endif + free_mem (u); +} + + static gfc_unit * delete_root (gfc_unit * t) { @@ -343,7 +357,7 @@ found: __gthread_mutex_lock (&unit_lock); __gthread_mutex_unlock (&p->lock); if (predec_waiting_locked (p) == 0) - free_mem (p); + destroy_unit_mutex (p); goto retry; } @@ -371,13 +385,14 @@ gfc_unit * get_internal_unit (st_parameter_dt *dtp) { gfc_unit * iunit; + gfc_offset start_record = 0; /* Allocate memory for a unit structure. */ iunit = get_mem (sizeof (gfc_unit)); if (iunit == NULL) { - generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL); + generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return NULL; } @@ -407,12 +422,15 @@ get_internal_unit (st_parameter_dt *dtp) iunit->ls = (array_loop_spec *) get_mem (iunit->rank * sizeof (array_loop_spec)); dtp->internal_unit_len *= - init_loop_spec (dtp->internal_unit_desc, iunit->ls); + init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record); + + start_record *= iunit->recl; } /* Set initial values for unit parameters. */ - iunit->s = open_internal (dtp->internal_unit, dtp->internal_unit_len); + iunit->s = open_internal (dtp->internal_unit - start_record, + dtp->internal_unit_len, -start_record); iunit->bytes_left = iunit->recl; iunit->last_record=0; iunit->maxrec=0; @@ -453,14 +471,18 @@ free_internal_unit (st_parameter_dt *dtp) if (!is_internal_unit (dtp)) return; - if (dtp->u.p.current_unit->ls != NULL) - free_mem (dtp->u.p.current_unit->ls); - - sclose (dtp->u.p.current_unit->s); - if (dtp->u.p.current_unit != NULL) - free_mem (dtp->u.p.current_unit); + { + if (dtp->u.p.current_unit->ls != NULL) + free_mem (dtp->u.p.current_unit->ls); + + if (dtp->u.p.current_unit->s) + free_mem (dtp->u.p.current_unit->s); + + destroy_unit_mutex (dtp->u.p.current_unit); + } } + /* get_unit()-- Returns the unit structure associated with the integer @@ -583,27 +605,8 @@ close_unit_1 (gfc_unit *u, int locked) /* If there are previously written bytes from a write with ADVANCE="no" Reposition the buffer before closing. */ - if (u->saved_pos > 0) - { - char *p; - - p = salloc_w (u->s, &u->saved_pos); - - if (!(u->unit_number == options.stdout_unit - || u->unit_number == options.stderr_unit)) - { - size_t len; - - const char crlf[] = "\r\n"; -#ifdef HAVE_CRLF - len = 2; -#else - len = 1; -#endif - if (swrite (u->s, &crlf[2-len], &len) != 0) - os_error ("Close after ADVANCE_NO failed"); - } - } + if (u->previous_nonadvancing_write) + finish_last_advance_record (u); rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE; @@ -629,7 +632,7 @@ close_unit_1 (gfc_unit *u, int locked) avoid freeing the memory, the last such thread will free it instead. */ if (u->waiting == 0) - free_mem (u); + destroy_unit_mutex (u); if (!locked) __gthread_mutex_unlock (&unit_lock); @@ -720,3 +723,27 @@ filename_from_unit (int n) return (char *) NULL; } +void +finish_last_advance_record (gfc_unit *u) +{ + char *p; + + if (u->saved_pos > 0) + p = salloc_w (u->s, &u->saved_pos); + + if (!(u->unit_number == options.stdout_unit + || u->unit_number == options.stderr_unit)) + { + size_t len; + + const char crlf[] = "\r\n"; +#ifdef HAVE_CRLF + len = 2; +#else + len = 1; +#endif + if (swrite (u->s, &crlf[2-len], &len) != 0) + os_error ("Completing record after ADVANCE_NO failed"); + } +} + diff --git a/libgfortran/io/unix.c b/libgfortran/io/unix.c index 87d001e7c1f..d33c11091a0 100644 --- a/libgfortran/io/unix.c +++ b/libgfortran/io/unix.c @@ -30,13 +30,11 @@ Boston, MA 02110-1301, USA. */ /* Unix stream I/O module */ -#include "config.h" +#include "io.h" #include <stdlib.h> #include <limits.h> #include <unistd.h> -#include <stdio.h> -#include <stdarg.h> #include <sys/stat.h> #include <fcntl.h> #include <assert.h> @@ -44,8 +42,58 @@ Boston, MA 02110-1301, USA. */ #include <string.h> #include <errno.h> -#include "libgfortran.h" -#include "io.h" + +/* For mingw, we don't identify files by their inode number, but by a + 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */ +#if defined(__MINGW32__) && !HAVE_WORKING_STAT + +#define WIN32_LEAN_AND_MEAN +#include <windows.h> + +static uint64_t +id_from_handle (HANDLE hFile) +{ + BY_HANDLE_FILE_INFORMATION FileInformation; + + if (hFile == INVALID_HANDLE_VALUE) + return 0; + + memset (&FileInformation, 0, sizeof(FileInformation)); + if (!GetFileInformationByHandle (hFile, &FileInformation)) + return 0; + + return ((uint64_t) FileInformation.nFileIndexLow) + | (((uint64_t) FileInformation.nFileIndexHigh) << 32); +} + + +static uint64_t +id_from_path (const char *path) +{ + HANDLE hFile; + uint64_t res; + + if (!path || !*path || access (path, F_OK)) + return (uint64_t) -1; + + hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING, + FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY, + NULL); + res = id_from_handle (hFile); + CloseHandle (hFile); + return res; +} + + +static uint64_t +id_from_fd (const int fd) +{ + return id_from_handle ((HANDLE) _get_osfhandle (fd)); +} + +#endif + + #ifndef SSIZE_MAX #define SSIZE_MAX SHRT_MAX @@ -142,10 +190,6 @@ typedef struct } int_stream; -extern stream *init_error_stream (unix_stream *); -internal_proto(init_error_stream); - - /* This implementation of stream I/O is based on the paper: * * "Exploiting the advantages of mapped files for stream I/O", @@ -220,13 +264,13 @@ move_pos_offset (stream* st, int pos_off) static int fix_fd (int fd) { +#ifdef HAVE_DUP int input, output, error; input = output = error = 0; /* Unix allocates the lowest descriptors first, so a loop is not required, but this order is. */ - if (fd == STDIN_FILENO) { fd = dup (fd); @@ -249,6 +293,7 @@ fix_fd (int fd) close (STDOUT_FILENO); if (error) close (STDERR_FILENO); +#endif return fd; } @@ -837,7 +882,7 @@ fd_open (unix_stream * s) s->st.sfree = (void *) fd_sfree; s->st.close = (void *) fd_close; s->st.seek = (void *) fd_seek; - s->st.truncate = (void *) fd_truncate; + s->st.trunc = (void *) fd_truncate; s->st.read = (void *) fd_read; s->st.write = (void *) fd_write; s->st.set = (void *) fd_sset; @@ -1033,7 +1078,7 @@ empty_internal_buffer(stream *strm) /* open_internal()-- Returns a stream structure from an internal file */ stream * -open_internal (char *base, int length) +open_internal (char *base, int length, gfc_offset offset) { int_stream *s; @@ -1041,7 +1086,7 @@ open_internal (char *base, int length) memset (s, '\0', sizeof (int_stream)); s->buffer = base; - s->buffer_offset = 0; + s->buffer_offset = offset; s->logical_offset = 0; s->active = s->file_length = length; @@ -1051,7 +1096,7 @@ open_internal (char *base, int length) s->st.sfree = (void *) mem_sfree; s->st.close = (void *) mem_close; s->st.seek = (void *) mem_seek; - s->st.truncate = (void *) mem_truncate; + s->st.trunc = (void *) mem_truncate; s->st.read = (void *) mem_read; s->st.write = (void *) mem_write; s->st.set = (void *) mem_set; @@ -1155,7 +1200,7 @@ tempfile (st_parameter_open *opp) template = get_mem (strlen (tempdir) + 20); - st_sprintf (template, "%s/gfortrantmpXXXXXX", tempdir); + sprintf (template, "%s/gfortrantmpXXXXXX", tempdir); #ifdef HAVE_MKSTEMP @@ -1366,10 +1411,16 @@ input_stream (void) stream * output_stream (void) { + stream * s; + #if defined(HAVE_CRLF) && defined(HAVE_SETMODE) setmode (STDOUT_FILENO, O_BINARY); #endif - return fd_to_stream (STDOUT_FILENO, PROT_WRITE); + + s = fd_to_stream (STDOUT_FILENO, PROT_WRITE); + if (options.unbuffered_preconnected) + ((unix_stream *) s)->unbuffered = 1; + return s; } @@ -1379,128 +1430,71 @@ output_stream (void) stream * error_stream (void) { + stream * s; + #if defined(HAVE_CRLF) && defined(HAVE_SETMODE) setmode (STDERR_FILENO, O_BINARY); #endif - return fd_to_stream (STDERR_FILENO, PROT_WRITE); -} -/* init_error_stream()-- Return a pointer to the error stream. This - * subroutine is called when the stream is needed, rather than at - * initialization. We want to work even if memory has been seriously - * corrupted. */ - -stream * -init_error_stream (unix_stream *error) -{ - memset (error, '\0', sizeof (*error)); - - error->fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO; + s = fd_to_stream (STDERR_FILENO, PROT_WRITE); + if (options.unbuffered_preconnected) + ((unix_stream *) s)->unbuffered = 1; + return s; +} - error->st.alloc_w_at = (void *) fd_alloc_w_at; - error->st.sfree = (void *) fd_sfree; - error->unbuffered = 1; - error->buffer = error->small_buffer; +/* st_vprintf()-- vprintf function for error output. To avoid buffer + overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k + is big enough to completely fill a 80x25 terminal, so it shuld be + OK. We use a direct write() because it is simpler and least likely + to be clobbered by memory corruption. Writing an error message + longer than that is an error. */ - return (stream *) error; -} - -/* st_printf()-- simple printf() function for streams that handles the - * formats %d, %s and %c. This function handles printing of error - * messages that originate within the library itself, not from a user - * program. */ +#define ST_VPRINTF_SIZE 2048 int -st_printf (const char *format, ...) +st_vprintf (const char *format, va_list ap) { - int count, total; - va_list arg; - char *p; - const char *q; - stream *s; - char itoa_buf[GFC_ITOA_BUF_SIZE]; - unix_stream err_stream; + static char buffer[ST_VPRINTF_SIZE]; + int written; + int fd; - total = 0; - s = init_error_stream (&err_stream); - va_start (arg, format); + fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO; +#ifdef HAVE_VSNPRINTF + written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap); +#else + written = vsprintf(buffer, format, ap); - for (;;) + if (written >= ST_VPRINTF_SIZE-1) { - count = 0; - - while (format[count] != '%' && format[count] != '\0') - count++; + /* The error message was longer than our buffer. Ouch. Because + we may have messed up things badly, report the error and + quit. */ +#define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n" + write (fd, buffer, ST_VPRINTF_SIZE-1); + write (fd, ERROR_MESSAGE, strlen(ERROR_MESSAGE)); + sys_exit(2); +#undef ERROR_MESSAGE - if (count != 0) - { - p = salloc_w (s, &count); - memmove (p, format, count); - sfree (s); - } - - total += count; - format += count; - if (*format++ == '\0') - break; + } +#endif - switch (*format) - { - case 'c': - count = 1; - - p = salloc_w (s, &count); - *p = (char) va_arg (arg, int); - - sfree (s); - break; - - case 'd': - q = gfc_itoa (va_arg (arg, int), itoa_buf, sizeof (itoa_buf)); - count = strlen (q); - - p = salloc_w (s, &count); - memmove (p, q, count); - sfree (s); - break; - - case 'x': - q = xtoa (va_arg (arg, unsigned), itoa_buf, sizeof (itoa_buf)); - count = strlen (q); - - p = salloc_w (s, &count); - memmove (p, q, count); - sfree (s); - break; - - case 's': - q = va_arg (arg, char *); - count = strlen (q); - - p = salloc_w (s, &count); - memmove (p, q, count); - sfree (s); - break; - - case '\0': - return total; - - default: - count = 2; - p = salloc_w (s, &count); - p[0] = format[-1]; - p[1] = format[0]; - sfree (s); - break; - } + written = write (fd, buffer, written); + return written; +} - total += count; - format++; - } +/* st_printf()-- printf() function for error output. This just calls + st_vprintf() to do the actual work. */ - va_end (arg); - return total; +int +st_printf (const char *format, ...) +{ + int written; + va_list ap; + va_start (ap, format); + written = st_vprintf(format, ap); + va_end (ap); + return written; } @@ -1515,6 +1509,10 @@ compare_file_filename (gfc_unit *u, const char *name, int len) struct stat st1; #ifdef HAVE_WORKING_STAT struct stat st2; +#else +# ifdef __MINGW32__ + uint64_t id1, id2; +# endif #endif if (unpack_filename (path, name, len)) @@ -1530,6 +1528,17 @@ compare_file_filename (gfc_unit *u, const char *name, int len) fstat (((unix_stream *) (u->s))->fd, &st2); return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino); #else + +# ifdef __MINGW32__ + /* We try to match files by a unique ID. On some filesystems (network + fs and FAT), we can't generate this unique ID, and will simply compare + filenames. */ + id1 = id_from_path (path); + id2 = id_from_fd (((unix_stream *) (u->s))->fd); + if (id1 || id2) + return (id1 == id2); +# endif + if (len != u->file_len) return 0; return (memcmp(path, u->file, len) == 0); @@ -1541,8 +1550,8 @@ compare_file_filename (gfc_unit *u, const char *name, int len) # define FIND_FILE0_DECL struct stat *st # define FIND_FILE0_ARGS st #else -# define FIND_FILE0_DECL const char *file, gfc_charlen_type file_len -# define FIND_FILE0_ARGS file, file_len +# define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len +# define FIND_FILE0_ARGS id, file, file_len #endif /* find_file0()-- Recursive work function for find_file() */ @@ -1551,6 +1560,9 @@ static gfc_unit * find_file0 (gfc_unit *u, FIND_FILE0_DECL) { gfc_unit *v; +#if defined(__MINGW32__) && !HAVE_WORKING_STAT + uint64_t id1; +#endif if (u == NULL) return NULL; @@ -1561,8 +1573,16 @@ find_file0 (gfc_unit *u, FIND_FILE0_DECL) st[0].st_dev == st[1].st_dev && st[0].st_ino == st[1].st_ino) return u; #else - if (compare_string (u->file_len, u->file, file_len, file) == 0) - return u; +# ifdef __MINGW32__ + if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1)) + { + if (id == id1) + return u; + } + else +# endif + if (compare_string (u->file_len, u->file, file_len, file) == 0) + return u; #endif v = find_file0 (u->left, FIND_FILE0_ARGS); @@ -1586,6 +1606,7 @@ find_file (const char *file, gfc_charlen_type file_len) char path[PATH_MAX + 1]; struct stat st[2]; gfc_unit *u; + uint64_t id; if (unpack_filename (path, file, file_len)) return NULL; @@ -1593,6 +1614,12 @@ find_file (const char *file, gfc_charlen_type file_len) if (stat (path, &st[0]) < 0) return NULL; +#if defined(__MINGW32__) && !HAVE_WORKING_STAT + id = id_from_path (path); +#else + id = 0; +#endif + __gthread_mutex_lock (&unit_lock); retry: u = find_file0 (unit_root, FIND_FILE0_ARGS); @@ -1779,7 +1806,7 @@ inquire_sequential (const char *string, int len) if (S_ISREG (statbuf.st_mode) || S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode)) - return yes; + return unknown; if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode)) return no; @@ -1802,7 +1829,7 @@ inquire_direct (const char *string, int len) return unknown; if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode)) - return yes; + return unknown; if (S_ISDIR (statbuf.st_mode) || S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode)) @@ -1828,7 +1855,7 @@ inquire_formatted (const char *string, int len) if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode) || S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode)) - return yes; + return unknown; if (S_ISDIR (statbuf.st_mode)) return no; @@ -1847,6 +1874,36 @@ inquire_unformatted (const char *string, int len) } +#ifndef HAVE_ACCESS + +#ifndef W_OK +#define W_OK 2 +#endif + +#ifndef R_OK +#define R_OK 4 +#endif + +/* Fallback implementation of access() on systems that don't have it. + Only modes R_OK and W_OK are used in this file. */ + +static int +fallback_access (const char *path, int mode) +{ + if ((mode & R_OK) && open (path, O_RDONLY) < 0) + return -1; + + if ((mode & W_OK) && open (path, O_WRONLY) < 0) + return -1; + + return 0; +} + +#undef access +#define access fallback_access +#endif + + /* inquire_access()-- Given a fortran string, determine if the file is * suitable for access. */ diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index b4e5d3efb8f..d1a3d7ad828 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -28,22 +28,15 @@ along with Libgfortran; see the file COPYING. If not, write to the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ -#include "config.h" +#include "io.h" #include <assert.h> #include <string.h> #include <ctype.h> -#include <stdio.h> #include <stdlib.h> -#include "libgfortran.h" -#include "io.h" - +#include <stdbool.h> #define star_fill(p, n) memset(p, '*', n) - -typedef enum -{ SIGN_NONE, SIGN_MINUS, SIGN_PLUS } -sign_t; - +#include "write_float.def" void write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len) @@ -235,653 +228,6 @@ extract_uint (const void *p, int len) return i; } -static GFC_REAL_LARGEST -extract_real (const void *p, int len) -{ - GFC_REAL_LARGEST i = 0; - switch (len) - { - case 4: - { - GFC_REAL_4 tmp; - memcpy ((void *) &tmp, p, len); - i = tmp; - } - break; - case 8: - { - GFC_REAL_8 tmp; - memcpy ((void *) &tmp, p, len); - i = tmp; - } - break; -#ifdef HAVE_GFC_REAL_10 - case 10: - { - GFC_REAL_10 tmp; - memcpy ((void *) &tmp, p, len); - i = tmp; - } - break; -#endif -#ifdef HAVE_GFC_REAL_16 - case 16: - { - GFC_REAL_16 tmp; - memcpy ((void *) &tmp, p, len); - i = tmp; - } - break; -#endif - default: - internal_error (NULL, "bad real kind"); - } - return i; -} - - -/* Given a flag that indicate if a value is negative or not, return a - sign_t that gives the sign that we need to produce. */ - -static sign_t -calculate_sign (st_parameter_dt *dtp, int negative_flag) -{ - sign_t s = SIGN_NONE; - - if (negative_flag) - s = SIGN_MINUS; - else - switch (dtp->u.p.sign_status) - { - case SIGN_SP: - s = SIGN_PLUS; - break; - case SIGN_SS: - s = SIGN_NONE; - break; - case SIGN_S: - s = options.optional_plus ? SIGN_PLUS : SIGN_NONE; - break; - } - - return s; -} - - -/* Returns the value of 10**d. */ - -static GFC_REAL_LARGEST -calculate_exp (int d) -{ - int i; - GFC_REAL_LARGEST r = 1.0; - - for (i = 0; i< (d >= 0 ? d : -d); i++) - r *= 10; - - r = (d >= 0) ? r : 1.0 / r; - - return r; -} - - -/* Generate corresponding I/O format for FMT_G output. - The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran - LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is: - - Data Magnitude Equivalent Conversion - 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee] - m = 0 F(w-n).(d-1), n' ' - 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' ' - 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' ' - 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' ' - ................ .......... - 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ') - m >= 10**d-0.5 Ew.d[Ee] - - notes: for Gw.d , n' ' means 4 blanks - for Gw.dEe, n' ' means e+2 blanks */ - -static fnode * -calculate_G_format (st_parameter_dt *dtp, const fnode *f, - GFC_REAL_LARGEST value, int *num_blank) -{ - int e = f->u.real.e; - int d = f->u.real.d; - int w = f->u.real.w; - fnode *newf; - GFC_REAL_LARGEST m, exp_d; - int low, high, mid; - int ubound, lbound; - - newf = get_mem (sizeof (fnode)); - - /* Absolute value. */ - m = (value > 0.0) ? value : -value; - - /* In case of the two data magnitude ranges, - generate E editing, Ew.d[Ee]. */ - exp_d = calculate_exp (d); - if ((m > 0.0 && m < 0.1 - 0.05 / exp_d) || (m >= exp_d - 0.5 ) || - ((m == 0.0) && !(compile_options.allow_std & GFC_STD_F2003))) - { - newf->format = FMT_E; - newf->u.real.w = w; - newf->u.real.d = d; - newf->u.real.e = e; - *num_blank = 0; - return newf; - } - - /* Use binary search to find the data magnitude range. */ - mid = 0; - low = 0; - high = d + 1; - lbound = 0; - ubound = d + 1; - - while (low <= high) - { - GFC_REAL_LARGEST temp; - mid = (low + high) / 2; - - /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1) */ - temp = 0.1 * calculate_exp (mid) - 0.5 * calculate_exp (mid - d - 1); - - if (m < temp) - { - ubound = mid; - if (ubound == lbound + 1) - break; - high = mid - 1; - } - else if (m > temp) - { - lbound = mid; - if (ubound == lbound + 1) - { - mid ++; - break; - } - low = mid + 1; - } - else - break; - } - - /* Pad with blanks where the exponent would be. */ - if (e < 0) - *num_blank = 4; - else - *num_blank = e + 2; - - /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '. */ - newf->format = FMT_F; - newf->u.real.w = f->u.real.w - *num_blank; - - /* Special case. */ - if (m == 0.0) - newf->u.real.d = d - 1; - else - newf->u.real.d = - (mid - d - 1); - - /* For F editing, the scale factor is ignored. */ - dtp->u.p.scale_factor = 0; - return newf; -} - - -/* Output a real number according to its format which is FMT_G free. */ - -static void -output_float (st_parameter_dt *dtp, const fnode *f, GFC_REAL_LARGEST value) -{ -#if defined(HAVE_GFC_REAL_16) && __LDBL_DIG__ > 18 -# define MIN_FIELD_WIDTH 46 -#else -# define MIN_FIELD_WIDTH 31 -#endif -#define STR(x) STR1(x) -#define STR1(x) #x - /* This must be large enough to accurately hold any value. */ - char buffer[MIN_FIELD_WIDTH+1]; - char *out; - char *digits; - int e; - char expchar; - format_token ft; - int w; - int d; - int edigits; - int ndigits; - /* Number of digits before the decimal point. */ - int nbefore; - /* Number of zeros after the decimal point. */ - int nzero; - /* Number of digits after the decimal point. */ - int nafter; - /* Number of zeros after the decimal point, whatever the precision. */ - int nzero_real; - int leadzero; - int nblanks; - int i; - int sign_bit; - sign_t sign; - - ft = f->format; - w = f->u.real.w; - d = f->u.real.d; - - nzero_real = -1; - - - /* We should always know the field width and precision. */ - if (d < 0) - internal_error (&dtp->common, "Unspecified precision"); - - /* Use sprintf to print the number in the format +D.DDDDe+ddd - For an N digit exponent, this gives us (MIN_FIELD_WIDTH-5)-N digits - after the decimal point, plus another one before the decimal point. */ - sign = calculate_sign (dtp, value < 0.0); - sign_bit = signbit (value); - if (value < 0) - value = -value; - - /* Special case when format specifies no digits after the decimal point. */ - if (d == 0 && ft == FMT_F) - { - if (value < 0.5) - value = 0.0; - else if (value < 1.0) - value = value + 0.5; - } - - /* printf pads blanks for us on the exponent so we just need it big enough - to handle the largest number of exponent digits expected. */ - edigits=4; - - if (ft == FMT_F || ft == FMT_EN - || ((ft == FMT_D || ft == FMT_E) && dtp->u.p.scale_factor != 0)) - { - /* Always convert at full precision to avoid double rounding. */ - ndigits = MIN_FIELD_WIDTH - 4 - edigits; - } - else - { - /* We know the number of digits, so can let printf do the rounding - for us. */ - if (ft == FMT_ES) - ndigits = d + 1; - else - ndigits = d; - if (ndigits > MIN_FIELD_WIDTH - 4 - edigits) - ndigits = MIN_FIELD_WIDTH - 4 - edigits; - } - - /* # The result will always contain a decimal point, even if no - * digits follow it - * - * - The converted value is to be left adjusted on the field boundary - * - * + A sign (+ or -) always be placed before a number - * - * MIN_FIELD_WIDTH minimum field width - * - * * (ndigits-1) is used as the precision - * - * e format: [-]d.ddde±dd where there is one digit before the - * decimal-point character and the number of digits after it is - * equal to the precision. The exponent always contains at least two - * digits; if the value is zero, the exponent is 00. - */ -#ifdef HAVE_SNPRINTF - snprintf (buffer, sizeof (buffer), "%+-#" STR(MIN_FIELD_WIDTH) ".*" - GFC_REAL_LARGEST_FORMAT "e", ndigits - 1, value); -#else - sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" - GFC_REAL_LARGEST_FORMAT "e", ndigits - 1, value); -#endif - - /* Check the resulting string has punctuation in the correct places. */ - if (d != 0 && (buffer[2] != '.' || buffer[ndigits + 2] != 'e')) - internal_error (&dtp->common, "printf is broken"); - - /* Read the exponent back in. */ - e = atoi (&buffer[ndigits + 3]) + 1; - - /* Make sure zero comes out as 0.0e0. */ - if (value == 0.0) - { - e = 0; - if (compile_options.sign_zero == 1) - sign = calculate_sign (dtp, sign_bit); - else - sign = calculate_sign (dtp, 0); - } - - /* Normalize the fractional component. */ - buffer[2] = buffer[1]; - digits = &buffer[2]; - - /* Figure out where to place the decimal point. */ - switch (ft) - { - case FMT_F: - nbefore = e + dtp->u.p.scale_factor; - if (nbefore < 0) - { - nzero = -nbefore; - nzero_real = nzero; - if (nzero > d) - nzero = d; - nafter = d - nzero; - nbefore = 0; - } - else - { - nzero = 0; - nafter = d; - } - expchar = 0; - break; - - case FMT_E: - case FMT_D: - i = dtp->u.p.scale_factor; - if (value != 0.0) - e -= i; - if (i < 0) - { - nbefore = 0; - nzero = -i; - nafter = d + i; - } - else if (i > 0) - { - nbefore = i; - nzero = 0; - nafter = (d - i) + 1; - } - else /* i == 0 */ - { - nbefore = 0; - nzero = 0; - nafter = d; - } - - if (ft == FMT_E) - expchar = 'E'; - else - expchar = 'D'; - break; - - case FMT_EN: - /* The exponent must be a multiple of three, with 1-3 digits before - the decimal point. */ - if (value != 0.0) - e--; - if (e >= 0) - nbefore = e % 3; - else - { - nbefore = (-e) % 3; - if (nbefore != 0) - nbefore = 3 - nbefore; - } - e -= nbefore; - nbefore++; - nzero = 0; - nafter = d; - expchar = 'E'; - break; - - case FMT_ES: - if (value != 0.0) - e--; - nbefore = 1; - nzero = 0; - nafter = d; - expchar = 'E'; - break; - - default: - /* Should never happen. */ - internal_error (&dtp->common, "Unexpected format token"); - } - - /* Round the value. */ - if (nbefore + nafter == 0) - { - ndigits = 0; - if (nzero_real == d && digits[0] >= '5') - { - /* We rounded to zero but shouldn't have */ - nzero--; - nafter = 1; - digits[0] = '1'; - ndigits = 1; - } - } - else if (nbefore + nafter < ndigits) - { - ndigits = nbefore + nafter; - i = ndigits; - if (digits[i] >= '5') - { - /* Propagate the carry. */ - for (i--; i >= 0; i--) - { - if (digits[i] != '9') - { - digits[i]++; - break; - } - digits[i] = '0'; - } - - if (i < 0) - { - /* The carry overflowed. Fortunately we have some spare space - at the start of the buffer. We may discard some digits, but - this is ok because we already know they are zero. */ - digits--; - digits[0] = '1'; - if (ft == FMT_F) - { - if (nzero > 0) - { - nzero--; - nafter++; - } - else - nbefore++; - } - else if (ft == FMT_EN) - { - nbefore++; - if (nbefore == 4) - { - nbefore = 1; - e += 3; - } - } - else - e++; - } - } - } - - /* Calculate the format of the exponent field. */ - if (expchar) - { - edigits = 1; - for (i = abs (e); i >= 10; i /= 10) - edigits++; - - if (f->u.real.e < 0) - { - /* Width not specified. Must be no more than 3 digits. */ - if (e > 999 || e < -999) - edigits = -1; - else - { - edigits = 4; - if (e > 99 || e < -99) - expchar = ' '; - } - } - else - { - /* Exponent width specified, check it is wide enough. */ - if (edigits > f->u.real.e) - edigits = -1; - else - edigits = f->u.real.e + 2; - } - } - else - edigits = 0; - - /* Pick a field size if none was specified. */ - if (w <= 0) - w = nbefore + nzero + nafter + (sign != SIGN_NONE ? 2 : 1); - - /* Create the ouput buffer. */ - out = write_block (dtp, w); - if (out == NULL) - return; - - /* Zero values always output as positive, even if the value was negative - before rounding. */ - for (i = 0; i < ndigits; i++) - { - if (digits[i] != '0') - break; - } - if (i == ndigits) - { - /* The output is zero, so set the sign according to the sign bit unless - -fno-sign-zero was specified. */ - if (compile_options.sign_zero == 1) - sign = calculate_sign (dtp, sign_bit); - else - sign = calculate_sign (dtp, 0); - } - - /* Work out how much padding is needed. */ - nblanks = w - (nbefore + nzero + nafter + edigits + 1); - if (sign != SIGN_NONE) - nblanks--; - - /* Check the value fits in the specified field width. */ - if (nblanks < 0 || edigits == -1) - { - star_fill (out, w); - return; - } - - /* See if we have space for a zero before the decimal point. */ - if (nbefore == 0 && nblanks > 0) - { - leadzero = 1; - nblanks--; - } - else - leadzero = 0; - - /* Pad to full field width. */ - - if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank) - { - memset (out, ' ', nblanks); - out += nblanks; - } - - /* Output the initial sign (if any). */ - if (sign == SIGN_PLUS) - *(out++) = '+'; - else if (sign == SIGN_MINUS) - *(out++) = '-'; - - /* Output an optional leading zero. */ - if (leadzero) - *(out++) = '0'; - - /* Output the part before the decimal point, padding with zeros. */ - if (nbefore > 0) - { - if (nbefore > ndigits) - { - i = ndigits; - memcpy (out, digits, i); - ndigits = 0; - while (i < nbefore) - out[i++] = '0'; - } - else - { - i = nbefore; - memcpy (out, digits, i); - ndigits -= i; - } - - digits += i; - out += nbefore; - } - /* Output the decimal point. */ - *(out++) = '.'; - - /* Output leading zeros after the decimal point. */ - if (nzero > 0) - { - for (i = 0; i < nzero; i++) - *(out++) = '0'; - } - - /* Output digits after the decimal point, padding with zeros. */ - if (nafter > 0) - { - if (nafter > ndigits) - i = ndigits; - else - i = nafter; - - memcpy (out, digits, i); - while (i < nafter) - out[i++] = '0'; - - digits += i; - ndigits -= i; - out += nafter; - } - - /* Output the exponent. */ - if (expchar) - { - if (expchar != ' ') - { - *(out++) = expchar; - edigits--; - } -#if HAVE_SNPRINTF - snprintf (buffer, sizeof (buffer), "%+0*d", edigits, e); -#else - sprintf (buffer, "%+0*d", edigits, e); -#endif - memcpy (out, buffer, edigits); - } - - if (dtp->u.p.no_leading_blank) - { - out += edigits; - memset( out , ' ' , nblanks ); - dtp->u.p.no_leading_blank = 0; - } -#undef STR -#undef STR1 -#undef MIN_FIELD_WIDTH -} - void write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len) @@ -898,108 +244,6 @@ write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len) p[f->u.w - 1] = (n) ? 'T' : 'F'; } -/* Output a real number according to its format. */ - -static void -write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len) -{ - GFC_REAL_LARGEST n; - int nb =0, res, save_scale_factor; - char * p, fin; - fnode *f2 = NULL; - - n = extract_real (source, len); - - if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z) - { - res = isfinite (n); - if (res == 0) - { - nb = f->u.real.w; - - /* If the field width is zero, the processor must select a width - not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */ - - if (nb == 0) nb = 4; - p = write_block (dtp, nb); - if (p == NULL) - return; - if (nb < 3) - { - memset (p, '*',nb); - return; - } - - memset(p, ' ', nb); - res = !isnan (n); - if (res != 0) - { - if (signbit(n)) - { - - /* If the sign is negative and the width is 3, there is - insufficient room to output '-Inf', so output asterisks */ - - if (nb == 3) - { - memset (p, '*',nb); - return; - } - - /* The negative sign is mandatory */ - - fin = '-'; - } - else - - /* The positive sign is optional, but we output it for - consistency */ - - fin = '+'; - - if (nb > 8) - - /* We have room, so output 'Infinity' */ - - memcpy(p + nb - 8, "Infinity", 8); - else - - /* For the case of width equals 8, there is not enough room - for the sign and 'Infinity' so we go with 'Inf' */ - - memcpy(p + nb - 3, "Inf", 3); - if (nb < 9 && nb > 3) - p[nb - 4] = fin; /* Put the sign in front of Inf */ - else if (nb > 8) - p[nb - 9] = fin; /* Put the sign in front of Infinity */ - } - else - memcpy(p + nb - 3, "NaN", 3); - return; - } - } - - if (f->format != FMT_G) - output_float (dtp, f, n); - else - { - save_scale_factor = dtp->u.p.scale_factor; - f2 = calculate_G_format (dtp, f, n, &nb); - output_float (dtp, f2, n); - dtp->u.p.scale_factor = save_scale_factor; - if (f2 != NULL) - free_mem(f2); - - if (nb > 0) - { - p = write_block (dtp, nb); - if (p == NULL) - return; - memset (p, ' ', nb); - } - } -} - static void write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len, @@ -1454,23 +698,23 @@ write_real (st_parameter_dt *dtp, const char *source, int length) switch (length) { case 4: - f.u.real.w = 14; - f.u.real.d = 7; + f.u.real.w = 15; + f.u.real.d = 8; f.u.real.e = 2; break; case 8: - f.u.real.w = 23; - f.u.real.d = 15; + f.u.real.w = 25; + f.u.real.d = 17; f.u.real.e = 3; break; case 10: - f.u.real.w = 28; - f.u.real.d = 19; + f.u.real.w = 29; + f.u.real.d = 20; f.u.real.e = 4; break; case 16: - f.u.real.w = 43; - f.u.real.d = 34; + f.u.real.w = 44; + f.u.real.d = 35; f.u.real.e = 4; break; default: @@ -1624,6 +868,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, size_t base_name_len; size_t base_var_name_len; size_t tot_len; + unit_delim tmp_delim; /* Write namelist variable names in upper case. If a derived type, nothing is output. If a component, base and base_name are set. */ @@ -1719,7 +964,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, { if (rep_ctr > 1) { - st_sprintf(rep_buff, " %d*", rep_ctr); + sprintf(rep_buff, " %d*", rep_ctr); write_character (dtp, rep_buff, strlen (rep_buff)); dtp->u.p.no_leading_blank = 1; } @@ -1740,11 +985,13 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, break; case GFC_DTYPE_CHARACTER: - if (dtp->u.p.nml_delim) - write_character (dtp, &dtp->u.p.nml_delim, 1); + tmp_delim = dtp->u.p.current_unit->flags.delim; + if (dtp->u.p.nml_delim == '"') + dtp->u.p.current_unit->flags.delim = DELIM_QUOTE; + if (dtp->u.p.nml_delim == '\'') + dtp->u.p.current_unit->flags.delim = DELIM_APOSTROPHE; write_character (dtp, p, obj->string_length); - if (dtp->u.p.nml_delim) - write_character (dtp, &dtp->u.p.nml_delim, 1); + dtp->u.p.current_unit->flags.delim = tmp_delim; break; case GFC_DTYPE_REAL: @@ -1792,7 +1039,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, ext_name[tot_len] = '('; tot_len++; } - st_sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx); + sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx); tot_len += strlen (ext_name + tot_len); ext_name[tot_len] = (dim_i == obj->var_rank - 1) ? ')' : ','; tot_len++; @@ -1886,7 +1133,6 @@ namelist_write (st_parameter_dt *dtp) /* Set the delimiter for namelist output. */ tmp_delim = dtp->u.p.current_unit->flags.delim; - dtp->u.p.current_unit->flags.delim = DELIM_NONE; switch (tmp_delim) { case (DELIM_QUOTE): @@ -1902,10 +1148,12 @@ namelist_write (st_parameter_dt *dtp) break; } + /* Temporarily disable namelist delimters. */ + dtp->u.p.current_unit->flags.delim = DELIM_NONE; + write_character (dtp, "&", 1); /* Write namelist name in upper case - f95 std. */ - for (i = 0 ;i < dtp->namelist_name_len ;i++ ) { c = toupper (dtp->namelist_name[i]); @@ -1921,14 +1169,14 @@ namelist_write (st_parameter_dt *dtp) t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name); } } + #ifdef HAVE_CRLF write_character (dtp, " /\r\n", 5); #else write_character (dtp, " /\n", 4); #endif - /* Recover the original delimiter. */ - + /* Restore the original delimiter. */ dtp->u.p.current_unit->flags.delim = tmp_delim; } diff --git a/libgfortran/io/write_float.def b/libgfortran/io/write_float.def new file mode 100644 index 00000000000..4642013ae98 --- /dev/null +++ b/libgfortran/io/write_float.def @@ -0,0 +1,812 @@ +/* Copyright (C) 2007 Free Software Foundation, Inc. + Contributed by Andy Vaught + Write float code factoring to this file by Jerry DeLisle + +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, 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, 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#include "config.h" + +typedef enum +{ SIGN_NONE, SIGN_MINUS, SIGN_PLUS } +sign_t; + +/* Given a flag that indicates if a value is negative or not, return a + sign_t that gives the sign that we need to produce. */ + +static sign_t +calculate_sign (st_parameter_dt *dtp, int negative_flag) +{ + sign_t s = SIGN_NONE; + + if (negative_flag) + s = SIGN_MINUS; + else + switch (dtp->u.p.sign_status) + { + case SIGN_SP: + s = SIGN_PLUS; + break; + case SIGN_SS: + s = SIGN_NONE; + break; + case SIGN_S: + s = options.optional_plus ? SIGN_PLUS : SIGN_NONE; + break; + } + + return s; +} + + +/* Output a real number according to its format which is FMT_G free. */ + +static void +output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size, + int sign_bit, bool zero_flag, int ndigits, int edigits) +{ + char *out; + char *digits; + int e; + char expchar; + format_token ft; + int w; + int d; + /* Number of digits before the decimal point. */ + int nbefore; + /* Number of zeros after the decimal point. */ + int nzero; + /* Number of digits after the decimal point. */ + int nafter; + /* Number of zeros after the decimal point, whatever the precision. */ + int nzero_real; + int leadzero; + int nblanks; + int i; + sign_t sign; + + ft = f->format; + w = f->u.real.w; + d = f->u.real.d; + + nzero_real = -1; + + /* We should always know the field width and precision. */ + if (d < 0) + internal_error (&dtp->common, "Unspecified precision"); + + /* Use sprintf to print the number in the format +D.DDDDe+ddd + For an N digit exponent, this gives us (MIN_FIELD_WIDTH-5)-N digits + after the decimal point, plus another one before the decimal point. */ + + sign = calculate_sign (dtp, sign_bit); + + /* # The result will always contain a decimal point, even if no + * digits follow it + * + * - The converted value is to be left adjusted on the field boundary + * + * + A sign (+ or -) always be placed before a number + * + * MIN_FIELD_WIDTH minimum field width + * + * * (ndigits-1) is used as the precision + * + * e format: [-]d.ddde±dd where there is one digit before the + * decimal-point character and the number of digits after it is + * equal to the precision. The exponent always contains at least two + * digits; if the value is zero, the exponent is 00. + */ + + /* Check the given string has punctuation in the correct places. */ + if (d != 0 && (buffer[2] != '.' || buffer[ndigits + 2] != 'e')) + internal_error (&dtp->common, "printf is broken"); + + /* Read the exponent back in. */ + e = atoi (&buffer[ndigits + 3]) + 1; + + /* Make sure zero comes out as 0.0e0. */ + if (zero_flag) + { + e = 0; + if (compile_options.sign_zero == 1) + sign = calculate_sign (dtp, sign_bit); + else + sign = calculate_sign (dtp, 0); + } + + /* Normalize the fractional component. */ + buffer[2] = buffer[1]; + digits = &buffer[2]; + + /* Figure out where to place the decimal point. */ + switch (ft) + { + case FMT_F: + nbefore = e + dtp->u.p.scale_factor; + if (nbefore < 0) + { + nzero = -nbefore; + nzero_real = nzero; + if (nzero > d) + nzero = d; + nafter = d - nzero; + nbefore = 0; + } + else + { + nzero = 0; + nafter = d; + } + expchar = 0; + break; + + case FMT_E: + case FMT_D: + i = dtp->u.p.scale_factor; + if (!zero_flag) + e -= i; + if (i < 0) + { + nbefore = 0; + nzero = -i; + nafter = d + i; + } + else if (i > 0) + { + nbefore = i; + nzero = 0; + nafter = (d - i) + 1; + } + else /* i == 0 */ + { + nbefore = 0; + nzero = 0; + nafter = d; + } + + if (ft == FMT_E) + expchar = 'E'; + else + expchar = 'D'; + break; + + case FMT_EN: + /* The exponent must be a multiple of three, with 1-3 digits before + the decimal point. */ + if (!zero_flag) + e--; + if (e >= 0) + nbefore = e % 3; + else + { + nbefore = (-e) % 3; + if (nbefore != 0) + nbefore = 3 - nbefore; + } + e -= nbefore; + nbefore++; + nzero = 0; + nafter = d; + expchar = 'E'; + break; + + case FMT_ES: + if (!zero_flag) + e--; + nbefore = 1; + nzero = 0; + nafter = d; + expchar = 'E'; + break; + + default: + /* Should never happen. */ + internal_error (&dtp->common, "Unexpected format token"); + } + + /* Round the value. */ + if (nbefore + nafter == 0) + { + ndigits = 0; + if (nzero_real == d && digits[0] >= '5') + { + /* We rounded to zero but shouldn't have */ + nzero--; + nafter = 1; + digits[0] = '1'; + ndigits = 1; + } + } + else if (nbefore + nafter < ndigits) + { + ndigits = nbefore + nafter; + i = ndigits; + if (digits[i] >= '5') + { + /* Propagate the carry. */ + for (i--; i >= 0; i--) + { + if (digits[i] != '9') + { + digits[i]++; + break; + } + digits[i] = '0'; + } + + if (i < 0) + { + /* The carry overflowed. Fortunately we have some spare space + at the start of the buffer. We may discard some digits, but + this is ok because we already know they are zero. */ + digits--; + digits[0] = '1'; + if (ft == FMT_F) + { + if (nzero > 0) + { + nzero--; + nafter++; + } + else + nbefore++; + } + else if (ft == FMT_EN) + { + nbefore++; + if (nbefore == 4) + { + nbefore = 1; + e += 3; + } + } + else + e++; + } + } + } + + /* Calculate the format of the exponent field. */ + if (expchar) + { + edigits = 1; + for (i = abs (e); i >= 10; i /= 10) + edigits++; + + if (f->u.real.e < 0) + { + /* Width not specified. Must be no more than 3 digits. */ + if (e > 999 || e < -999) + edigits = -1; + else + { + edigits = 4; + if (e > 99 || e < -99) + expchar = ' '; + } + } + else + { + /* Exponent width specified, check it is wide enough. */ + if (edigits > f->u.real.e) + edigits = -1; + else + edigits = f->u.real.e + 2; + } + } + else + edigits = 0; + + /* Pick a field size if none was specified. */ + if (w <= 0) + w = nbefore + nzero + nafter + (sign != SIGN_NONE ? 2 : 1); + + /* Create the ouput buffer. */ + out = write_block (dtp, w); + if (out == NULL) + return; + + /* Zero values always output as positive, even if the value was negative + before rounding. */ + for (i = 0; i < ndigits; i++) + { + if (digits[i] != '0') + break; + } + if (i == ndigits) + { + /* The output is zero, so set the sign according to the sign bit unless + -fno-sign-zero was specified. */ + if (compile_options.sign_zero == 1) + sign = calculate_sign (dtp, sign_bit); + else + sign = calculate_sign (dtp, 0); + } + + /* Work out how much padding is needed. */ + nblanks = w - (nbefore + nzero + nafter + edigits + 1); + if (sign != SIGN_NONE) + nblanks--; + + /* Check the value fits in the specified field width. */ + if (nblanks < 0 || edigits == -1) + { + star_fill (out, w); + return; + } + + /* See if we have space for a zero before the decimal point. */ + if (nbefore == 0 && nblanks > 0) + { + leadzero = 1; + nblanks--; + } + else + leadzero = 0; + + /* Pad to full field width. */ + + if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank) + { + memset (out, ' ', nblanks); + out += nblanks; + } + + /* Output the initial sign (if any). */ + if (sign == SIGN_PLUS) + *(out++) = '+'; + else if (sign == SIGN_MINUS) + *(out++) = '-'; + + /* Output an optional leading zero. */ + if (leadzero) + *(out++) = '0'; + + /* Output the part before the decimal point, padding with zeros. */ + if (nbefore > 0) + { + if (nbefore > ndigits) + { + i = ndigits; + memcpy (out, digits, i); + ndigits = 0; + while (i < nbefore) + out[i++] = '0'; + } + else + { + i = nbefore; + memcpy (out, digits, i); + ndigits -= i; + } + + digits += i; + out += nbefore; + } + /* Output the decimal point. */ + *(out++) = '.'; + + /* Output leading zeros after the decimal point. */ + if (nzero > 0) + { + for (i = 0; i < nzero; i++) + *(out++) = '0'; + } + + /* Output digits after the decimal point, padding with zeros. */ + if (nafter > 0) + { + if (nafter > ndigits) + i = ndigits; + else + i = nafter; + + memcpy (out, digits, i); + while (i < nafter) + out[i++] = '0'; + + digits += i; + ndigits -= i; + out += nafter; + } + + /* Output the exponent. */ + if (expchar) + { + if (expchar != ' ') + { + *(out++) = expchar; + edigits--; + } +#if HAVE_SNPRINTF + snprintf (buffer, size, "%+0*d", edigits, e); +#else + sprintf (buffer, "%+0*d", edigits, e); +#endif + memcpy (out, buffer, edigits); + } + if (dtp->u.p.no_leading_blank) + { + out += edigits; + memset( out , ' ' , nblanks ); + dtp->u.p.no_leading_blank = 0; + } +#undef STR +#undef STR1 +#undef MIN_FIELD_WIDTH +} + + +/* Write "Infinite" or "Nan" as appropriate for the given format. */ + +static void +write_infnan (st_parameter_dt *dtp, const fnode *f, int isnan_flag, int sign_bit) +{ + char * p, fin; + int nb = 0; + + if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z) + { + nb = f->u.real.w; + + /* If the field width is zero, the processor must select a width + not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */ + + if (nb == 0) nb = 4; + p = write_block (dtp, nb); + if (p == NULL) + return; + if (nb < 3) + { + memset (p, '*',nb); + return; + } + + memset(p, ' ', nb); + if (!isnan_flag) + { + if (sign_bit) + { + + /* If the sign is negative and the width is 3, there is + insufficient room to output '-Inf', so output asterisks */ + + if (nb == 3) + { + memset (p, '*',nb); + return; + } + + /* The negative sign is mandatory */ + + fin = '-'; + } + else + + /* The positive sign is optional, but we output it for + consistency */ + fin = '+'; + + if (nb > 8) + + /* We have room, so output 'Infinity' */ + memcpy(p + nb - 8, "Infinity", 8); + else + + /* For the case of width equals 8, there is not enough room + for the sign and 'Infinity' so we go with 'Inf' */ + memcpy(p + nb - 3, "Inf", 3); + + if (nb < 9 && nb > 3) + p[nb - 4] = fin; /* Put the sign in front of Inf */ + else if (nb > 8) + p[nb - 9] = fin; /* Put the sign in front of Infinity */ + } + else + memcpy(p + nb - 3, "NaN", 3); + return; + } + } + + +/* Returns the value of 10**d. */ + +#define CALCULATE_EXP(x) \ +inline static GFC_REAL_ ## x \ +calculate_exp_ ## x (int d)\ +{\ + int i;\ + GFC_REAL_ ## x r = 1.0;\ + for (i = 0; i< (d >= 0 ? d : -d); i++)\ + r *= 10;\ + r = (d >= 0) ? r : 1.0 / r;\ + return r;\ +} + +CALCULATE_EXP(4) + +CALCULATE_EXP(8) + +#ifdef HAVE_GFC_REAL_10 +CALCULATE_EXP(10) +#endif + +#ifdef HAVE_GFC_REAL_16 +CALCULATE_EXP(16) +#endif +#undef CALCULATE_EXP + +/* Generate corresponding I/O format for FMT_G and output. + The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran + LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is: + + Data Magnitude Equivalent Conversion + 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee] + m = 0 F(w-n).(d-1), n' ' + 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' ' + 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' ' + 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' ' + ................ .......... + 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ') + m >= 10**d-0.5 Ew.d[Ee] + + notes: for Gw.d , n' ' means 4 blanks + for Gw.dEe, n' ' means e+2 blanks */ + +#define OUTPUT_FLOAT_FMT_G(x) \ +static void \ +output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \ + GFC_REAL_ ## x m, char *buffer, size_t size, \ + int sign_bit, bool zero_flag, int ndigits, int edigits) \ +{ \ + int e = f->u.real.e;\ + int d = f->u.real.d;\ + int w = f->u.real.w;\ + fnode *newf;\ + GFC_REAL_ ## x exp_d;\ + int low, high, mid;\ + int ubound, lbound;\ + char *p;\ + int save_scale_factor, nb = 0;\ +\ + save_scale_factor = dtp->u.p.scale_factor;\ + newf = get_mem (sizeof (fnode));\ +\ + exp_d = calculate_exp_ ## x (d);\ + if ((m > 0.0 && m < 0.1 - 0.05 / exp_d) || (m >= exp_d - 0.5 ) ||\ + ((m == 0.0) && !(compile_options.allow_std & GFC_STD_F2003)))\ + { \ + newf->format = FMT_E;\ + newf->u.real.w = w;\ + newf->u.real.d = d;\ + newf->u.real.e = e;\ + nb = 0;\ + goto finish;\ + }\ +\ + mid = 0;\ + low = 0;\ + high = d + 1;\ + lbound = 0;\ + ubound = d + 1;\ +\ + while (low <= high)\ + { \ + GFC_REAL_ ## x temp;\ + mid = (low + high) / 2;\ +\ + temp = 0.1 * calculate_exp_ ## x (mid) - 0.5\ + * calculate_exp_ ## x (mid - d - 1);\ +\ + if (m < temp)\ + { \ + ubound = mid;\ + if (ubound == lbound + 1)\ + break;\ + high = mid - 1;\ + }\ + else if (m > temp)\ + { \ + lbound = mid;\ + if (ubound == lbound + 1)\ + { \ + mid ++;\ + break;\ + }\ + low = mid + 1;\ + }\ + else\ + break;\ + }\ +\ + if (e < 0)\ + nb = 4;\ + else\ + nb = e + 2;\ +\ + newf->format = FMT_F;\ + newf->u.real.w = f->u.real.w - nb;\ +\ + if (m == 0.0)\ + newf->u.real.d = d - 1;\ + else\ + newf->u.real.d = - (mid - d - 1);\ +\ + dtp->u.p.scale_factor = 0;\ +\ + finish:\ + output_float (dtp, newf, buffer, size, sign_bit, zero_flag, ndigits, \ + edigits);\ + dtp->u.p.scale_factor = save_scale_factor;\ +\ + free_mem(newf);\ +\ + if (nb > 0)\ + { \ + p = write_block (dtp, nb);\ + if (p == NULL)\ + return;\ + memset (p, ' ', nb);\ + }\ +}\ + +OUTPUT_FLOAT_FMT_G(4) + +OUTPUT_FLOAT_FMT_G(8) + +#ifdef HAVE_GFC_REAL_10 +OUTPUT_FLOAT_FMT_G(10) +#endif + +#ifdef HAVE_GFC_REAL_16 +OUTPUT_FLOAT_FMT_G(16) +#endif + +#undef OUTPUT_FLOAT_FMT_G + +/* Define a macro to build code for write_float. */ + +#ifdef HAVE_SNPRINTF + +#define DTOA \ +snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \ + "e", ndigits - 1, tmp); + +#define DTOAL \ +snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \ + "Le", ndigits - 1, tmp); + +#else + +#define DTOA \ +sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \ + "e", ndigits - 1, tmp); + +#define DTOAL \ +sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \ + "Le", ndigits - 1, tmp); + +#endif + +#define WRITE_FLOAT(x,y)\ +{\ + GFC_REAL_ ## x tmp;\ + tmp = * (GFC_REAL_ ## x *)source;\ + sign_bit = signbit (tmp);\ + if (!isfinite (tmp))\ + { \ + write_infnan (dtp, f, isnan (tmp), sign_bit);\ + return;\ + }\ + tmp = sign_bit ? -tmp : tmp;\ + if (f->u.real.d == 0 && f->format == FMT_F)\ + {\ + if (tmp < 0.5)\ + tmp = 0.0;\ + else if (tmp < 1.0)\ + tmp = tmp + 0.5;\ + }\ + zero_flag = (tmp == 0.0);\ +\ + DTOA ## y\ +\ + if (f->format != FMT_G)\ + output_float (dtp, f, buffer, size, sign_bit, zero_flag, ndigits, \ + edigits);\ + else \ + output_float_FMT_G_ ## x (dtp, f, tmp, buffer, size, sign_bit, \ + zero_flag, ndigits, edigits);\ +}\ + +/* Output a real number according to its format. */ + +static void +write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len) +{ + +#if defined(HAVE_GFC_REAL_16) && __LDBL_DIG__ > 18 +# define MIN_FIELD_WIDTH 46 +#else +# define MIN_FIELD_WIDTH 31 +#endif +#define STR(x) STR1(x) +#define STR1(x) #x + + /* This must be large enough to accurately hold any value. */ + char buffer[MIN_FIELD_WIDTH+1]; + int sign_bit, ndigits, edigits; + bool zero_flag; + size_t size; + + size = MIN_FIELD_WIDTH+1; + + /* printf pads blanks for us on the exponent so we just need it big enough + to handle the largest number of exponent digits expected. */ + edigits=4; + + if (f->format == FMT_F || f->format == FMT_EN || f->format == FMT_G + || ((f->format == FMT_D || f->format == FMT_E) + && dtp->u.p.scale_factor != 0)) + { + /* Always convert at full precision to avoid double rounding. */ + ndigits = MIN_FIELD_WIDTH - 4 - edigits; + } + else + { + /* The number of digits is known, so let printf do the rounding. */ + if (f->format == FMT_ES) + ndigits = f->u.real.d + 1; + else + ndigits = f->u.real.d; + if (ndigits > MIN_FIELD_WIDTH - 4 - edigits) + ndigits = MIN_FIELD_WIDTH - 4 - edigits; + } + + switch (len) + { + case 4: + WRITE_FLOAT(4,) + break; + + case 8: + WRITE_FLOAT(8,) + break; + +#ifdef HAVE_GFC_REAL_10 + case 10: + WRITE_FLOAT(10,L) + break; +#endif +#ifdef HAVE_GFC_REAL_16 + case 16: + WRITE_FLOAT(16,L) + break; +#endif + default: + internal_error (NULL, "bad real kind"); + } +} diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index a1efab26aa9..427b2fadbab 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -31,13 +31,14 @@ Boston, MA 02110-1301, USA. */ #ifndef LIBGFOR_H #define LIBGFOR_H +/* config.h MUST be first because it can affect system headers. */ +#include "config.h" + +#include <stdio.h> #include <math.h> #include <stddef.h> #include <float.h> - -#ifndef M_PI -#define M_PI 3.14159265358979323846264338327 -#endif +#include <stdarg.h> #if HAVE_COMPLEX_H # include <complex.h> @@ -45,7 +46,8 @@ Boston, MA 02110-1301, USA. */ #define complex __complex__ #endif -#include "config.h" +#include "../gcc/fortran/libgfortran.h" + #include "c99_protos.h" #if HAVE_IEEEFP_H @@ -68,6 +70,16 @@ typedef off_t gfc_offset; #endif +/* On mingw, work around the buggy Windows snprintf() by using the one + mingw provides, __mingw_snprintf(). We also provide a prototype for + __mingw_snprintf(), because the mingw headers currently don't have one. */ +#if HAVE_MINGW_SNPRINTF +extern int __mingw_snprintf (char *, size_t, const char *, ...); +#undef snprintf +#define snprintf __mingw_snprintf +#endif + + /* For a library, a standard prefix is a requirement in order to partition the namespace. IPREFIX is for symbols intended to be internal to the library. */ @@ -221,8 +233,8 @@ typedef GFC_INTEGER_4 gfc_charlen_type; extern int l8_to_l4_offset; internal_proto(l8_to_l4_offset); -#define GFOR_POINTER_L8_TO_L4(p8) \ - (l8_to_l4_offset + (GFC_LOGICAL_4 *)(p8)) +#define GFOR_POINTER_TO_L1(p, kind) \ + (l8_to_l4_offset * (kind - 1) + (GFC_LOGICAL_1 *)(p)) #define GFC_INTEGER_1_HUGE \ (GFC_INTEGER_1)((((GFC_UINTEGER_1)1) << 7) - 1) @@ -237,36 +249,6 @@ internal_proto(l8_to_l4_offset); (GFC_INTEGER_16)((((GFC_UINTEGER_16)1) << 127) - 1) #endif -#define GFC_REAL_4_HUGE FLT_MAX -#define GFC_REAL_8_HUGE DBL_MAX -#ifdef HAVE_GFC_REAL_10 -#define GFC_REAL_10_HUGE LDBL_MAX -#endif -#ifdef HAVE_GFC_REAL_16 -#define GFC_REAL_16_HUGE LDBL_MAX -#endif - -#define GFC_REAL_4_DIGITS FLT_MANT_DIG -#define GFC_REAL_8_DIGITS DBL_MANT_DIG -#ifdef HAVE_GFC_REAL_10 -#define GFC_REAL_10_DIGITS LDBL_MANT_DIG -#endif -#ifdef HAVE_GFC_REAL_16 -#define GFC_REAL_16_DIGITS LDBL_MANT_DIG -#endif - -#define GFC_REAL_4_RADIX FLT_RADIX -#define GFC_REAL_8_RADIX FLT_RADIX -#ifdef HAVE_GFC_REAL_10 -#define GFC_REAL_10_RADIX FLT_RADIX -#endif -#ifdef HAVE_GFC_REAL_16 -#define GFC_REAL_16_RADIX FLT_RADIX -#endif - -#ifndef GFC_MAX_DIMENSIONS -#define GFC_MAX_DIMENSIONS 7 -#endif typedef struct descriptor_dimension { @@ -310,31 +292,14 @@ typedef GFC_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_COMPLEX_10) gfc_array_c10; #ifdef HAVE_GFC_COMPLEX_16 typedef GFC_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_COMPLEX_16) gfc_array_c16; #endif +typedef GFC_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_LOGICAL_1) gfc_array_l1; +typedef GFC_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_LOGICAL_2) gfc_array_l2; typedef GFC_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_LOGICAL_4) gfc_array_l4; typedef GFC_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_LOGICAL_8) gfc_array_l8; #ifdef HAVE_GFC_LOGICAL_16 typedef GFC_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_LOGICAL_16) gfc_array_l16; #endif -#define GFC_DTYPE_RANK_MASK 0x07 -#define GFC_DTYPE_TYPE_SHIFT 3 -#define GFC_DTYPE_TYPE_MASK 0x38 -#define GFC_DTYPE_SIZE_SHIFT 6 - -/* added for f03. --Rickett, 02.28.06 */ -#define GFC_NUM_RANK_BITS 3 - -enum -{ - GFC_DTYPE_UNKNOWN = 0, - GFC_DTYPE_INTEGER, - /* TODO: recognize logical types. */ - GFC_DTYPE_LOGICAL, - GFC_DTYPE_REAL, - GFC_DTYPE_COMPLEX, - GFC_DTYPE_DERIVED, - GFC_DTYPE_CHARACTER -}; #define GFC_DESCRIPTOR_RANK(desc) ((desc)->dtype & GFC_DTYPE_RANK_MASK) #define GFC_DESCRIPTOR_TYPE(desc) (((desc)->dtype & GFC_DTYPE_TYPE_MASK) \ @@ -352,25 +317,22 @@ enum typedef struct { int stdin_unit, stdout_unit, stderr_unit, optional_plus; - int allocate_init_flag, allocate_init_value; int locus; int separator_len; const char *separator; - int mem_check; - int use_stderr, all_unbuffered, default_recl; - - int fpu_round, fpu_precision, fpe; - - int sighup, sigint; - int dump_core, backtrace; + int use_stderr, all_unbuffered, unbuffered_preconnected, default_recl; + int fpe, dump_core, backtrace; } options_t; extern options_t options; internal_proto(options); +extern void handler (int); +internal_proto(handler); + /* Compile-time options that will influence the library. */ @@ -406,58 +368,6 @@ typedef struct } st_option; -/* Runtime errors. The EOR and EOF errors are required to be negative. - These codes must be kept sychronized with their equivalents in - gcc/fortran/gfortran.h . */ - -typedef enum -{ - ERROR_FIRST = -3, /* Marker for the first error. */ - ERROR_EOR = -2, - ERROR_END = -1, - ERROR_OK = 0, /* Indicates success, must be zero. */ - ERROR_OS = 5000, /* Operating system error, more info in errno. */ - ERROR_OPTION_CONFLICT, - ERROR_BAD_OPTION, - ERROR_MISSING_OPTION, - ERROR_ALREADY_OPEN, - ERROR_BAD_UNIT, - ERROR_FORMAT, - ERROR_BAD_ACTION, - ERROR_ENDFILE, - ERROR_BAD_US, - ERROR_READ_VALUE, - ERROR_READ_OVERFLOW, - ERROR_INTERNAL, - ERROR_INTERNAL_UNIT, - ERROR_ALLOCATION, - ERROR_DIRECT_EOR, - ERROR_SHORT_RECORD, - ERROR_CORRUPT_FILE, - ERROR_LAST /* Not a real error, the last error # + 1. */ -} -error_codes; - - -/* Flags to specify which standard/extension contains a feature. - Keep them in sync with their counterparts in gcc/fortran/gfortran.h. */ -#define GFC_STD_LEGACY (1<<6) /* Backward compatibility. */ -#define GFC_STD_GNU (1<<5) /* GNU Fortran extension. */ -#define GFC_STD_F2003 (1<<4) /* New in F2003. */ -/* Note that no features were obsoleted nor deleted in F2003. */ -#define GFC_STD_F95 (1<<3) /* New in F95. */ -#define GFC_STD_F95_DEL (1<<2) /* Deleted in F95. */ -#define GFC_STD_F95_OBS (1<<1) /* Obsoleted in F95. */ -#define GFC_STD_F77 (1<<0) /* Up to and including F77. */ - -/* Bitmasks for the various FPE that can be enabled. - Keep them in sync with their counterparts in gcc/fortran/gfortran.h. */ -#define GFC_FPE_INVALID (1<<0) -#define GFC_FPE_DENORMAL (1<<1) -#define GFC_FPE_ZERO (1<<2) -#define GFC_FPE_OVERFLOW (1<<3) -#define GFC_FPE_UNDERFLOW (1<<4) -#define GFC_FPE_PRECISION (1<<5) /* This is returned by notification_std to know if, given the flags that were given (-std=, -pedantic) we should issue an error, a warning @@ -486,8 +396,8 @@ iexport_data_proto(filename); #define gfc_alloca(x) __builtin_alloca(x) -/* Various I/O stuff also used in other parts of the library. */ - +/* Directory for creating temporary files. Only used when none of the + following environment variables exist: GFORTRAN_TMPDIR, TMP and TEMP. */ #define DEFAULT_TEMPDIR "/tmp" /* The default value of record length for preconnected units is defined @@ -495,9 +405,6 @@ iexport_data_proto(filename); Default value is 1 Gb. */ #define DEFAULT_RECL 1073741824 -typedef enum -{ CONVERT_NONE=-1, CONVERT_NATIVE, CONVERT_SWAP, CONVERT_BIG, CONVERT_LITTLE } -unit_convert; #define CHARACTER2(name) \ gfc_charlen_type name ## _len; \ @@ -593,11 +500,12 @@ iexport_proto(os_error); extern void show_locus (st_parameter_common *); internal_proto(show_locus); -extern void runtime_error (const char *) __attribute__ ((noreturn)); +extern void runtime_error (const char *, ...) + __attribute__ ((noreturn, format (printf, 1, 2))); iexport_proto(runtime_error); -extern void runtime_error_at (const char *, const char *) -__attribute__ ((noreturn)); +extern void runtime_error_at (const char *, const char *, ...) + __attribute__ ((noreturn, format (printf, 2, 3))); iexport_proto(runtime_error_at); extern void internal_error (st_parameter_common *, const char *) @@ -607,10 +515,6 @@ internal_proto(internal_error); extern const char *get_oserror (void); internal_proto(get_oserror); -extern void st_sprintf (char *, const char *, ...) - __attribute__ ((format (printf, 2, 3))); -internal_proto(st_sprintf); - extern const char *translate_error (int); internal_proto(translate_error); @@ -688,6 +592,9 @@ extern int st_printf (const char *, ...) __attribute__ ((format (printf, 1, 2))); internal_proto(st_printf); +extern int st_vprintf (const char *, va_list); +internal_proto(st_vprintf); + extern char * filename_from_unit (int); internal_proto(filename_from_unit); @@ -757,15 +664,18 @@ internal_proto(internal_unpack_c16); /* string_intrinsics.c */ -extern GFC_INTEGER_4 compare_string (GFC_INTEGER_4, const char *, - GFC_INTEGER_4, const char *); +extern int compare_string (GFC_INTEGER_4, const char *, + GFC_INTEGER_4, const char *); iexport_proto(compare_string); /* random.c */ -extern void random_seed (GFC_INTEGER_4 * size, gfc_array_i4 * put, - gfc_array_i4 * get); -iexport_proto(random_seed); +extern void random_seed_i4 (GFC_INTEGER_4 * size, gfc_array_i4 * put, + gfc_array_i4 * get); +iexport_proto(random_seed_i4); +extern void random_seed_i8 (GFC_INTEGER_8 * size, gfc_array_i8 * put, + gfc_array_i8 * get); +iexport_proto(random_seed_i8); /* size.c */ diff --git a/libgfortran/m4/all.m4 b/libgfortran/m4/all.m4 index 297e5f36708..8d4ece3d6ce 100644 --- a/libgfortran/m4/all.m4 +++ b/libgfortran/m4/all.m4 @@ -1,5 +1,5 @@ `/* Implementation of the ALL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,15 +28,14 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> -#include <assert.h> -#include "libgfortran.h"' +#include <assert.h>' include(iparm.m4)dnl -include(ifunction.m4)dnl +include(ifunction_logical.m4)dnl -`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' +`#if defined (HAVE_'rtype_name`)' ARRAY_FUNCTION(1, ` /* Return true only if all the elements are set. */ diff --git a/libgfortran/m4/any.m4 b/libgfortran/m4/any.m4 index 70edff95440..156f6c5b828 100644 --- a/libgfortran/m4/any.m4 +++ b/libgfortran/m4/any.m4 @@ -1,5 +1,5 @@ `/* Implementation of the ANY intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,15 +28,14 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> -#include <assert.h> -#include "libgfortran.h"' +#include <assert.h>' include(iparm.m4)dnl -include(ifunction.m4)dnl +include(ifunction_logical.m4)dnl -`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' +`#if defined (HAVE_'rtype_name`)' ARRAY_FUNCTION(0, ` result = 0;', diff --git a/libgfortran/m4/count.m4 b/libgfortran/m4/count.m4 index 245d9726d37..48ce411b0ab 100644 --- a/libgfortran/m4/count.m4 +++ b/libgfortran/m4/count.m4 @@ -1,5 +1,5 @@ `/* Implementation of the COUNT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,15 +28,14 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> -#include <assert.h> -#include "libgfortran.h"' +#include <assert.h>' include(iparm.m4)dnl -include(ifunction.m4)dnl +include(ifunction_logical.m4)dnl -`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' +`#if defined (HAVE_'rtype_name`)' ARRAY_FUNCTION(0, ` result = 0;', diff --git a/libgfortran/m4/cshift1.m4 b/libgfortran/m4/cshift1.m4 index edc95cee729..735621d4f7b 100644 --- a/libgfortran/m4/cshift1.m4 +++ b/libgfortran/m4/cshift1.m4 @@ -1,5 +1,5 @@ `/* Implementation of the CSHIFT intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Feng Wang <wf_cs@yahoo.com> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include <string.h> -#include "libgfortran.h"' +#include <string.h>' + include(iparm.m4)dnl `#if defined (HAVE_'atype_name`) diff --git a/libgfortran/m4/eoshift1.m4 b/libgfortran/m4/eoshift1.m4 index d9be3423d3b..53ec168da61 100644 --- a/libgfortran/m4/eoshift1.m4 +++ b/libgfortran/m4/eoshift1.m4 @@ -1,5 +1,5 @@ `/* Implementation of the EOSHIFT intrinsic - Copyright 2002, 2005 Free Software Foundation, Inc. + Copyright 2002, 2005, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include <string.h> -#include "libgfortran.h"' +#include <string.h>' + include(iparm.m4)dnl `#if defined (HAVE_'atype_name`) diff --git a/libgfortran/m4/eoshift3.m4 b/libgfortran/m4/eoshift3.m4 index 58f12fcddd6..db04ae8f0e6 100644 --- a/libgfortran/m4/eoshift3.m4 +++ b/libgfortran/m4/eoshift3.m4 @@ -1,5 +1,5 @@ `/* Implementation of the EOSHIFT intrinsic - Copyright 2002, 2005 Free Software Foundation, Inc. + Copyright 2002, 2005, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include <string.h> -#include "libgfortran.h"' +#include <string.h>' + include(iparm.m4)dnl `#if defined (HAVE_'atype_name`) diff --git a/libgfortran/m4/exponent.m4 b/libgfortran/m4/exponent.m4 index 141d1746caa..ef0fd437fde 100644 --- a/libgfortran/m4/exponent.m4 +++ b/libgfortran/m4/exponent.m4 @@ -1,5 +1,5 @@ `/* Implementation of the EXPONENT intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h"' include(`mtype.m4')dnl diff --git a/libgfortran/m4/fraction.m4 b/libgfortran/m4/fraction.m4 index cbbed06f605..3c8ed95c40c 100644 --- a/libgfortran/m4/fraction.m4 +++ b/libgfortran/m4/fraction.m4 @@ -1,5 +1,5 @@ `/* Implementation of the FRACTION intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h"' include(`mtype.m4')dnl diff --git a/libgfortran/m4/head.m4 b/libgfortran/m4/head.m4 index 73e99b22afd..52bb112e2c9 100644 --- a/libgfortran/m4/head.m4 +++ b/libgfortran/m4/head.m4 @@ -1,4 +1,4 @@ -`! Copyright 2002 Free Software Foundation, Inc. +`! Copyright 2002, 2007 Free Software Foundation, Inc. ! Contributed by Paul Brook <paul@nowt.org> ! !This file is part of the GNU Fortran 95 runtime library (libgfortran). diff --git a/libgfortran/m4/iforeach.m4 b/libgfortran/m4/iforeach.m4 index af53cef7ecc..071900b03b8 100644 --- a/libgfortran/m4/iforeach.m4 +++ b/libgfortran/m4/iforeach.m4 @@ -36,11 +36,22 @@ name`'rtype_qual`_'atype_code (rtype * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in u_name intrinsic" + " should be 1, is %ld", (long int) ret_rank); - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " u_name intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + } } dstride = retarray->dim[0].stride; @@ -106,13 +117,13 @@ define(FINISH_FOREACH_FUNCTION, define(START_MASKED_FOREACH_FUNCTION, ` extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict, - atype * const restrict, gfc_array_l4 * const restrict); + atype * const restrict, gfc_array_l1 * const restrict); export_proto(`m'name`'rtype_qual`_'atype_code); void `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, atype * const restrict array, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -121,9 +132,10 @@ void index_type dstride; rtype_name *dest; const atype_name *base; - GFC_LOGICAL_4 *mbase; + GFC_LOGICAL_1 *mbase; int rank; index_type n; + int mask_kind; rank = GFC_DESCRIPTOR_RANK (array); if (rank <= 0) @@ -140,19 +152,62 @@ void } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in u_name intrinsic" + " should be 1, is %ld", (long int) ret_rank); - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " u_name intrnisic: is %ld, should be %ld", + (long int) ret_extent, (long int) rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in u_name intrnisic" + "should be %ld, is %ld", (long int) rank, + (long int) mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " u_name intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + dstride = retarray->dim[0].stride; dest = retarray->data; for (n = 0; n < rank; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; count[n] = 0; if (extent[n] <= 0) @@ -165,17 +220,6 @@ void } base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } - /* Initialize the return value. */ for (n = 0; n < rank; n++) @@ -267,11 +311,20 @@ void } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in u_name intrinsic" + " should be 1, is %ld", (long int) ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; diff --git a/libgfortran/m4/ifunction.m4 b/libgfortran/m4/ifunction.m4 index 225b89a7562..9769e4d2ddb 100644 --- a/libgfortran/m4/ifunction.m4 +++ b/libgfortran/m4/ifunction.m4 @@ -98,7 +98,26 @@ name`'rtype_qual`_'atype_code (rtype * const restrict retarray, else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in" + " u_name intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " u_name intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } } for (n = 0; n < rank; n++) @@ -166,14 +185,14 @@ define(START_MASKED_ARRAY_FUNCTION, ` extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict, atype * const restrict, const index_type * const restrict, - gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict); export_proto(`m'name`'rtype_qual`_'atype_code); void `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, atype * const restrict array, const index_type * const restrict pdim, - gfc_array_l4 * const restrict mask) + gfc_array_l1 * const restrict mask) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -182,13 +201,14 @@ void index_type mstride[GFC_MAX_DIMENSIONS]; rtype_name * restrict dest; const atype_name * restrict base; - const GFC_LOGICAL_4 * restrict mbase; + const GFC_LOGICAL_1 * restrict mbase; int rank; int dim; index_type n; index_type len; index_type delta; index_type mdelta; + int mask_kind; dim = (*pdim) - 1; rank = GFC_DESCRIPTOR_RANK (array) - 1; @@ -196,13 +216,27 @@ void len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; if (len <= 0) return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride; + mdelta = mask->dim[dim].stride * mask_kind; for (n = 0; n < dim; n++) { sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride; + mstride[n] = mask->dim[n].stride * mask_kind; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; if (extent[n] < 0) @@ -212,7 +246,7 @@ void for (n = dim; n < rank; n++) { sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride; + mstride[n] = mask->dim[n + 1].stride * mask_kind; extent[n] = array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; @@ -254,7 +288,35 @@ void else { if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect"); + runtime_error ("rank of return array incorrect in u_name intrinsic"); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " u_name intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + for (n=0; n<= rank; n++) + { + index_type mask_extent, array_extent; + + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " u_name intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } for (n = 0; n < rank; n++) @@ -267,22 +329,11 @@ void dest = retarray->data; base = array->data; - mbase = mask->data; - - if (GFC_DESCRIPTOR_SIZE (mask) != 4) - { - /* This allows the same loop to be used for all logical types. */ - assert (GFC_DESCRIPTOR_SIZE (mask) == 8); - for (n = 0; n < rank; n++) - mstride[n] <<= 1; - mdelta <<= 1; - mbase = (GFOR_POINTER_L8_TO_L4 (mbase)); - } while (base) { const atype_name * restrict src; - const GFC_LOGICAL_4 * restrict msrc; + const GFC_LOGICAL_1 * restrict msrc; rtype_name result; src = base; msrc = mbase; @@ -372,13 +423,21 @@ void } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); - } + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in u_name intrinsic" + " should be 1, is %ld", (long int) ret_rank); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } + } dstride = retarray->dim[0].stride; dest = retarray->data; diff --git a/libgfortran/m4/ifunction_logical.m4 b/libgfortran/m4/ifunction_logical.m4 new file mode 100644 index 00000000000..b2acb32f115 --- /dev/null +++ b/libgfortran/m4/ifunction_logical.m4 @@ -0,0 +1,204 @@ +dnl Support macro file for intrinsic functions. +dnl Contains the generic sections of the array functions. +dnl This file is part of the GNU Fortran 95 Runtime Library (libgfortran) +dnl Distributed under the GNU GPL with exception. See COPYING for details. +dnl +dnl Pass the implementation for a single section as the parameter to +dnl {MASK_}ARRAY_FUNCTION. +dnl The variables base, delta, and len describe the input section. +dnl For masked section the mask is described by mbase and mdelta. +dnl These should not be modified. The result should be stored in *dest. +dnl The names count, extent, sstride, dstride, base, dest, rank, dim +dnl retarray, array, pdim and mstride should not be used. +dnl The variable n is declared as index_type and may be used. +dnl Other variable declarations may be placed at the start of the code, +dnl The types of the array parameter and the return value are +dnl atype_name and rtype_name respectively. +dnl Execution should be allowed to continue to the end of the block. +dnl You should not return or break from the inner loop of the implementation. +dnl Care should also be taken to avoid using the names defined in iparm.m4 +define(START_ARRAY_FUNCTION, +` +extern void name`'rtype_qual`_'atype_code (rtype * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(name`'rtype_qual`_'atype_code); + +void +name`'rtype_qual`_'atype_code (rtype * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict pdim) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_LOGICAL_1 * restrict base; + rtype_name * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + delta = array->dim[dim].stride * src_kind; + + for (n = 0; n < dim; n++) + { + sstride[n] = array->dim[n].stride * src_kind; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = array->dim[n + 1].stride * src_kind; + extent[n] = + array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size; + + for (n = 0; n < rank; n++) + { + retarray->dim[n].lbound = 0; + retarray->dim[n].ubound = extent[n]-1; + if (n == 0) + retarray->dim[n].stride = 1; + else + retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + retarray->dim[0].lbound = 0; + retarray->dim[0].ubound = -1; + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " u_name intrinsic: is %d, should be %d", + GFC_DESCRIPTOR_RANK (retarray), rank); + + if (compile_options.bounds_check) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = retarray->dim[n].ubound + 1 + - retarray->dim[n].lbound; + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " u_name intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = retarray->dim[n].stride; + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in u_name intrinsic"); + + dest = retarray->data; + + while (base) + { + const GFC_LOGICAL_1 * restrict src; + rtype_name result; + src = base; + { +')dnl +define(START_ARRAY_BLOCK, +` if (len <= 0) + *dest = '$1`; + else + { + for (n = 0; n < len; n++, src += delta) + { +')dnl +define(FINISH_ARRAY_FUNCTION, + ` } + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +}')dnl +define(ARRAY_FUNCTION, +`START_ARRAY_FUNCTION +$2 +START_ARRAY_BLOCK($1) +$3 +FINISH_ARRAY_FUNCTION')dnl diff --git a/libgfortran/m4/in_pack.m4 b/libgfortran/m4/in_pack.m4 index ca243641329..ce13f954170 100644 --- a/libgfortran/m4/in_pack.m4 +++ b/libgfortran/m4/in_pack.m4 @@ -1,5 +1,5 @@ `/* Helper function for repacking arrays. - Copyright 2003, 2006 Free Software Foundation, Inc. + Copyright 2003, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> -#include <assert.h> -#include "libgfortran.h"' +#include <assert.h>' + include(iparm.m4)dnl `#if defined (HAVE_'rtype_name`) @@ -124,4 +124,4 @@ internal_pack_'rtype_ccode` ('rtype` * source) } #endif -'
\ No newline at end of file +' diff --git a/libgfortran/m4/in_unpack.m4 b/libgfortran/m4/in_unpack.m4 index 319c19f9cd0..00f4f12da33 100644 --- a/libgfortran/m4/in_unpack.m4 +++ b/libgfortran/m4/in_unpack.m4 @@ -1,5 +1,5 @@ `/* Helper function for repacking arrays. - Copyright 2003, 2006 Free Software Foundation, Inc. + Copyright 2003, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include <string.h> -#include "libgfortran.h"' +#include <string.h>' + include(iparm.m4)dnl `#if defined (HAVE_'rtype_name`)' @@ -112,4 +112,4 @@ internal_unpack_'rtype_ccode` ('rtype` * d, const 'rtype_name` * src) } #endif -'
\ No newline at end of file +' diff --git a/libgfortran/m4/iparm.m4 b/libgfortran/m4/iparm.m4 index acd3d2ce604..51ee40d049d 100644 --- a/libgfortran/m4/iparm.m4 +++ b/libgfortran/m4/iparm.m4 @@ -30,4 +30,6 @@ define(rtype_qual,`_'rtype_kind)dnl define(atype_max, atype_name`_HUGE')dnl define(atype_min,ifelse(regexp(file, `_\(.\)[0-9]*\.c$', `\1'),`i',`(-'atype_max`-1)',`-'atype_max))dnl define(name, regexp(regexp(file, `[^/]*$', `\&'), `^\([^_]*\)_', `\1'))dnl +define(`upcase', `translit(`$*', `a-z', `A-Z')')dnl +define(`u_name',`regexp(upcase(name),`\([A-Z]*\)',`\1')')dnl define(rtype_ccode,ifelse(rtype_letter,`i',rtype_kind,rtype_code))dnl diff --git a/libgfortran/m4/matmul.m4 b/libgfortran/m4/matmul.m4 index 6235f63e2b0..a290bfe1f06 100644 --- a/libgfortran/m4/matmul.m4 +++ b/libgfortran/m4/matmul.m4 @@ -1,5 +1,5 @@ `/* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,11 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <string.h> -#include <assert.h> -#include "libgfortran.h"' +#include <assert.h>' + include(iparm.m4)dnl `#if defined (HAVE_'rtype_name`) diff --git a/libgfortran/m4/matmull.m4 b/libgfortran/m4/matmull.m4 index d4b0008e951..54afa8a238e 100644 --- a/libgfortran/m4/matmull.m4 +++ b/libgfortran/m4/matmull.m4 @@ -1,5 +1,5 @@ `/* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> -#include <assert.h> -#include "libgfortran.h"' +#include <assert.h>' + include(iparm.m4)dnl `#if defined (HAVE_'rtype_name`) @@ -40,15 +40,15 @@ include(iparm.m4)dnl Either a or b can be rank 1. In this case x or y is 1. */ extern void matmul_'rtype_code` ('rtype` * const restrict, - gfc_array_l4 * const restrict, gfc_array_l4 * const restrict); + gfc_array_l1 * const restrict, gfc_array_l1 * const restrict); export_proto(matmul_'rtype_code`); void matmul_'rtype_code` ('rtype` * const restrict retarray, - gfc_array_l4 * const restrict a, gfc_array_l4 * const restrict b) + gfc_array_l1 * const restrict a, gfc_array_l1 * const restrict b) { - const GFC_INTEGER_4 * restrict abase; - const GFC_INTEGER_4 * restrict bbase; + const GFC_LOGICAL_1 * restrict abase; + const GFC_LOGICAL_1 * restrict bbase; 'rtype_name` * restrict dest; index_type rxstride; index_type rystride; @@ -58,9 +58,11 @@ matmul_'rtype_code` ('rtype` * const restrict retarray, index_type ystride; index_type x; index_type y; + int a_kind; + int b_kind; - const GFC_INTEGER_4 * restrict pa; - const GFC_INTEGER_4 * restrict pb; + const GFC_LOGICAL_1 * restrict pa; + const GFC_LOGICAL_1 * restrict pb; index_type astride; index_type bstride; index_type count; @@ -100,17 +102,29 @@ matmul_'rtype_code` ('rtype` * const restrict retarray, } abase = a->data; - if (GFC_DESCRIPTOR_SIZE (a) != 4) - { - assert (GFC_DESCRIPTOR_SIZE (a) == 8); - abase = GFOR_POINTER_L8_TO_L4 (abase); - } + a_kind = GFC_DESCRIPTOR_SIZE (a); + + if (a_kind == 1 || a_kind == 2 || a_kind == 4 || a_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || a_kind == 16 +#endif + ) + abase = GFOR_POINTER_TO_L1 (abase, a_kind); + else + internal_error (NULL, "Funny sized logical array"); + bbase = b->data; - if (GFC_DESCRIPTOR_SIZE (b) != 4) - { - assert (GFC_DESCRIPTOR_SIZE (b) == 8); - bbase = GFOR_POINTER_L8_TO_L4 (bbase); - } + b_kind = GFC_DESCRIPTOR_SIZE (b); + + if (b_kind == 1 || b_kind == 2 || b_kind == 4 || b_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || b_kind == 16 +#endif + ) + bbase = GFOR_POINTER_TO_L1 (bbase, b_kind); + else + internal_error (NULL, "Funny sized logical array"); + dest = retarray->data; ' sinclude(`matmul_asm_'rtype_code`.m4')dnl @@ -130,7 +144,7 @@ sinclude(`matmul_asm_'rtype_code`.m4')dnl one. */ if (GFC_DESCRIPTOR_RANK (a) == 1) { - astride = a->dim[0].stride; + astride = a->dim[0].stride * a_kind; count = a->dim[0].ubound + 1 - a->dim[0].lbound; xstride = 0; rxstride = 0; @@ -138,14 +152,14 @@ sinclude(`matmul_asm_'rtype_code`.m4')dnl } else { - astride = a->dim[1].stride; + astride = a->dim[1].stride * a_kind; count = a->dim[1].ubound + 1 - a->dim[1].lbound; - xstride = a->dim[0].stride; + xstride = a->dim[0].stride * a_kind; xcount = a->dim[0].ubound + 1 - a->dim[0].lbound; } if (GFC_DESCRIPTOR_RANK (b) == 1) { - bstride = b->dim[0].stride; + bstride = b->dim[0].stride * b_kind; assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound); ystride = 0; rystride = 0; @@ -153,9 +167,9 @@ sinclude(`matmul_asm_'rtype_code`.m4')dnl } else { - bstride = b->dim[0].stride; + bstride = b->dim[0].stride * b_kind; assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound); - ystride = b->dim[1].stride; + ystride = b->dim[1].stride * b_kind; ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; } @@ -191,4 +205,4 @@ sinclude(`matmul_asm_'rtype_code`.m4')dnl } #endif -'
\ No newline at end of file +' diff --git a/libgfortran/m4/maxloc0.m4 b/libgfortran/m4/maxloc0.m4 index 375e99e60b5..c4c5feb5c4c 100644 --- a/libgfortran/m4/maxloc0.m4 +++ b/libgfortran/m4/maxloc0.m4 @@ -1,5 +1,5 @@ `/* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include <limits.h> -#include "libgfortran.h"' +#include <limits.h>' include(iparm.m4)dnl include(iforeach.m4)dnl diff --git a/libgfortran/m4/maxloc1.m4 b/libgfortran/m4/maxloc1.m4 index b6b4fa705ac..69214a358e8 100644 --- a/libgfortran/m4/maxloc1.m4 +++ b/libgfortran/m4/maxloc1.m4 @@ -1,5 +1,5 @@ `/* Implementation of the MAXLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include <limits.h> -#include "libgfortran.h"' +#include <limits.h>' include(iparm.m4)dnl include(ifunction.m4)dnl diff --git a/libgfortran/m4/maxval.m4 b/libgfortran/m4/maxval.m4 index 84a65500d70..66970e4d1d8 100644 --- a/libgfortran/m4/maxval.m4 +++ b/libgfortran/m4/maxval.m4 @@ -1,5 +1,5 @@ `/* Implementation of the MAXVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> -#include <assert.h> -#include "libgfortran.h"' +#include <assert.h>' include(iparm.m4)dnl include(ifunction.m4)dnl diff --git a/libgfortran/m4/minloc0.m4 b/libgfortran/m4/minloc0.m4 index 8c23e19fbaa..6b05b5f2d9e 100644 --- a/libgfortran/m4/minloc0.m4 +++ b/libgfortran/m4/minloc0.m4 @@ -1,5 +1,5 @@ `/* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include <limits.h> -#include "libgfortran.h"' +#include <limits.h>' include(iparm.m4)dnl include(iforeach.m4)dnl diff --git a/libgfortran/m4/minloc1.m4 b/libgfortran/m4/minloc1.m4 index 06738fe7ba1..46ebfd23d5a 100644 --- a/libgfortran/m4/minloc1.m4 +++ b/libgfortran/m4/minloc1.m4 @@ -1,5 +1,5 @@ `/* Implementation of the MINLOC intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> -#include <limits.h> -#include "libgfortran.h"' +#include <limits.h>' include(iparm.m4)dnl include(ifunction.m4)dnl diff --git a/libgfortran/m4/minval.m4 b/libgfortran/m4/minval.m4 index 439300dcb94..8d7cc54d047 100644 --- a/libgfortran/m4/minval.m4 +++ b/libgfortran/m4/minval.m4 @@ -1,5 +1,5 @@ `/* Implementation of the MINVAL intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> -#include <assert.h> -#include "libgfortran.h"' +#include <assert.h>' include(iparm.m4)dnl include(ifunction.m4)dnl diff --git a/libgfortran/m4/nearest.m4 b/libgfortran/m4/nearest.m4 index 69ff255c643..13efe2554f8 100644 --- a/libgfortran/m4/nearest.m4 +++ b/libgfortran/m4/nearest.m4 @@ -1,5 +1,5 @@ `/* Implementation of the NEAREST intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h"' include(`mtype.m4')dnl diff --git a/libgfortran/m4/pow.m4 b/libgfortran/m4/pow.m4 index 8f1b6b21f99..052cfb23f79 100644 --- a/libgfortran/m4/pow.m4 +++ b/libgfortran/m4/pow.m4 @@ -1,5 +1,5 @@ `/* Support routines for the intrinsic power (**) operator. - Copyright 2004 Free Software Foundation, Inc. + Copyright 2004, 2007 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,8 +28,8 @@ 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 "config.h" #include "libgfortran.h"' + include(iparm.m4)dnl /* Use Binary Method to calculate the powi. This is not an optimal but diff --git a/libgfortran/m4/product.m4 b/libgfortran/m4/product.m4 index 77393022ebe..e885f8eaa25 100644 --- a/libgfortran/m4/product.m4 +++ b/libgfortran/m4/product.m4 @@ -1,5 +1,5 @@ `/* Implementation of the PRODUCT intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> -#include <assert.h> -#include "libgfortran.h"' +#include <assert.h>' include(iparm.m4)dnl include(ifunction.m4)dnl diff --git a/libgfortran/m4/reshape.m4 b/libgfortran/m4/reshape.m4 index 2a877a2f8ab..de936f0191a 100644 --- a/libgfortran/m4/reshape.m4 +++ b/libgfortran/m4/reshape.m4 @@ -1,5 +1,5 @@ `/* Implementation of the RESHAPE - Copyright 2002, 2006 Free Software Foundation, Inc. + Copyright 2002, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> -#include <assert.h> -#include "libgfortran.h"' +#include <assert.h>' + include(iparm.m4)dnl `#if defined (HAVE_'rtype_name`) diff --git a/libgfortran/m4/rrspacing.m4 b/libgfortran/m4/rrspacing.m4 index e2d31d6cc67..63348c7d1e0 100644 --- a/libgfortran/m4/rrspacing.m4 +++ b/libgfortran/m4/rrspacing.m4 @@ -1,5 +1,5 @@ `/* Implementation of the RRSPACING intrinsic - Copyright 2006 Free Software Foundation, Inc. + Copyright 2006, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargl@gcc.gnu.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h"' include(`mtype.m4')dnl diff --git a/libgfortran/m4/set_exponent.m4 b/libgfortran/m4/set_exponent.m4 index 8ff9acdb562..19669c4e7dd 100644 --- a/libgfortran/m4/set_exponent.m4 +++ b/libgfortran/m4/set_exponent.m4 @@ -1,5 +1,5 @@ `/* Implementation of the SET_EXPONENT intrinsic - Copyright 2003 Free Software Foundation, Inc. + Copyright 2003, 2007 Free Software Foundation, Inc. Contributed by Richard Henderson <rth@redhat.com>. This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h"' include(`mtype.m4')dnl diff --git a/libgfortran/m4/shape.m4 b/libgfortran/m4/shape.m4 index 1902d7514d6..c783270bec7 100644 --- a/libgfortran/m4/shape.m4 +++ b/libgfortran/m4/shape.m4 @@ -1,5 +1,5 @@ `/* Implementation of the SHAPE intrinsic - Copyright 2002, 2006 Free Software Foundation, Inc. + Copyright 2002, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> -#include <assert.h> -#include "libgfortran.h"' +#include <assert.h>' + include(iparm.m4)dnl `#if defined (HAVE_'rtype_name`) @@ -46,13 +46,17 @@ shape_'rtype_kind` ('rtype` * const restrict ret, { int n; index_type stride; + index_type extent; stride = ret->dim[0].stride; + if (ret->dim[0].ubound < ret->dim[0].lbound) + return; + for (n = 0; n < GFC_DESCRIPTOR_RANK (array); n++) { - ret->data[n * stride] = - array->dim[n].ubound + 1 - array->dim[n].lbound; + extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + ret->data[n * stride] = extent > 0 ? extent : 0 ; } } diff --git a/libgfortran/m4/spacing.m4 b/libgfortran/m4/spacing.m4 index 20bda8abfbd..dce9c17bef6 100644 --- a/libgfortran/m4/spacing.m4 +++ b/libgfortran/m4/spacing.m4 @@ -1,5 +1,5 @@ `/* Implementation of the SPACING intrinsic - Copyright 2006 Free Software Foundation, Inc. + Copyright 2006, 2007 Free Software Foundation, Inc. Contributed by Steven G. Kargl <kargl@gcc.gnu.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,7 +28,6 @@ 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 "config.h" #include "libgfortran.h"' include(`mtype.m4')dnl diff --git a/libgfortran/m4/sum.m4 b/libgfortran/m4/sum.m4 index a9406882cfa..622d18ce920 100644 --- a/libgfortran/m4/sum.m4 +++ b/libgfortran/m4/sum.m4 @@ -1,5 +1,5 @@ `/* Implementation of the SUM intrinsic - Copyright 2002 Free Software Foundation, Inc. + Copyright 2002, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> -#include <assert.h> -#include "libgfortran.h"' +#include <assert.h>' include(iparm.m4)dnl include(ifunction.m4)dnl diff --git a/libgfortran/m4/transpose.m4 b/libgfortran/m4/transpose.m4 index bd0577f089f..177e86dcdc1 100644 --- a/libgfortran/m4/transpose.m4 +++ b/libgfortran/m4/transpose.m4 @@ -1,5 +1,5 @@ `/* Implementation of the TRANSPOSE intrinsic - Copyright 2003, 2005, 2006 Free Software Foundation, Inc. + Copyright 2003, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Tobias Schlüter This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,9 +28,9 @@ 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 "config.h" -#include <assert.h> -#include "libgfortran.h"' +#include "libgfortran.h" +#include <assert.h>' + include(iparm.m4)dnl `#if defined (HAVE_'rtype_name`) diff --git a/libgfortran/mk-kinds-h.sh b/libgfortran/mk-kinds-h.sh index ccd073844c9..6e893ff5ee7 100755 --- a/libgfortran/mk-kinds-h.sh +++ b/libgfortran/mk-kinds-h.sh @@ -1,4 +1,6 @@ #!/bin/sh +LC_ALL=C +export LC_ALL compile="$1" @@ -12,7 +14,7 @@ smallest="" for k in $possible_integer_kinds; do echo " integer (kind=$k) :: i" > tmp$$.f90 echo " end" >> tmp$$.f90 - if $compile -c tmp$$.f90 > /dev/null 2>&1; then + if $compile -S tmp$$.f90 > /dev/null 2>&1; then s=`expr 8 \* $k` largest="$k" @@ -31,6 +33,7 @@ for k in $possible_integer_kinds; do echo "typedef GFC_INTEGER_${k} GFC_LOGICAL_${k};" echo "#define HAVE_GFC_LOGICAL_${k}" echo "#define HAVE_GFC_INTEGER_${k}" + echo "" fi rm -f tmp$$.* done @@ -41,33 +44,47 @@ echo "#define GFC_DEFAULT_CHAR ${smallest}" echo "" -largest_ctype="" for k in $possible_real_kinds; do echo " real (kind=$k) :: x" > tmp$$.f90 echo " end" >> tmp$$.f90 - if $compile -c tmp$$.f90 > /dev/null 2>&1; then + if $compile -S tmp$$.f90 > /dev/null 2>&1; then case $k in - 4) ctype="float" ;; - 8) ctype="double" ;; - 10) ctype="long double" ;; - 16) ctype="long double" ;; + 4) ctype="float" ; suffix="f" ;; + 8) ctype="double" ; suffix="" ;; + 10) ctype="long double" ; suffix="l" ;; + 16) ctype="long double" ; suffix="l" ;; *) echo "$0: Unknown type" >&2 ; exit 1 ;; esac - largest_ctype="$ctype" + + # Check for the value of HUGE + echo "print *, huge(0._$k) ; end" > tmq$$.f90 + huge=`$compile -S -fdump-parse-tree tmq$$.f90 | grep TRANSFER \ + | sed 's/ *TRANSFER *//' | sed 's/_.*//'` + rm -f tmq$$.* + + # Check for the value of DIGITS + echo "print *, digits(0._$k) ; end" > tmq$$.f90 + digits=`$compile -S -fdump-parse-tree tmq$$.f90 | grep TRANSFER \ + | sed 's/ *TRANSFER *//'` + rm -f tmq$$.* + + # Check for the value of RADIX + echo "print *, radix(0._$k) ; end" > tmq$$.f90 + radix=`$compile -S -fdump-parse-tree tmq$$.f90 | grep TRANSFER \ + | sed 's/ *TRANSFER *//'` + rm -f tmq$$.* + + # Output the information we've gathered echo "typedef ${ctype} GFC_REAL_${k};" echo "typedef complex ${ctype} GFC_COMPLEX_${k};" echo "#define HAVE_GFC_REAL_${k}" echo "#define HAVE_GFC_COMPLEX_${k}" + echo "#define GFC_REAL_${k}_HUGE ${huge}${suffix}" + echo "#define GFC_REAL_${k}_DIGITS ${digits}" + echo "#define GFC_REAL_${k}_RADIX ${radix}" + echo "" fi rm -f tmp$$.* done -case $largest_ctype in - float) echo "#define GFC_REAL_LARGEST_FORMAT \"\"" ;; - double) echo "#define GFC_REAL_LARGEST_FORMAT \"l\"" ;; - "long double") echo "#define GFC_REAL_LARGEST_FORMAT \"L\"" ;; - *) echo "$0: Unknown type" >&2 ; exit 1 ;; -esac -echo "#define GFC_REAL_LARGEST $largest_ctype" - exit 0 diff --git a/libgfortran/mk-sik-inc.sh b/libgfortran/mk-sik-inc.sh index a2f29e1e30a..83dcb16999e 100755 --- a/libgfortran/mk-sik-inc.sh +++ b/libgfortran/mk-sik-inc.sh @@ -8,7 +8,7 @@ c=0 for k in $possible_kinds; do echo " integer (kind=$k) :: x" > tmp$$.f90 echo " end" >> tmp$$.f90 - if $compile -c tmp$$.f90 > /dev/null 2>&1; then + if $compile -S tmp$$.f90 > /dev/null 2>&1; then kinds="$kinds $k" c=`expr $c + 1` fi diff --git a/libgfortran/mk-srk-inc.sh b/libgfortran/mk-srk-inc.sh index d036d682679..076c24bb5b7 100755 --- a/libgfortran/mk-srk-inc.sh +++ b/libgfortran/mk-srk-inc.sh @@ -8,7 +8,7 @@ c=0 for k in $possible_kinds; do echo " real (kind=$k) :: x" > tmp$$.f90 echo " end" >> tmp$$.f90 - if $compile -c tmp$$.f90 > /dev/null 2>&1; then + if $compile -S tmp$$.f90 > /dev/null 2>&1; then kinds="$kinds $k" c=`expr $c + 1` fi diff --git a/libgfortran/runtime/backtrace.c b/libgfortran/runtime/backtrace.c index 684ac00c9a0..00605b50d3f 100644 --- a/libgfortran/runtime/backtrace.c +++ b/libgfortran/runtime/backtrace.c @@ -27,9 +27,8 @@ along with libgfortran; see the file COPYING. If not, write to the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ +#include "libgfortran.h" -#include "config.h" -#include <stdio.h> #include <string.h> #ifdef HAVE_STDLIB_H @@ -58,16 +57,21 @@ Boston, MA 02110-1301, USA. */ #include <sys/wait.h> #endif -#ifdef HAVE_STRING_H -#include <string.h> -#endif - #include <ctype.h> -#include "libgfortran.h" +/* Macros for common sets of capabilities: can we fork and exec, can + we use glibc-style backtrace functions, and can we use pipes. */ +#define CAN_FORK (defined(HAVE_FORK) && defined(HAVE_EXECVP) \ + && defined(HAVE_WAIT)) +#define GLIBC_BACKTRACE (defined(HAVE_BACKTRACE) \ + && defined(HAVE_BACKTRACE_SYMBOLS)) +#define CAN_PIPE (CAN_FORK && defined(HAVE_PIPE) \ + && defined(HAVE_DUP2) && defined(HAVE_FDOPEN) \ + && defined(HAVE_CLOSE)) +#if GLIBC_BACKTRACE && CAN_PIPE static char * local_strcasestr (const char *s1, const char *s2) { @@ -92,14 +96,7 @@ local_strcasestr (const char *s1, const char *s2) } #endif } - -#define CAN_FORK (defined(HAVE_FORK) && defined(HAVE_EXECVP) \ - && defined(HAVE_WAIT)) -#define GLIBC_BACKTRACE (defined(HAVE_BACKTRACE) \ - && defined(HAVE_BACKTRACE_SYMBOLS)) -#define CAN_PIPE (CAN_FORK && defined(HAVE_PIPE) \ - && defined(HAVE_DUP2) && defined(HAVE_FDOPEN) \ - && defined(HAVE_CLOSE)) +#endif #if GLIBC_BACKTRACE @@ -223,7 +220,8 @@ show_backtrace (void) /* Try to recognize the internal libgfortran functions. */ if (strncasecmp (func, "*_gfortran", 10) == 0 || strncasecmp (func, "_gfortran", 9) == 0 - || strcmp (func, "main") == 0 || strcmp (func, "_start") == 0) + || strcmp (func, "main") == 0 || strcmp (func, "_start") == 0 + || strcmp (func, "_gfortrani_handler") == 0) continue; if (local_strcasestr (str[i], "libgfortran.so") != NULL diff --git a/libgfortran/runtime/compile_options.c b/libgfortran/runtime/compile_options.c index a6e2a42229e..8e0a3fe30ce 100644 --- a/libgfortran/runtime/compile_options.c +++ b/libgfortran/runtime/compile_options.c @@ -27,14 +27,63 @@ along with libgfortran; see the file COPYING. If not, write to the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ -#include "config.h" - #include "libgfortran.h" +#ifdef HAVE_SIGNAL_H +#include <signal.h> +#endif + /* Useful compile-time options will be stored in here. */ compile_options_t compile_options; + +/* A signal handler to allow us to output a backtrace. */ +void +handler (int signum) +{ + const char * name = NULL, * desc = NULL; + + switch (signum) + { +#if defined(SIGSEGV) + case SIGSEGV: + name = "SIGSEGV"; + desc = "Segmentation fault"; + break; +#endif + +#if defined(SIGBUS) + case SIGBUS: + name = "SIGBUS"; + desc = "Bus error"; + break; +#endif + +#if defined(SIGILL) + case SIGILL: + name = "SIGILL"; + desc = "Illegal instruction"; + break; +#endif + +#if defined(SIGFPE) + case SIGFPE: + name = "SIGFPE"; + desc = "Floating-point exception"; + break; +#endif + } + + if (name) + st_printf ("\nProgram received signal %d (%s): %s.\n", signum, name, desc); + else + st_printf ("\nProgram received signal %d.\n", signum); + + sys_exit (5); +} + + /* Set the usual compile-time options. */ extern void set_options (int , int []); export_proto(set_options); @@ -56,6 +105,31 @@ set_options (int num, int options[]) compile_options.sign_zero = options[5]; if (num >= 7) compile_options.bounds_check = options[6]; + + /* If backtrace is required, we set signal handlers on most common + signals. */ +#if defined(HAVE_SIGNAL) && (defined(SIGSEGV) || defined(SIGBUS) \ + || defined(SIGILL) || defined(SIGFPE)) + if (compile_options.backtrace) + { +#if defined(SIGSEGV) + signal (SIGSEGV, handler); +#endif + +#if defined(SIGBUS) + signal (SIGBUS, handler); +#endif + +#if defined(SIGILL) + signal (SIGILL, handler); +#endif + +#if defined(SIGFPE) + signal (SIGFPE, handler); +#endif + } +#endif + } diff --git a/libgfortran/runtime/environ.c b/libgfortran/runtime/environ.c index 388383c9a81..ba8283e68aa 100644 --- a/libgfortran/runtime/environ.c +++ b/libgfortran/runtime/environ.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2002,2003,2005 Free Software Foundation, Inc. +/* Copyright (C) 2002, 2003, 2005, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -27,13 +27,12 @@ along with libgfortran; see the file COPYING. If not, write to the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ -#include "config.h" -#include <stdio.h> +#include "libgfortran.h" + #include <string.h> #include <stdlib.h> #include <ctype.h> -#include "libgfortran.h" /* Environment scanner. Examine the environment for controlling minor * aspects of the program's execution. Our philosophy here that the @@ -202,78 +201,6 @@ show_boolean (variable * v) } -/* init_mem()-- Initialize environment variables that have to do with - * how memory from an ALLOCATE statement is filled. A single flag - * enables filling and a second variable gives the value that is used - * to initialize the memory. */ - -static void -init_mem (variable * v) -{ - int offset, n; - char *p; - - p = getenv (v->name); - - options.allocate_init_flag = 0; /* The default */ - - if (p == NULL) - return; - - if (strcasecmp (p, "NONE") == 0) - return; - - /* IEEE-754 Quiet Not-a-Number that will work for single and double - * precision. Look for the 'f95' mantissa in debug dumps. */ - - if (strcasecmp (p, "NaN") == 0) - { - options.allocate_init_flag = 1; - options.allocate_init_value = 0xfff80f95; - return; - } - - /* Interpret the string as a hexadecimal constant */ - - n = 0; - while (*p) - { - if (!isxdigit (*p)) - { - v->bad = 1; - return; - } - - offset = '0'; - if (islower (*p)) - offset = 'a'; - if (isupper (*p)) - offset = 'A'; - - n = (n << 4) | (*p++ - offset); - } - - options.allocate_init_flag = 1; - options.allocate_init_value = n; -} - - -static void -show_mem (variable * v) -{ - char *p; - - p = getenv (v->name); - - st_printf ("%s ", var_source (v)); - - if (options.allocate_init_flag) - st_printf ("0x%x", options.allocate_init_value); - - st_printf ("\n"); -} - - static void init_sep (variable * v) { @@ -343,135 +270,19 @@ show_string (variable * v) } -/* Structure for associating names and values. */ - -typedef struct -{ - const char *name; - int value; -} -choice; - - -enum -{ FP_ROUND_NEAREST, FP_ROUND_UP, FP_ROUND_DOWN, FP_ROUND_ZERO }; - -static const choice rounding[] = { - {"NEAREST", FP_ROUND_NEAREST}, - {"UP", FP_ROUND_UP}, - {"DOWN", FP_ROUND_DOWN}, - {"ZERO", FP_ROUND_ZERO}, - {NULL, 0} -}; - -static const choice precision[] = -{ - { "24", 1}, - { "53", 2}, - { "64", 0}, - { NULL, 0} -}; - -static const choice signal_choices[] = -{ - { "IGNORE", 1}, - { "ABORT", 0}, - { NULL, 0} -}; - - -static void -init_choice (variable * v, const choice * c) -{ - char *p; - - p = getenv (v->name); - if (p == NULL) - goto set_default; - - for (; c->name; c++) - if (strcasecmp (c->name, p) == 0) - break; - - if (c->name == NULL) - { - v->bad = 1; - goto set_default; - } - - *v->var = c->value; - return; - - set_default: - *v->var = v->value; -} - - -static void -show_choice (variable * v, const choice * c) -{ - st_printf ("%s ", var_source (v)); - - for (; c->name; c++) - if (c->value == *v->var) - break; - - if (c->name) - st_printf ("%s\n", c->name); - else - st_printf ("(Unknown)\n"); -} - - -static void -init_round (variable * v) -{ - init_choice (v, rounding); -} - -static void -show_round (variable * v) -{ - show_choice (v, rounding); -} - -static void -init_precision (variable * v) -{ - init_choice (v, precision); -} - -static void -show_precision (variable * v) -{ - show_choice (v, precision); -} - -static void -init_signal (variable * v) -{ - init_choice (v, signal_choices); -} - -static void -show_signal (variable * v) -{ - show_choice (v, signal_choices); -} - - static variable variable_table[] = { - {"GFORTRAN_STDIN_UNIT", 5, &options.stdin_unit, init_integer, show_integer, + {"GFORTRAN_STDIN_UNIT", GFC_STDIN_UNIT_NUMBER, &options.stdin_unit, + init_integer, show_integer, "Unit number that will be preconnected to standard input\n" "(No preconnection if negative)", 0}, - {"GFORTRAN_STDOUT_UNIT", 6, &options.stdout_unit, init_integer, - show_integer, + {"GFORTRAN_STDOUT_UNIT", GFC_STDOUT_UNIT_NUMBER, &options.stdout_unit, + init_integer, show_integer, "Unit number that will be preconnected to standard output\n" "(No preconnection if negative)", 0}, - {"GFORTRAN_STDERR_UNIT", 0, &options.stderr_unit, init_integer, - show_integer, + {"GFORTRAN_STDERR_UNIT", GFC_STDERR_UNIT_NUMBER, &options.stderr_unit, + init_integer, show_integer, "Unit number that will be preconnected to standard error\n" "(No preconnection if negative)", 0}, @@ -488,6 +299,10 @@ static variable variable_table[] = { "If TRUE, all output is unbuffered. This will slow down large writes " "but can be\nuseful for forcing data to be displayed immediately.", 0}, + {"GFORTRAN_UNBUFFERED_PRECONNECTED", 0, &options.unbuffered_preconnected, + init_boolean, show_boolean, + "If TRUE, output to preconnected units is unbuffered.", 0}, + {"GFORTRAN_SHOW_LOCUS", 1, &options.locus, init_boolean, show_boolean, "If TRUE, print filename and line number where runtime errors happen.", 0}, @@ -504,34 +319,6 @@ static variable variable_table[] = { "Separator to use when writing list output. May contain any number of " "spaces\nand at most one comma. Default is a single space.", 0}, - /* Memory related controls */ - - {"GFORTRAN_MEM_INIT", 0, NULL, init_mem, show_mem, - "How to initialize allocated memory. Default value is NONE for no " - "initialization\n(faster), NAN for a Not-a-Number with the mantissa " - "0x40f95 or a custom\nhexadecimal value", 0}, - - {"GFORTRAN_MEM_CHECK", 0, &options.mem_check, init_boolean, show_boolean, - "Whether memory still allocated will be reported when the program ends.", - 0}, - - /* Signal handling (Unix). */ - - {"GFORTRAN_SIGHUP", 0, &options.sighup, init_signal, show_signal, - "Whether the program will IGNORE or ABORT on SIGHUP.", 0}, - - {"GFORTRAN_SIGINT", 0, &options.sigint, init_signal, show_signal, - "Whether the program will IGNORE or ABORT on SIGINT.", 0}, - - /* Floating point control */ - - {"GFORTRAN_FPU_ROUND", 0, &options.fpu_round, init_round, show_round, - "Set floating point rounding. Values are NEAREST, UP, DOWN, ZERO.", 0}, - - {"GFORTRAN_FPU_PRECISION", 0, &options.fpu_precision, init_precision, - show_precision, - "Precision of intermediate results. Values are 24, 53 and 64.", 0}, - /* GFORTRAN_CONVERT_UNIT - Set the default data conversion for unformatted I/O. */ {"GFORTRAN_CONVERT_UNIT", 0, 0, init_unformatted, show_string, @@ -563,32 +350,6 @@ init_variables (void) } -/* check_buffered()-- Given an unit number n, determine if an override - * for the stream exists. Returns zero for unbuffered, one for - * buffered or two for not set. */ - -int -check_buffered (int n) -{ - char name[22 + sizeof (n) * 3]; - variable v; - int rv; - - if (options.all_unbuffered) - return 0; - - sprintf (name, "GFORTRAN_UNBUFFERED_%d", n); - - v.name = name; - v.value = 2; - v.var = &rv; - - init_boolean (&v); - - return rv; -} - - void show_variables (void) { @@ -623,7 +384,7 @@ show_variables (void) st_printf ("\nRuntime error codes:"); st_printf ("\n--------------------\n"); - for (n = ERROR_FIRST + 1; n < ERROR_LAST; n++) + for (n = LIBERROR_FIRST + 1; n < LIBERROR_LAST; n++) if (n < 0 || n > 9) st_printf ("%d %s\n", n, translate_error (n)); else @@ -882,19 +643,19 @@ do_parse (void) switch (tok) { case NATIVE: - endian = CONVERT_NATIVE; + endian = GFC_CONVERT_NATIVE; break; case SWAP: - endian = CONVERT_SWAP; + endian = GFC_CONVERT_SWAP; break; case BIG: - endian = CONVERT_BIG; + endian = GFC_CONVERT_BIG; break; case LITTLE: - endian = CONVERT_LITTLE; + endian = GFC_CONVERT_LITTLE; break; case INTEGER: @@ -949,25 +710,25 @@ do_parse (void) case NATIVE: if (next_token () != ':') goto error; - endian = CONVERT_NATIVE; + endian = GFC_CONVERT_NATIVE; break; case SWAP: if (next_token () != ':') goto error; - endian = CONVERT_SWAP; + endian = GFC_CONVERT_SWAP; break; case LITTLE: if (next_token () != ':') goto error; - endian = CONVERT_LITTLE; + endian = GFC_CONVERT_LITTLE; break; case BIG: if (next_token () != ':') goto error; - endian = CONVERT_BIG; + endian = GFC_CONVERT_BIG; break; case INTEGER: @@ -1035,7 +796,7 @@ do_parse (void) end: return 0; error: - def = CONVERT_NONE; + def = GFC_CONVERT_NONE; return -1; } @@ -1043,7 +804,7 @@ void init_unformatted (variable * v) { char *val; val = getenv (v->name); - def = CONVERT_NONE; + def = GFC_CONVERT_NONE; n_elist = 0; if (val == NULL) diff --git a/libgfortran/runtime/error.c b/libgfortran/runtime/error.c index 959a44b97d1..f0a4ff2291d 100644 --- a/libgfortran/runtime/error.c +++ b/libgfortran/runtime/error.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2002, 2003, 2005, 2006 Free Software Foundation, Inc. +/* Copyright (C) 2002, 2003, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,8 @@ the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ -#include "config.h" +#include "libgfortran.h" #include <assert.h> -#include <stdio.h> -#include <stdarg.h> #include <string.h> #include <errno.h> @@ -57,7 +55,6 @@ Boston, MA 02110-1301, USA. */ #include <sys/resource.h> #endif -#include "libgfortran.h" #ifdef __MINGW32__ #define HAVE_GETPID 1 @@ -185,63 +182,6 @@ xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len) return p; } - -/* st_sprintf()-- Simple sprintf() for formatting memory buffers. */ - -void -st_sprintf (char *buffer, const char *format, ...) -{ - va_list arg; - char c; - const char *p; - int count; - char itoa_buf[GFC_ITOA_BUF_SIZE]; - - va_start (arg, format); - - for (;;) - { - c = *format++; - if (c != '%') - { - *buffer++ = c; - if (c == '\0') - break; - continue; - } - - c = *format++; - switch (c) - { - case 'c': - *buffer++ = (char) va_arg (arg, int); - break; - - case 'd': - p = gfc_itoa (va_arg (arg, int), itoa_buf, sizeof (itoa_buf)); - count = strlen (p); - - memcpy (buffer, p, count); - buffer += count; - break; - - case 's': - p = va_arg (arg, char *); - count = strlen (p); - - memcpy (buffer, p, count); - buffer += count; - break; - - default: - *buffer++ = c; - } - } - - va_end (arg); -} - - /* show_locus()-- Print a line number and filename describing where * something went wrong */ @@ -306,10 +246,16 @@ iexport(os_error); * invalid fortran program. */ void -runtime_error (const char *message) +runtime_error (const char *message, ...) { + va_list ap; + recursion_check (); - st_printf ("Fortran runtime error: %s\n", message); + st_printf ("Fortran runtime error: "); + va_start (ap, message); + st_vprintf (message, ap); + va_end (ap); + st_printf ("\n"); sys_exit (2); } iexport(runtime_error); @@ -318,11 +264,17 @@ iexport(runtime_error); * run time error generated by the front end compiler. */ void -runtime_error_at (const char *where, const char *message) +runtime_error_at (const char *where, const char *message, ...) { + va_list ap; + recursion_check (); st_printf ("%s\n", where); - st_printf ("Fortran runtime error: %s\n", message); + st_printf ("Fortran runtime error: "); + va_start (ap, message); + st_vprintf (message, ap); + va_end (ap); + st_printf ("\n"); sys_exit (2); } iexport(runtime_error_at); @@ -358,83 +310,83 @@ translate_error (int code) switch (code) { - case ERROR_EOR: + case LIBERROR_EOR: p = "End of record"; break; - case ERROR_END: + case LIBERROR_END: p = "End of file"; break; - case ERROR_OK: + case LIBERROR_OK: p = "Successful return"; break; - case ERROR_OS: + case LIBERROR_OS: p = "Operating system error"; break; - case ERROR_BAD_OPTION: + case LIBERROR_BAD_OPTION: p = "Bad statement option"; break; - case ERROR_MISSING_OPTION: + case LIBERROR_MISSING_OPTION: p = "Missing statement option"; break; - case ERROR_OPTION_CONFLICT: + case LIBERROR_OPTION_CONFLICT: p = "Conflicting statement options"; break; - case ERROR_ALREADY_OPEN: + case LIBERROR_ALREADY_OPEN: p = "File already opened in another unit"; break; - case ERROR_BAD_UNIT: + case LIBERROR_BAD_UNIT: p = "Unattached unit"; break; - case ERROR_FORMAT: + case LIBERROR_FORMAT: p = "FORMAT error"; break; - case ERROR_BAD_ACTION: + case LIBERROR_BAD_ACTION: p = "Incorrect ACTION specified"; break; - case ERROR_ENDFILE: + case LIBERROR_ENDFILE: p = "Read past ENDFILE record"; break; - case ERROR_BAD_US: + case LIBERROR_BAD_US: p = "Corrupt unformatted sequential file"; break; - case ERROR_READ_VALUE: + case LIBERROR_READ_VALUE: p = "Bad value during read"; break; - case ERROR_READ_OVERFLOW: + case LIBERROR_READ_OVERFLOW: p = "Numeric overflow on read"; break; - case ERROR_INTERNAL: + case LIBERROR_INTERNAL: p = "Internal error in run-time library"; break; - case ERROR_INTERNAL_UNIT: + case LIBERROR_INTERNAL_UNIT: p = "Internal unit I/O error"; break; - case ERROR_DIRECT_EOR: + case LIBERROR_DIRECT_EOR: p = "Write exceeds length of DIRECT access record"; break; - case ERROR_SHORT_RECORD: + case LIBERROR_SHORT_RECORD: p = "I/O past end of record on unformatted file"; break; - case ERROR_CORRUPT_FILE: + case LIBERROR_CORRUPT_FILE: p = "Unformatted file structure has been corrupted"; break; @@ -458,13 +410,20 @@ translate_error (int code) void generate_error (st_parameter_common *cmp, int family, const char *message) { + + /* If there was a previous error, don't mask it with another + error message, EOF or EOR condition. */ + + if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR) + return; + /* Set the error status. */ if ((cmp->flags & IOPARM_HAS_IOSTAT)) - *cmp->iostat = (family == ERROR_OS) ? errno : family; + *cmp->iostat = (family == LIBERROR_OS) ? errno : family; if (message == NULL) message = - (family == ERROR_OS) ? get_oserror () : translate_error (family); + (family == LIBERROR_OS) ? get_oserror () : translate_error (family); if (cmp->flags & IOPARM_HAS_IOMSG) cf_strcpy (cmp->iomsg, cmp->iomsg_len, message); @@ -473,13 +432,13 @@ generate_error (st_parameter_common *cmp, int family, const char *message) cmp->flags &= ~IOPARM_LIBRETURN_MASK; switch (family) { - case ERROR_EOR: + case LIBERROR_EOR: cmp->flags |= IOPARM_LIBRETURN_EOR; if ((cmp->flags & IOPARM_EOR)) return; break; - case ERROR_END: + case LIBERROR_END: cmp->flags |= IOPARM_LIBRETURN_END; if ((cmp->flags & IOPARM_END)) return; diff --git a/libgfortran/runtime/in_pack_generic.c b/libgfortran/runtime/in_pack_generic.c index 7f02b97bff9..59205ead999 100644 --- a/libgfortran/runtime/in_pack_generic.c +++ b/libgfortran/runtime/in_pack_generic.c @@ -1,5 +1,5 @@ /* Generic helper function for repacking arrays. - Copyright 2003, 2004, 2005 Free Software Foundation, Inc. + Copyright 2003, 2004, 2005, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" extern void *internal_pack (gfc_array_char *); export_proto(internal_pack); diff --git a/libgfortran/runtime/in_unpack_generic.c b/libgfortran/runtime/in_unpack_generic.c index 7c14355b809..25ab64f9c01 100644 --- a/libgfortran/runtime/in_unpack_generic.c +++ b/libgfortran/runtime/in_unpack_generic.c @@ -1,5 +1,5 @@ /* Generic helper function for repacking arrays. - Copyright 2003, 2004, 2005 Free Software Foundation, Inc. + Copyright 2003, 2004, 2005, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,10 @@ 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 "config.h" +#include "libgfortran.h" #include <stdlib.h> #include <assert.h> #include <string.h> -#include "libgfortran.h" extern void internal_unpack (gfc_array_char *, const void *); export_proto(internal_unpack); diff --git a/libgfortran/runtime/main.c b/libgfortran/runtime/main.c index e88c2abdcdb..8632f152c95 100644 --- a/libgfortran/runtime/main.c +++ b/libgfortran/runtime/main.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2002-2003, 2005 Free Software Foundation, Inc. +/* Copyright (C) 2002-2003, 2005, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught and Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -27,13 +27,11 @@ along with libgfortran; see the file COPYING. If not, write to the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ -#include "config.h" -#include <stdio.h> +#include "libgfortran.h" #include <stdlib.h> #include <string.h> #include <limits.h> -#include "libgfortran.h" #ifdef HAVE_UNISTD_H #include <unistd.h> @@ -122,11 +120,15 @@ store_exe_path (const char * argv0) } memset (buf, 0, sizeof (buf)); +#ifdef HAVE_GETCWD cwd = getcwd (buf, sizeof (buf)); +#else + cwd = ""; +#endif /* exe_path will be cwd + "/" + argv[0] + "\0" */ path = malloc (strlen (cwd) + 1 + strlen (argv0) + 1); - st_sprintf (path, "%s%c%s", cwd, DIR_SEPARATOR, argv0); + sprintf (path, "%s%c%s", cwd, DIR_SEPARATOR, argv0); exe_path = path; please_free_exe_path_when_done = 1; } @@ -162,7 +164,7 @@ init (void) /* if (argc > 1 && strcmp(argv[1], "--resume") == 0) resume(); */ #endif - random_seed(NULL,NULL,NULL); + random_seed_i4 (NULL, NULL, NULL); } @@ -174,5 +176,5 @@ cleanup (void) close_units (); if (please_free_exe_path_when_done) - free (exe_path); + free ((char *) exe_path); } diff --git a/libgfortran/runtime/memory.c b/libgfortran/runtime/memory.c index f1991cda324..d84d32200bd 100644 --- a/libgfortran/runtime/memory.c +++ b/libgfortran/runtime/memory.c @@ -28,9 +28,8 @@ 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 "config.h" -#include <stdlib.h> #include "libgfortran.h" +#include <stdlib.h> /* If GFC_CLEAR_MEMORY is defined, the memory allocation routines will return memory that is guaranteed to be set to zero. This can have @@ -38,10 +37,6 @@ Boston, MA 02110-1301, USA. */ performance is desired, but it can help when you're debugging code. */ /* #define GFC_CLEAR_MEMORY */ -/* If GFC_CHECK_MEMORY is defined, we do some sanity checks at runtime. - This causes small overhead, but again, it also helps debugging. */ -#define GFC_CHECK_MEMORY - void * get_mem (size_t n) { @@ -76,123 +71,3 @@ internal_malloc_size (size_t size) return get_mem (size); } - - -/* Reallocate internal memory MEM so it has SIZE bytes of data. - Allocate a new block if MEM is zero, and free the block if - SIZE is 0. */ - -extern void *internal_realloc (void *, index_type); -export_proto(internal_realloc); - -void * -internal_realloc (void *mem, index_type size) -{ -#ifdef GFC_CHECK_MEMORY - /* Under normal circumstances, this is _never_ going to happen! */ - if (size < 0) - runtime_error ("Attempt to allocate a negative amount of memory."); -#endif - mem = realloc (mem, size); - if (!mem && size != 0) - os_error ("Out of memory."); - - if (size == 0) - return NULL; - - return mem; -} - - -/* User-allocate, one call for each member of the alloc-list of an - ALLOCATE statement. */ - -extern void *allocate (index_type, GFC_INTEGER_4 *) __attribute__ ((malloc)); -export_proto(allocate); - -void * -allocate (index_type size, GFC_INTEGER_4 * stat) -{ - void *newmem; - -#ifdef GFC_CHECK_MEMORY - /* The only time this can happen is the size computed by the - frontend wraps around. */ - if (size < 0) - { - if (stat) - { - *stat = ERROR_ALLOCATION; - return NULL; - } - else - runtime_error ("Attempt to allocate negative amount of memory. " - "Possible integer overflow"); - } -#endif - newmem = malloc (size ? size : 1); - if (!newmem) - { - if (stat) - { - *stat = ERROR_ALLOCATION; - return newmem; - } - else - runtime_error ("ALLOCATE: Out of memory."); - } - - if (stat) - *stat = 0; - - return newmem; -} - -/* Function to call in an ALLOCATE statement when the argument is an - allocatable array. If the array is currently allocated, it is - an error to allocate it again. */ - -extern void *allocate_array (void *, index_type, GFC_INTEGER_4 *); -export_proto(allocate_array); - -void * -allocate_array (void *mem, index_type size, GFC_INTEGER_4 * stat) -{ - if (mem == NULL) - return allocate (size, stat); - if (stat) - { - free (mem); - mem = allocate (size, stat); - *stat = ERROR_ALLOCATION; - return mem; - } - - runtime_error ("Attempting to allocate already allocated array."); -} - - -/* User-deallocate; pointer is then NULLified by the front-end. */ - -extern void deallocate (void *, GFC_INTEGER_4 *); -export_proto(deallocate); - -void -deallocate (void *mem, GFC_INTEGER_4 * stat) -{ - if (!mem) - { - if (stat) - { - *stat = 1; - return; - } - else - runtime_error ("Internal: Attempt to DEALLOCATE unallocated memory."); - } - - free (mem); - - if (stat) - *stat = 0; -} diff --git a/libgfortran/runtime/pause.c b/libgfortran/runtime/pause.c index 95572e1128b..8ee0e844ab5 100644 --- a/libgfortran/runtime/pause.c +++ b/libgfortran/runtime/pause.c @@ -1,5 +1,5 @@ /* Implementation of the STOP statement. - Copyright 2002, 2005 Free Software Foundation, Inc. + Copyright 2002, 2005, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,11 +28,9 @@ 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 "config.h" +#include "libgfortran.h" #include <string.h> -#include <stdio.h> -#include "libgfortran.h" static void do_pause (void) diff --git a/libgfortran/runtime/select.c b/libgfortran/runtime/select.c index cecd0254118..44c353235a0 100644 --- a/libgfortran/runtime/select.c +++ b/libgfortran/runtime/select.c @@ -53,7 +53,7 @@ select_string (select_struct *table, int table_len, const char *selector, { select_struct *t; int i, low, high, mid; - int default_jump; + int default_jump = -1; if (table_len == 0) return -1; diff --git a/libgfortran/runtime/stop.c b/libgfortran/runtime/stop.c index e4c3620e51f..4f6f907119a 100644 --- a/libgfortran/runtime/stop.c +++ b/libgfortran/runtime/stop.c @@ -1,5 +1,5 @@ /* Implementation of the STOP statement. - Copyright 2002, 2005 Free Software Foundation, Inc. + Copyright 2002, 2005, 2007 Free Software Foundation, Inc. Contributed by Paul Brook <paul@nowt.org> This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -28,10 +28,8 @@ 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 "config.h" -#include <string.h> - #include "libgfortran.h" +#include <string.h> /* A numeric or blank STOP statement. */ void diff --git a/libgfortran/runtime/string.c b/libgfortran/runtime/string.c index c0f70ef8ad2..ee7bcfb4be8 100644 --- a/libgfortran/runtime/string.c +++ b/libgfortran/runtime/string.c @@ -27,10 +27,8 @@ along with libgfortran; see the file COPYING. If not, write to the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ -#include "config.h" -#include <string.h> - #include "libgfortran.h" +#include <string.h> /* Compare a C-style string with a fortran style string in a case-insensitive manner. Used for decoding string options to various statements. Returns @@ -124,7 +122,7 @@ find_option (st_parameter_common *cmp, const char *s1, gfc_charlen_type s1_len, if (compare0 (s1, s1_len, opts->name)) return opts->value; - generate_error (cmp, ERROR_BAD_OPTION, error_message); + generate_error (cmp, LIBERROR_BAD_OPTION, error_message); return -1; } |