From d0eb20740408161537caed93c3074153218b39d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Aur=C3=A9lien=20Delval?= <32074290+PurplePachyderm@users.noreply.github.com> Date: Wed, 7 Jul 2021 13:42:42 +0200 Subject: [PATCH] Integration of Verificarlo CI tests (#1) * comment * Update distance test code The distance test has been updated to the latest version, with a first attempt at using vfc_probes inside it * Functional implementation of vfc_probes in the distance tests This commit has the first functional vfc_ci tests. Verificarlo tests should be written over the existing tests, and they can be enabled with the following configure command: QMCKL_DEVEL=1 ./configure --prefix=$PWD/_install --enable-maintainer-mode --enable-vfc_ci CC="verificarlo-f -Mpreprocess -D VFC_CI" FC="verificarlo-f -Mpreprocess -D VFC_CI" --host=x86_64 The --enable-vfc_ci flag will trigger the linking of the vfc_ci library. Moreover, as of now, the "-Mpreprocess" and "-D VFC_CI" flags have to be specified directly here. There is probably an appropriate macro to place those flags into but I couldn't find it yet, and could only manage to build the tests this way. When the VFC_CI preprocessor is defined, somme additional code to register and export the test probes can be executed (see qmckl_distance.org). As of now, the tests are built as normal, even though they are expected to fail : make all make check From there, the test_qmckl_distance (and potentially the others) executable can be called at will. This will typically be done automatically by vfc_ci, but one could manually execute the executable by defining the following env variables : VFC_PROBES_OUTPUT="test.csv" VFC_BACKENDS="libinterflop_ieee.so" depending on the export file and the Verificarlo backend to be used. The next steps will be to define more tests such as this one, and to integrate them into a Verificarlo CI workflow (by writing a vfc_tests_config.json file and using the automatic CI setup command). * Error in FOrtran interface fixed * Added missing Fortran interfaces * Modify distance test and install process integration All probes are now ignored using only the preprocessor (instead of checking for a facultative argument) in the distance test. Moreover,preprocessing can now be enabled correctly using FCFLAGS (the issue seemed to come from the order of the arguments passed to gfortran/verificarlo-f with the preprocessor arg having to come first). * Add vfc_probes to AO tests vfc_probes have been added to qmckl_ao.org in the same way as qmckl_distance.org, which means that it can be enabled or disabled at compile time using the --enable-vfc_ci option. qmckl_distance.org has been slightly modified with a better indentation, and configure.ac now adds the "-D VFC_CI" flag to CFLAGS when vfc_ci is enabled. Co-authored-by: Anthony Scemama --- .gitignore | 2 + Makefile.am | 12 +- configure.ac | 38 +- include/config.h.in | 7 - include/config.h.in~ | 160 +++ org/qmckl_ao.org | 234 ++-- org/qmckl_distance.org | 190 +++- org/qmckl_electron.org | 38 + share/doc/qmckl/html/htmlize.el | 1882 +++++++++++++++++++++++++++++++ 9 files changed, 2446 insertions(+), 117 deletions(-) create mode 100644 include/config.h.in~ create mode 100644 share/doc/qmckl/html/htmlize.el diff --git a/.gitignore b/.gitignore index 61f6fbb..8e8dceb 100644 --- a/.gitignore +++ b/.gitignore @@ -13,6 +13,8 @@ config.status config.sub configure generated.mk +.vfcwrapper.o +libtool m4/libtool.m4 m4/ltoptions.m4 m4/ltsugar.m4 diff --git a/Makefile.am b/Makefile.am index 57ad20b..cda95f9 100644 --- a/Makefile.am +++ b/Makefile.am @@ -31,6 +31,12 @@ # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +if VFC_CI +AM_LDFLAGS=-lvfc_probes -lvfc_probes_f +endif + + ACLOCAL_AMFLAGS = -I m4 VERSION_MAJOR = @VERSION_MAJOR@ @@ -64,7 +70,7 @@ src_libqmckl_la_SOURCES = $(qmckl_h) $(src_qmckl_f) $(C_FILES) $(F_FILES) $(H_PR export qmckl_f qmckl_h srcdir -CLEANFILES+=$(test_qmckl_f) $(src_qmckl_f) $(test_qmckl_o) $(src_qmckl_o) +CLEANFILES+=$(test_qmckl_f) $(src_qmckl_f) $(test_qmckl_o) $(src_qmckl_o) htmlize_el=share/doc/qmckl/html/htmlize.el @@ -156,13 +162,13 @@ $(htmlize_el): $(srcdir)/tools/install_htmlize.sh $(htmlize_el) tests/chbrclf.h: $(qmckl_h) - + generated.mk: $(ORG_FILES) $(PYTHON) $(srcdir)/tools/build_makefile.py cppcheck: cppcheck.out - + cppcheck.out: $(qmckl_h) cd src/ && \ cppcheck --addon=cert -q --error-exitcode=0 \ diff --git a/configure.ac b/configure.ac index c313f56..fc31af1 100644 --- a/configure.ac +++ b/configure.ac @@ -4,24 +4,24 @@ # QMCkl - Quantum Monte Carlo kernel library # # BSD 3-Clause License -# +# # Copyright (c) 2020, TREX Center of Excellence # All rights reserved. -# +# # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: -# +# # 1. Redistributions of source code must retain the above copyright notice, this # list of conditions and the following disclaimer. -# +# # 2. Redistributions in binary form must reproduce the above copyright notice, # this list of conditions and the following disclaimer in the documentation # and/or other materials provided with the distribution. -# +# # 3. Neither the name of the copyright holder nor the names of its # contributors may be used to endorse or promote products derived from # this software without specific prior written permission. -# +# # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE @@ -168,7 +168,7 @@ AC_TYPE_UINT64_T # Checks for library functions. ## qmckl -AC_FUNC_MALLOC +# AC_FUNC_MALLOC AC_CHECK_FUNCS([memset strerror]) # Development mode @@ -197,6 +197,29 @@ if test "x${QMCKL_DEVEL}" != "x"; then fi +# Enable Verificarlo tests +AC_ARG_ENABLE([vfc_ci], +[ --enable-vfc_ci Build the library with vfc_ci support], +[case "${enableval}" in + yes) vfc_ci=true && FCFLAGS="-D VFC_CI $FCFLAGS" && CFLAGS="-D VFC_CI $CFLAGS";; + no) vfc_ci=false ;; + *) AC_MSG_ERROR([bad value ${enableval} for --enable_vfc_ci]) ;; +esac],[vfc_ci=false]) +AM_CONDITIONAL([VFC_CI], [test x$vfc_ci = xtrue]) + +# Enable Fortran preprocessor +if test "$FC" = "gfortran"; then + AC_MSG_NOTICE(gfortran detected) + # Arguments order is important here + FCFLAGS="-cpp $FCFLAGS" +fi + +if test "$FC" = "verificarlo-f"; then + AC_MSG_NOTICE(verificarlo-f detected) + # Arguments order is important here + FCFLAGS="-Mpreprocess $FCFLAGS" +fi + #PKG-CONFIG #mkl-dynamic-lp64-seq @@ -238,4 +261,3 @@ where the optional is: check - run tests install - install ${PACKAGE_NAME} --------------------------------------------------" - diff --git a/include/config.h.in b/include/config.h.in index 6d33cba..01facda 100644 --- a/include/config.h.in +++ b/include/config.h.in @@ -30,10 +30,6 @@ /* Define to 1 if you have the `pthread' library (-lpthread). */ #undef HAVE_LIBPTHREAD -/* Define to 1 if your system has a GNU libc compatible `malloc' function, and - to 0 otherwise. */ -#undef HAVE_MALLOC - /* Define to 1 if you have the header file. */ #undef HAVE_MALLOC_H @@ -145,9 +141,6 @@ such a type exists and the standard includes do not define it. */ #undef int64_t -/* Define to rpl_malloc if the replacement function should be used. */ -#undef malloc - /* Define to `unsigned int' if does not define. */ #undef size_t diff --git a/include/config.h.in~ b/include/config.h.in~ new file mode 100644 index 0000000..6d33cba --- /dev/null +++ b/include/config.h.in~ @@ -0,0 +1,160 @@ +/* include/config.h.in. Generated from configure.ac by autoheader. */ + +/* Define to turn on debugging checks */ +#undef DEBUG + +/* Define when using the profiler tool */ +#undef ENABLE_PROF + +/* Define to 1 if your Fortran compiler doesn't accept -c and -o together. */ +#undef FC_NO_MINUS_C_MINUS_O + +/* Define to 1 if you have the header file. */ +#undef HAVE_ASSERT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_DLFCN_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_ERRNO_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_INTTYPES_H + +/* Define to 1 if you have the `efence' library (-lefence). */ +#undef HAVE_LIBEFENCE + +/* Define to 1 if you have the `m' library (-lm). */ +#undef HAVE_LIBM + +/* Define to 1 if you have the `pthread' library (-lpthread). */ +#undef HAVE_LIBPTHREAD + +/* Define to 1 if your system has a GNU libc compatible `malloc' function, and + to 0 otherwise. */ +#undef HAVE_MALLOC + +/* Define to 1 if you have the header file. */ +#undef HAVE_MALLOC_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_MATH_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_MEMORY_H + +/* Define to 1 if you have the `memset' function. */ +#undef HAVE_MEMSET + +/* Define to 1 if you have the header file. */ +#undef HAVE_PTHREAD_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDBOOL_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDINT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDIO_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDLIB_H + +/* Define to 1 if you have the `strerror' function. */ +#undef HAVE_STRERROR + +/* Define to 1 if you have the header file. */ +#undef HAVE_STRINGS_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STRING_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_STAT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_TYPES_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_UNISTD_H + +/* Define to 1 if the system has the type `_Bool'. */ +#undef HAVE__BOOL + +/* Define to the sub-directory where libtool stores uninstalled libraries. */ +#undef LT_OBJDIR + +/* Define to use debugging malloc/free */ +#undef MALLOC_TRACE + +/* Define to 1 if your C compiler doesn't accept -c and -o together. */ +#undef NO_MINUS_C_MINUS_O + +/* Name of package */ +#undef PACKAGE + +/* Define to the address where bug reports for this package should be sent. */ +#undef PACKAGE_BUGREPORT + +/* Define to the full name of this package. */ +#undef PACKAGE_NAME + +/* Define to the full name and version of this package. */ +#undef PACKAGE_STRING + +/* Define to the one symbol short name of this package. */ +#undef PACKAGE_TARNAME + +/* Define to the home page for this package. */ +#undef PACKAGE_URL + +/* Define to the version of this package. */ +#undef PACKAGE_VERSION + +/* major version */ +#undef QMCKL_VERSION_MAJOR + +/* minor version */ +#undef QMCKL_VERSION_MINOR + +/* patch version */ +#undef QMCKL_VERSION_PATCH + +/* Define to 1 if you have the ANSI C header files. */ +#undef STDC_HEADERS + +/* Version number of package */ +#undef VERSION + +/* Define for Solaris 2.5.1 so the uint32_t typedef from , + , or is not used. If the typedef were allowed, the + #define below would cause a syntax error. */ +#undef _UINT32_T + +/* Define for Solaris 2.5.1 so the uint64_t typedef from , + , or is not used. If the typedef were allowed, the + #define below would cause a syntax error. */ +#undef _UINT64_T + +/* Define to the type of a signed integer type of width exactly 32 bits if + such a type exists and the standard includes do not define it. */ +#undef int32_t + +/* Define to the type of a signed integer type of width exactly 64 bits if + such a type exists and the standard includes do not define it. */ +#undef int64_t + +/* Define to rpl_malloc if the replacement function should be used. */ +#undef malloc + +/* Define to `unsigned int' if does not define. */ +#undef size_t + +/* Define to the type of an unsigned integer type of width exactly 32 bits if + such a type exists and the standard includes do not define it. */ +#undef uint32_t + +/* Define to the type of an unsigned integer type of width exactly 64 bits if + such a type exists and the standard includes do not define it. */ +#undef uint64_t diff --git a/org/qmckl_ao.org b/org/qmckl_ao.org index b193f3a..891fc47 100644 --- a/org/qmckl_ao.org +++ b/org/qmckl_ao.org @@ -60,9 +60,17 @@ gradients and Laplacian of the atomic basis functions. #include #include "chbrclf.h" +#ifdef VFC_CI +#include +#endif + int main() { qmckl_context context; context = qmckl_context_create(); + + #ifdef VFC_CI + vfc_probes probes = vfc_init_probes(); + #endif #+end_src #+begin_src c :tangle (eval c) @@ -107,7 +115,7 @@ int main() { | ~prim_factor~ | ~[prim_num]~ | Normalization factors of the primtives | Computed data: - + |----------------------+-------------------------------------+-----------------------------------------------------------------------------------------------| | ~nucleus_prim_index~ | ~[nucl_num]~ | Index of the first primitive for each nucleus | | ~primitive_vgl~ | ~[prim_num][5][walk_num][elec_num]~ | Value, gradients, Laplacian of the primitives at electron positions | @@ -202,10 +210,10 @@ typedef struct qmckl_ao_basis_struct { Some values are initialized by default, and are not concerned by this mechanism. - #+begin_src c :comments org :tangle (eval h_private_func) + #+begin_src c :comments org :tangle (eval h_private_func) qmckl_exit_code qmckl_init_ao_basis(qmckl_context context); #+end_src - + #+begin_src c :comments org :tangle (eval c) qmckl_exit_code qmckl_init_ao_basis(qmckl_context context) { @@ -225,7 +233,7 @@ qmckl_exit_code qmckl_init_ao_basis(qmckl_context context) { return QMCKL_SUCCESS; } #+end_src - + ** Access functions #+begin_src c :comments org :tangle (eval h_private_func) :exports none @@ -1026,16 +1034,16 @@ qmckl_exit_code qmckl_finalize_basis(qmckl_context context) { ctx->ao_basis.nucleus_prim_index[i] = ctx->ao_basis.shell_prim_index[shell_idx]; } ctx->ao_basis.nucleus_prim_index[nucl_num] = ctx->ao_basis.prim_num; - + /* TODO : sort the basis set here */ return QMCKL_SUCCESS; } #+end_src - + ** Fortran interfaces - #+begin_src f90 :tangle (eval fh_func) :comments org :exports none + #+begin_src f90 :tangle (eval fh_func) :comments org :exports none interface integer(c_int32_t) function qmckl_set_ao_basis_type (context, t) & bind(C) @@ -1087,7 +1095,7 @@ interface end function end interface interface - integer(c_int32_t) function qmckl_set_ao_basis_nucleus_shell_ang_mom(context,shell_ang_mom) & + integer(c_int32_t) function qmckl_set_ao_basis_shell_ang_mom(context,shell_ang_mom) & bind(C) use, intrinsic :: iso_c_binding import @@ -1097,7 +1105,7 @@ interface end function end interface interface - integer(c_int32_t) function qmckl_set_ao_basis_nucleus_shell_prim_num(context,shell_prim_num) & + integer(c_int32_t) function qmckl_set_ao_basis_shell_prim_num(context,shell_prim_num) & bind(C) use, intrinsic :: iso_c_binding import @@ -1107,7 +1115,7 @@ interface end function end interface interface - integer(c_int32_t) function qmckl_set_ao_basis_nucleus_shell_prim_index(context,shell_prim_index) & + integer(c_int32_t) function qmckl_set_ao_basis_shell_prim_index(context,shell_prim_index) & bind(C) use, intrinsic :: iso_c_binding import @@ -1117,7 +1125,7 @@ interface end function end interface interface - integer(c_int32_t) function qmckl_set_ao_basis_nucleus_shell_factor(context,shell_factor) & + integer(c_int32_t) function qmckl_set_ao_basis_shell_factor(context,shell_factor) & bind(C) use, intrinsic :: iso_c_binding import @@ -1127,7 +1135,7 @@ interface end function end interface interface - integer(c_int32_t) function qmckl_set_ao_basis_nucleus_exponent(context,exponent) & + integer(c_int32_t) function qmckl_set_ao_basis_exponent(context,exponent) & bind(C) use, intrinsic :: iso_c_binding import @@ -1137,7 +1145,7 @@ interface end function end interface interface - integer(c_int32_t) function qmckl_set_ao_basis_nucleus_coefficient(context,coefficient) & + integer(c_int32_t) function qmckl_set_ao_basis_coefficient(context,coefficient) & bind(C) use, intrinsic :: iso_c_binding import @@ -1147,7 +1155,7 @@ interface end function end interface interface - integer(c_int32_t) function qmckl_set_ao_basis_nucleus_prim_factor(context,prim_factor) & + integer(c_int32_t) function qmckl_set_ao_basis_prim_factor(context,prim_factor) & bind(C) use, intrinsic :: iso_c_binding import @@ -1243,7 +1251,7 @@ assert(rc == QMCKL_SUCCESS); assert(qmckl_ao_basis_provided(context)); #+end_src - + * Radial part ** General functions for Gaussian basis functions @@ -1385,12 +1393,27 @@ end function qmckl_ao_gaussian_vgl # Test #+begin_src f90 :tangle (eval f_test) +#ifdef VFC_CI +integer(c_int32_t) function test_qmckl_ao_gaussian_vgl(context, probes) bind(C) +#else integer(c_int32_t) function test_qmckl_ao_gaussian_vgl(context) bind(C) +#endif use qmckl + +#ifdef VFC_CI + use iso_c_binding + use vfc_probes_f +#endif + implicit none integer(c_int64_t), intent(in), value :: context +#ifdef VFC_CI + type(vfc_probes) :: probes + integer(C_INT) :: vfc_err +#endif + integer*8 :: n, ldv, j, i double precision :: X(3), R(3), Y(3), r2 double precision, allocatable :: VGL(:,:), A(:) @@ -1414,10 +1437,17 @@ integer(c_int32_t) function test_qmckl_ao_gaussian_vgl(context) bind(C) test_qmckl_ao_gaussian_vgl = & qmckl_ao_gaussian_vgl(context, X, R, n, A, VGL, ldv) + +#ifdef VFC_CI + vfc_err = vfc_probe(probes, "ao"//C_NULL_CHAR, "gaussian_vgl"//C_NULL_CHAR, & + DBLE(test_qmckl_ao_gaussian_vgl)) +#else if (test_qmckl_ao_gaussian_vgl /= 0) return +#endif test_qmckl_ao_gaussian_vgl = -1 +#ifndef VFC_CI do i=1,n test_qmckl_ao_gaussian_vgl = -11 if (dabs(1.d0 - VGL(i,1) / (& @@ -1444,6 +1474,7 @@ integer(c_int32_t) function test_qmckl_ao_gaussian_vgl(context) bind(C) A(i) * (4.d0*r2*A(i) - 6.d0) * dexp(-A(i) * r2) & )) > epsilon ) return end do +#endif test_qmckl_ao_gaussian_vgl = 0 @@ -1452,8 +1483,13 @@ end function test_qmckl_ao_gaussian_vgl #+end_src #+begin_src c :tangle (eval c_test) :exports none +#ifdef VFC_CI + int test_qmckl_ao_gaussian_vgl(qmckl_context context, vfc_probes * probes); + assert(0 == test_qmckl_ao_gaussian_vgl(context, &probes)); +#else int test_qmckl_ao_gaussian_vgl(qmckl_context context); assert(0 == test_qmckl_ao_gaussian_vgl(context)); +#endif #+end_src ** TODO General functions for Slater basis functions @@ -1468,7 +1504,7 @@ qmckl_exit_code qmckl_get_ao_basis_primitive_vgl(qmckl_context context, double* #+begin_src c :comments org :tangle (eval c) :noweb yes :exports none qmckl_exit_code qmckl_get_ao_basis_primitive_vgl(qmckl_context context, double* const primitive_vgl) { - + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { return QMCKL_NULL_CONTEXT; } @@ -1511,7 +1547,7 @@ qmckl_exit_code qmckl_provide_ao_basis_primitive_vgl(qmckl_context context) "qmckl_ao_basis_primitive_vgl", NULL); } - + /* Compute if necessary */ if (ctx->electron.coord_new_date > ctx->ao_basis.primitive_vgl_date) { @@ -1532,7 +1568,7 @@ qmckl_exit_code qmckl_provide_ao_basis_primitive_vgl(qmckl_context context) ctx->ao_basis.primitive_vgl = primitive_vgl; } - qmckl_exit_code rc; + qmckl_exit_code rc; if (ctx->ao_basis.type == 'G') { rc = qmckl_compute_ao_basis_primitive_gaussian_vgl(context, ctx->ao_basis.prim_num, @@ -1549,7 +1585,7 @@ qmckl_exit_code qmckl_provide_ao_basis_primitive_vgl(qmckl_context context) QMCKL_FAILURE, "compute_ao_basis_primitive_vgl", "Not yet implemented"); - } + } if (rc != QMCKL_SUCCESS) { return rc; } @@ -1579,7 +1615,7 @@ qmckl_exit_code qmckl_provide_ao_basis_primitive_vgl(qmckl_context context) | double | nucl_coord[3][elec_num] | in | Nuclear coordinates | | double | expo[prim_num] | in | Exponents of the primitives | | double | primitive_vgl[prim_num][5][walk_num][elec_num] | out | Value, gradients and Laplacian of the primitives | - + #+begin_src f90 :comments org :tangle (eval f) :noweb yes integer function qmckl_compute_ao_basis_primitive_gaussian_vgl_f(context, & prim_num, elec_num, nucl_num, walk_num, & @@ -1611,19 +1647,19 @@ integer function qmckl_compute_ao_basis_primitive_gaussian_vgl_f(context, & do iprim = nucleus_prim_index(inucl)+1, nucleus_prim_index(inucl+1) do iwalk = 1, walk_num do ielec = 1, elec_num - x = elec_coord(ielec,1,iwalk) - nucl_coord(inucl,1) - y = elec_coord(ielec,2,iwalk) - nucl_coord(inucl,2) - z = elec_coord(ielec,3,iwalk) - nucl_coord(inucl,3) + x = elec_coord(ielec,1,iwalk) - nucl_coord(inucl,1) + y = elec_coord(ielec,2,iwalk) - nucl_coord(inucl,2) + z = elec_coord(ielec,3,iwalk) - nucl_coord(inucl,3) r2 = x*x + y*y + z*z ar2 = expo(iprim)*r2 if (ar2 > cutoff) cycle - + v = dexp(-ar2) two_a = -2.d0 * expo(iprim) * v primitive_vgl(ielec, iwalk, 1, iprim) = v - primitive_vgl(ielec, iwalk, 2, iprim) = two_a * x + primitive_vgl(ielec, iwalk, 2, iprim) = two_a * x primitive_vgl(ielec, iwalk, 3, iprim) = two_a * y primitive_vgl(ielec, iwalk, 4, iprim) = two_a * z primitive_vgl(ielec, iwalk, 5, iprim) = two_a * (3.d0 - 2.d0*ar2) @@ -1632,7 +1668,7 @@ integer function qmckl_compute_ao_basis_primitive_gaussian_vgl_f(context, & end do end do end do - + end function qmckl_compute_ao_basis_primitive_gaussian_vgl_f #+end_src @@ -1683,7 +1719,7 @@ qmckl_exit_code qmckl_compute_ao_basis_primitive_gaussian_vgl( import numpy as np def f(a,x,y): - return np.exp( -a*(np.linalg.norm(x-y))**2 ) + return np.exp( -a*(np.linalg.norm(x-y))**2 ) def df(a,x,y,n): h0 = 1.e-6 @@ -1750,7 +1786,7 @@ int64_t elec_up_num = chbrclf_elec_up_num; int64_t elec_dn_num = chbrclf_elec_dn_num; double* elec_coord = &(chbrclf_elec_coord[0][0][0]); -rc = qmckl_set_electron_num (context, elec_up_num, elec_dn_num); +rc = qmckl_set_electron_num (context, elec_up_num, elec_dn_num); assert (rc == QMCKL_SUCCESS); rc = qmckl_set_electron_walk_num (context, walk_num); @@ -1758,7 +1794,7 @@ assert (rc == QMCKL_SUCCESS); assert(qmckl_electron_provided(context)); -rc = qmckl_set_electron_coord (context, 'N', elec_coord); +rc = qmckl_set_electron_coord (context, 'N', elec_coord); assert(rc == QMCKL_SUCCESS); @@ -1773,13 +1809,13 @@ assert( fabs(prim_vgl[7][1][0][26] - (-7.5014974095310560E-004)) < 1.e-14 ); assert( fabs(prim_vgl[7][2][0][26] - (-3.8250692897610380E-003)) < 1.e-14 ); assert( fabs(prim_vgl[7][3][0][26] - ( 3.4950559194080275E-003)) < 1.e-14 ); assert( fabs(prim_vgl[7][4][0][26] - ( 2.0392163767356572E-002)) < 1.e-14 ); - + assert( fabs(prim_vgl[39][0][1][15] - ( 1.0825844173157661E-003)) < 1.e-14 ); assert( fabs(prim_vgl[39][1][1][15] - ( 2.3774237611651531E-003)) < 1.e-14 ); assert( fabs(prim_vgl[39][2][1][15] - ( 2.1423191526963063E-003)) < 1.e-14 ); assert( fabs(prim_vgl[39][3][1][15] - ( 4.3312003523048492E-004)) < 1.e-14 ); assert( fabs(prim_vgl[39][4][1][15] - ( 7.5174404780004771E-003)) < 1.e-14 ); - + } @@ -1796,11 +1832,11 @@ k=0; for (m=0 ; melectron.coord_new_date > ctx->ao_basis.shell_vgl_date) { @@ -1892,7 +1942,7 @@ qmckl_exit_code qmckl_provide_ao_basis_shell_vgl(qmckl_context context) ctx->ao_basis.shell_vgl = shell_vgl; } - qmckl_exit_code rc; + qmckl_exit_code rc; if (ctx->ao_basis.type == 'G') { rc = qmckl_compute_ao_basis_shell_gaussian_vgl(context, ctx->ao_basis.prim_num, @@ -1914,7 +1964,7 @@ qmckl_exit_code qmckl_provide_ao_basis_shell_vgl(qmckl_context context) QMCKL_FAILURE, "compute_ao_basis_shell_vgl", "Not yet implemented"); - } + } if (rc != QMCKL_SUCCESS) { return rc; } @@ -1949,7 +1999,7 @@ qmckl_exit_code qmckl_provide_ao_basis_shell_vgl(qmckl_context context) | ~double~ | ~expo[prim_num]~ | in | Exponents of the primitives | | ~double~ | ~coef[prim_num]~ | in | Coefficients of the primitives | | ~double~ | ~shell_vgl[shell_num][5][walk_num][elec_num]~ | out | Value, gradients and Laplacian of the shells | - + #+begin_src f90 :comments org :tangle (eval f) :noweb yes integer function qmckl_compute_ao_basis_shell_gaussian_vgl_f(context, & prim_num, shell_num, elec_num, nucl_num, walk_num, & @@ -1978,8 +2028,9 @@ integer function qmckl_compute_ao_basis_shell_gaussian_vgl_f(context, & double precision :: x, y, z, two_a, ar2, r2, v, cutoff info = QMCKL_SUCCESS - + ! Don't compute exponentials when the result will be almost zero. + ! TODO : Use numerical precision here cutoff = -dlog(1.d-15) do inucl=1,nucl_num @@ -1991,9 +2042,9 @@ integer function qmckl_compute_ao_basis_shell_gaussian_vgl_f(context, & shell_vgl(ielec, iwalk, 1:5, ishell) = 0.d0 - x = elec_coord(ielec,1,iwalk) - nucl_coord(inucl,1) - y = elec_coord(ielec,2,iwalk) - nucl_coord(inucl,2) - z = elec_coord(ielec,3,iwalk) - nucl_coord(inucl,3) + x = elec_coord(ielec,1,iwalk) - nucl_coord(inucl,1) + y = elec_coord(ielec,2,iwalk) - nucl_coord(inucl,2) + z = elec_coord(ielec,3,iwalk) - nucl_coord(inucl,3) r2 = x*x + y*y + z*z @@ -2006,30 +2057,30 @@ integer function qmckl_compute_ao_basis_shell_gaussian_vgl_f(context, & v = coef(iprim) * dexp(-ar2) two_a = -2.d0 * expo(iprim) * v - + shell_vgl(ielec, iwalk, 1, ishell) = & shell_vgl(ielec, iwalk, 1, ishell) + v - + shell_vgl(ielec, iwalk, 2, ishell) = & - shell_vgl(ielec, iwalk, 2, ishell) + two_a * x - + shell_vgl(ielec, iwalk, 2, ishell) + two_a * x + shell_vgl(ielec, iwalk, 3, ishell) = & - shell_vgl(ielec, iwalk, 3, ishell) + two_a * y - + shell_vgl(ielec, iwalk, 3, ishell) + two_a * y + shell_vgl(ielec, iwalk, 4, ishell) = & - shell_vgl(ielec, iwalk, 4, ishell) + two_a * z - + shell_vgl(ielec, iwalk, 4, ishell) + two_a * z + shell_vgl(ielec, iwalk, 5, ishell) = & shell_vgl(ielec, iwalk, 5, ishell) + two_a * (3.d0 - 2.d0*ar2) end do - + end do end do - + end do end do - + end function qmckl_compute_ao_basis_shell_gaussian_vgl_f #+end_src @@ -2119,7 +2170,7 @@ qmckl_exit_code qmckl_compute_ao_basis_shell_gaussian_vgl( import numpy as np def f(a,x,y): - return np.sum( [c * np.exp( -b*(np.linalg.norm(x-y))**2) for b,c in a] ) + return np.sum( [c * np.exp( -b*(np.linalg.norm(x-y))**2) for b,c in a] ) def df(a,x,y,n): h0 = 1.e-6 @@ -2203,7 +2254,7 @@ int64_t elec_up_num = chbrclf_elec_up_num; int64_t elec_dn_num = chbrclf_elec_dn_num; double* elec_coord = &(chbrclf_elec_coord[0][0][0]); -rc = qmckl_set_electron_num (context, elec_up_num, elec_dn_num); +rc = qmckl_set_electron_num (context, elec_up_num, elec_dn_num); assert (rc == QMCKL_SUCCESS); rc = qmckl_set_electron_walk_num (context, walk_num); @@ -2211,7 +2262,7 @@ assert (rc == QMCKL_SUCCESS); assert(qmckl_electron_provided(context)); -rc = qmckl_set_electron_coord (context, 'N', elec_coord); +rc = qmckl_set_electron_coord (context, 'N', elec_coord); assert(rc == QMCKL_SUCCESS); @@ -2225,7 +2276,7 @@ printf(" shell_vgl[1][1][0][26] %25.15e\n", shell_vgl[1][1][0][26]); printf(" shell_vgl[1][2][0][26] %25.15e\n", shell_vgl[1][2][0][26]); printf(" shell_vgl[1][3][0][26] %25.15e\n", shell_vgl[1][3][0][26]); printf(" shell_vgl[1][4][0][26] %25.15e\n", shell_vgl[1][4][0][26]); - + printf(" shell_vgl[14][0][1][15] %25.15e\n", shell_vgl[14][0][1][15]); printf(" shell_vgl[14][1][1][15] %25.15e\n", shell_vgl[14][1][1][15]); printf(" shell_vgl[14][2][1][15] %25.15e\n", shell_vgl[14][2][1][15]); @@ -2237,16 +2288,15 @@ assert( fabs(shell_vgl[1][1][0][26] - ( -2.615250164814435e-02)) < 1.e-14 ); assert( fabs(shell_vgl[1][2][0][26] - ( -1.333535498894419e-01)) < 1.e-14 ); assert( fabs(shell_vgl[1][3][0][26] - ( 1.218482800201208e-01)) < 1.e-14 ); assert( fabs(shell_vgl[1][4][0][26] - ( 3.197054084474042e-02)) < 1.e-14 ); - + assert( fabs(shell_vgl[14][0][1][15] - ( 4.509748459243634e-02)) < 1.e-14 ); assert( fabs(shell_vgl[14][1][1][15] - ( 3.203917730584210e-02)) < 1.e-14 ); assert( fabs(shell_vgl[14][2][1][15] - ( 2.887080725789477e-02)) < 1.e-14 ); assert( fabs(shell_vgl[14][3][1][15] - ( 5.836910453297223e-03)) < 1.e-14 ); assert( fabs(shell_vgl[14][4][1][15] - ( 1.572966698871693e-02)) < 1.e-14 ); -} +} #+end_src - * Polynomial part ** General functions for Powers of $x-X_i$ :PROPERTIES: @@ -2290,7 +2340,7 @@ assert( fabs(shell_vgl[14][4][1][15] - ( 1.572966698871693e-02)) < 1.e-14 ); const double* X, const int32_t* LMAX, double* const P, - const int64_t ldp ); + const int64_t ldp ); #+end_src *** Source @@ -2395,10 +2445,26 @@ end function qmckl_ao_power_f *** Test #+begin_src f90 :tangle (eval f_test) +#ifdef VFC_CI +integer(c_int32_t) function test_qmckl_ao_power(context, probes) bind(C) +#else integer(c_int32_t) function test_qmckl_ao_power(context) bind(C) +#endif + use qmckl + +#ifdef VFC_CI + use iso_c_binding + use vfc_probes_f +#endif + implicit none +#ifdef VFC_CI + type(vfc_probes) :: probes + integer(C_INT) :: vfc_err +#endif + integer(qmckl_context), intent(in), value :: context integer*8 :: n, LDP @@ -2420,7 +2486,13 @@ integer(c_int32_t) function test_qmckl_ao_power(context) bind(C) end do test_qmckl_ao_power = qmckl_ao_power(context, n, X, LMAX, P, LDP) + +#ifdef VFC_CI + vfc_err = vfc_probe(probes, "ao"//C_NULL_CHAR, "power"//C_NULL_CHAR, & + DBLE(test_qmckl_ao_power)) +#else if (test_qmckl_ao_power /= QMCKL_SUCCESS) return +#endif test_qmckl_ao_power = QMCKL_FAILURE @@ -2440,8 +2512,13 @@ end function test_qmckl_ao_power #+end_src #+begin_src c :tangle (eval c_test) :exports none +#ifdef VFC_CI + int test_qmckl_ao_power(qmckl_context context, vfc_probes * probes); + assert(0 == test_qmckl_ao_power(context, &probes)); +#else int test_qmckl_ao_power(qmckl_context context); assert(0 == test_qmckl_ao_power(context)); +#endif #+end_src ** General functions for Value, Gradient and Laplacian of a polynomial @@ -2724,12 +2801,27 @@ end function qmckl_ao_polynomial_vgl_f *** Test #+begin_src f90 :tangle (eval f_test) +#ifdef VFC_CI +integer(c_int32_t) function test_qmckl_ao_polynomial_vgl(context, probes) bind(C) +#else integer(c_int32_t) function test_qmckl_ao_polynomial_vgl(context) bind(C) +#endif use qmckl + +#ifdef VFC_CI + use iso_c_binding + use vfc_probes_f +#endif + implicit none integer(c_int64_t), intent(in), value :: context +#ifdef VFC_CI + type(vfc_probes) :: probes + integer(C_INT) :: vfc_err +#endif + integer :: lmax, d, i integer, allocatable :: L(:,:) integer*8 :: n, ldl, ldv, j @@ -2755,9 +2847,15 @@ integer(c_int32_t) function test_qmckl_ao_polynomial_vgl(context) bind(C) test_qmckl_ao_polynomial_vgl = & qmckl_ao_polynomial_vgl(context, X, R, lmax, n, L, ldl, VGL, ldv) +#ifdef VFC_CI + vfc_err = vfc_probe(probes, "ao"//C_NULL_CHAR, "polynomial_vgl"//C_NULL_CHAR, & + DBLE(test_qmckl_ao_polynomial_vgl)) +#else if (test_qmckl_ao_polynomial_vgl /= QMCKL_SUCCESS) return if (n /= d) return +#endif +#ifdef VFC_CI do j=1,n test_qmckl_ao_polynomial_vgl = QMCKL_FAILURE do i=1,3 @@ -2808,6 +2906,7 @@ integer(c_int32_t) function test_qmckl_ao_polynomial_vgl(context) bind(C) end if if (dabs(1.d0 - VGL(5,j) / w) > epsilon ) return end do +#endif test_qmckl_ao_polynomial_vgl = QMCKL_SUCCESS @@ -2816,8 +2915,13 @@ end function test_qmckl_ao_polynomial_vgl #+end_src #+begin_src c :tangle (eval c_test) +#ifdef VFC_CI + int test_qmckl_ao_polynomial_vgl(qmckl_context context, vfc_probes * probes); + assert(0 == test_qmckl_ao_polynomial_vgl(context, &probes)); +#else int test_qmckl_ao_polynomial_vgl(qmckl_context context); assert(0 == test_qmckl_ao_polynomial_vgl(context)); +#endif #+end_src * Combining radial and polynomial parts @@ -2832,6 +2936,10 @@ end function test_qmckl_ao_polynomial_vgl rc = qmckl_context_destroy(context); assert (rc == QMCKL_SUCCESS); +#ifdef VFC_CI + vfc_dump_probes(&probes); +#endif + return 0; } #+end_src @@ -2865,5 +2973,3 @@ end function test_qmckl_ao_polynomial_vgl # -*- mode: org -*- # vim: syntax=c - - diff --git a/org/qmckl_distance.org b/org/qmckl_distance.org index 082209b..804ee69 100644 --- a/org/qmckl_distance.org +++ b/org/qmckl_distance.org @@ -12,13 +12,21 @@ Functions for the computation of distances between particles. #+begin_src c :comments link :tangle (eval c_test) :noweb yes #include "qmckl.h" #include "assert.h" +#include #ifdef HAVE_CONFIG_H #include "config.h" #endif +#ifdef VFC_CI +#include +#endif int main() { qmckl_context context; context = qmckl_context_create(); +#ifdef VFC_CI + vfc_probes probes = vfc_init_probes(); +#endif + #+end_src * Squared distance @@ -282,11 +290,28 @@ end function qmckl_distance_sq_f *** Test :noexport: #+begin_src f90 :tangle (eval f_test) +#ifdef VFC_CI +integer(qmckl_exit_code) function test_qmckl_distance_sq(context, probes) bind(C) +#else integer(qmckl_exit_code) function test_qmckl_distance_sq(context) bind(C) +#endif + use qmckl + +#ifdef VFC_CI + use iso_c_binding + use vfc_probes_f +#endif + implicit none + integer(qmckl_context), intent(in), value :: context +#ifdef VFC_CI + type(vfc_probes) :: probes + integer(C_INT) :: vfc_err +#endif + double precision, allocatable :: A(:,:), B(:,:), C(:,:) integer*8 :: m, n, LDA, LDB, LDC double precision :: x @@ -298,6 +323,8 @@ integer(qmckl_exit_code) function test_qmckl_distance_sq(context) bind(C) LDB = n LDC = 5 + print *, "Entering test 1" + allocate( A(LDA,m), B(LDB,n), C(LDC,n) ) do j=1,m @@ -314,17 +341,32 @@ integer(qmckl_exit_code) function test_qmckl_distance_sq(context) bind(C) test_qmckl_distance_sq = & qmckl_distance_sq(context, 'X', 't', m, n, A, LDA, B, LDB, C, LDC) +#ifdef VFC_CI + print *, "About to create probe" + vfc_err = vfc_probe(probes, "distance"//C_NULL_CHAR, & + "distance_sq_Xt"//C_NULL_CHAR, DBLE(test_qmckl_distance_sq)) + print *, "Created probe" +#else if (test_qmckl_distance_sq == 0) return +#endif test_qmckl_distance_sq = & qmckl_distance_sq(context, 't', 'X', m, n, A, LDA, B, LDB, C, LDC) - +#ifdef VFC_CI + vfc_err = vfc_probe(probes, "distance"//C_NULL_CHAR, & + "distance_sq_tX"//C_NULL_CHAR, DBLE(test_qmckl_distance_sq)) +#else if (test_qmckl_distance_sq == 0) return +#endif test_qmckl_distance_sq = & qmckl_distance_sq(context, 'T', 't', m, n, A, LDA, B, LDB, C, LDC) - - if (test_qmckl_distance_sq /= 0) return +#ifdef VFC_CI + vfc_err = vfc_probe(probes, "distance"//C_NULL_CHAR, & + "distance_sq_Tt"//C_NULL_CHAR, DBLE(test_qmckl_distance_sq)) +#else + if (test_qmckl_distance_sq == 0) return +#endif test_qmckl_distance_sq = QMCKL_FAILURE @@ -333,14 +375,20 @@ integer(qmckl_exit_code) function test_qmckl_distance_sq(context) bind(C) x = (A(i,1)-B(j,1))**2 + & (A(i,2)-B(j,2))**2 + & (A(i,3)-B(j,3))**2 - if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return +#ifndef VFC_CI + if ( dabs(1.d0 - C(i,j)/x) > 1.d-14) return +#endif end do end do test_qmckl_distance_sq = & qmckl_distance_sq(context, 'n', 'T', m, n, A, LDA, B, LDB, C, LDC) - - if (test_qmckl_distance_sq /= 0) return +#ifdef VFC_CI + vfc_err = vfc_probe(probes, "distance"//C_NULL_CHAR, & + "distance_sq_nT"//C_NULL_CHAR, DBLE(test_qmckl_distance_sq)) +#else + if (test_qmckl_distance_sq == 0) return +#endif test_qmckl_distance_sq = QMCKL_FAILURE @@ -349,14 +397,20 @@ integer(qmckl_exit_code) function test_qmckl_distance_sq(context) bind(C) x = (A(1,i)-B(j,1))**2 + & (A(2,i)-B(j,2))**2 + & (A(3,i)-B(j,3))**2 - if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return +#ifndef VFC_CI + if ( dabs(1.d0 - C(i,j)/x) > 1.d-14) return +#endif end do end do test_qmckl_distance_sq = & qmckl_distance_sq(context, 'T', 'n', m, n, A, LDA, B, LDB, C, LDC) - - if (test_qmckl_distance_sq /= 0) return +#ifdef VFC_CI + vfc_err = vfc_probe(probes, "distance"//C_NULL_CHAR, & + "distance_sq_Tn"//C_NULL_CHAR, DBLE(test_qmckl_distance_sq)) +#else + if (test_qmckl_distance_sq == 0) return +#endif test_qmckl_distance_sq = QMCKL_FAILURE @@ -365,14 +419,20 @@ integer(qmckl_exit_code) function test_qmckl_distance_sq(context) bind(C) x = (A(i,1)-B(1,j))**2 + & (A(i,2)-B(2,j))**2 + & (A(i,3)-B(3,j))**2 - if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return +#ifndef VFC_CI + if ( dabs(1.d0 - C(i,j)/x) > 1.d-14) return +#endif end do end do test_qmckl_distance_sq = & qmckl_distance_sq(context, 'n', 'N', m, n, A, LDA, B, LDB, C, LDC) - - if (test_qmckl_distance_sq /= 0) return +#ifdef VFC_CI + vfc_err = vfc_probe(probes, "distance"//C_NULL_CHAR, & + "distance_sq_nN"//C_NULL_CHAR, DBLE(test_qmckl_distance_sq)) +#else + if (test_qmckl_distance_sq == 0) return +#endif test_qmckl_distance_sq = QMCKL_FAILURE @@ -392,8 +452,13 @@ end function test_qmckl_distance_sq #+end_src #+begin_src c :comments link :tangle (eval c_test) -qmckl_exit_code test_qmckl_distance_sq(qmckl_context context); -assert(test_qmckl_distance_sq(context) == QMCKL_SUCCESS); +#ifdef VFC_CI + qmckl_exit_code test_qmckl_distance_sq(qmckl_context context, vfc_probes * probes); + assert(test_qmckl_distance_sq(context, &probes) == QMCKL_SUCCESS); +#else + qmckl_exit_code test_qmckl_distance_sq(qmckl_context context); + assert(test_qmckl_distance_sq(context) == QMCKL_SUCCESS); +#endif #+end_src * Distance @@ -690,10 +755,23 @@ end function qmckl_distance_f *** Test :noexport: #+begin_src f90 :tangle (eval f_test) +#ifdef VFC_CI +integer(qmckl_exit_code) function test_qmckl_dist(context, probes) bind(C) +#else integer(qmckl_exit_code) function test_qmckl_dist(context) bind(C) +#endif use qmckl +#ifdef VFC_CI + use iso_c_binding + use vfc_probes_f +#endif implicit none + integer(qmckl_context), intent(in), value :: context +#ifdef VFC_CI + type(vfc_probes) :: probes + integer(C_INT) :: vfc_err +#endif double precision, allocatable :: A(:,:), B(:,:), C(:,:) integer*8 :: m, n, LDA, LDB, LDC @@ -721,18 +799,30 @@ integer(qmckl_exit_code) function test_qmckl_dist(context) bind(C) test_qmckl_dist = & qmckl_distance(context, 'X', 't', m, n, A, LDA, B, LDB, C, LDC) - +#ifdef VFC_CI + vfc_err = vfc_probe(probes, "distance"//C_NULL_CHAR, & + "distance_Xt"//C_NULL_CHAR, DBLE(test_qmckl_dist)) +#else if (test_qmckl_dist == 0) return +#endif test_qmckl_dist = & qmckl_distance(context, 't', 'X', m, n, A, LDA, B, LDB, C, LDC) - +#ifdef VFC_CI + vfc_err = vfc_probe(probes, "distance"//C_NULL_CHAR, & + "distance_tX"//C_NULL_CHAR, DBLE(test_qmckl_dist)) +#else if (test_qmckl_dist == 0) return +#endif test_qmckl_dist = & qmckl_distance(context, 'T', 't', m, n, A, LDA, B, LDB, C, LDC) - - if (test_qmckl_dist /= 0) return +#ifdef VFC_CI + vfc_err = vfc_probe(probes, "distance"//C_NULL_CHAR, & + "distance_Tt"//C_NULL_CHAR, DBLE(test_qmckl_dist)) +#else + if (test_qmckl_dist == 0) return +#endif test_qmckl_dist = QMCKL_FAILURE @@ -741,14 +831,20 @@ integer(qmckl_exit_code) function test_qmckl_dist(context) bind(C) x = dsqrt((A(i,1)-B(j,1))**2 + & (A(i,2)-B(j,2))**2 + & (A(i,3)-B(j,3))**2) - if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return +#ifndef VFC_CI + if ( dabs(1.d0 - C(i,j)/x) > 1.d-14) return +#endif end do end do test_qmckl_dist = & qmckl_distance(context, 'n', 'T', m, n, A, LDA, B, LDB, C, LDC) - - if (test_qmckl_dist /= 0) return +#ifdef VFC_CI + vfc_err = vfc_probe(probes, "distance"//C_NULL_CHAR, & + "distance_nT"//C_NULL_CHAR, DBLE(test_qmckl_dist)) +#else + if (test_qmckl_dist == 0) return +#endif test_qmckl_dist = QMCKL_FAILURE @@ -757,14 +853,20 @@ integer(qmckl_exit_code) function test_qmckl_dist(context) bind(C) x = dsqrt((A(1,i)-B(j,1))**2 + & (A(2,i)-B(j,2))**2 + & (A(3,i)-B(j,3))**2) - if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return +#ifndef VFC_CI + if ( dabs(1.d0 - C(i,j)/x) > 1.d-14) return +#endif end do end do test_qmckl_dist = & qmckl_distance(context, 'T', 'n', m, n, A, LDA, B, LDB, C, LDC) - - if (test_qmckl_dist /= 0) return +#ifdef VFC_CI + vfc_err = vfc_probe(probes, "distance"//C_NULL_CHAR, & + "distance_Tn"//C_NULL_CHAR, DBLE(test_qmckl_dist)) +#else + if (test_qmckl_dist == 0) return +#endif test_qmckl_dist = QMCKL_FAILURE @@ -773,14 +875,20 @@ integer(qmckl_exit_code) function test_qmckl_dist(context) bind(C) x = dsqrt((A(i,1)-B(1,j))**2 + & (A(i,2)-B(2,j))**2 + & (A(i,3)-B(3,j))**2) - if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return +#ifndef VFC_CI + if ( dabs(1.d0 - C(i,j)/x) > 1.d-14) return +#endif end do end do test_qmckl_dist = & qmckl_distance(context, 'n', 'N', m, n, A, LDA, B, LDB, C, LDC) - - if (test_qmckl_dist /= 0) return +#ifdef VFC_CI + vfc_err = vfc_probe(probes, "distance"//C_NULL_CHAR, & + "distance_nN"//C_NULL_CHAR, DBLE(test_qmckl_dist)) +#else + if (test_qmckl_dist == 0) return +#endif test_qmckl_dist = QMCKL_FAILURE @@ -789,7 +897,9 @@ integer(qmckl_exit_code) function test_qmckl_dist(context) bind(C) x = dsqrt((A(1,i)-B(1,j))**2 + & (A(2,i)-B(2,j))**2 + & (A(3,i)-B(3,j))**2) - if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return +#ifndef VFC_CI + if ( dabs(1.d0 - C(i,j)/x) > 1.d-14) return +#endif end do end do @@ -800,8 +910,13 @@ end function test_qmckl_dist #+end_src #+begin_src c :comments link :tangle (eval c_test) -qmckl_exit_code test_qmckl_dist(qmckl_context context); -assert(test_qmckl_dist(context) == QMCKL_SUCCESS); +#ifdef VFC_CI + qmckl_exit_code test_qmckl_dist(qmckl_context context, vfc_probes * probes); + assert(test_qmckl_dist(context, &probes) == QMCKL_SUCCESS); +#else + qmckl_exit_code test_qmckl_dist(qmckl_context context); + assert(test_qmckl_dist(context) == QMCKL_SUCCESS); +#endif #+end_src * Rescaled Distance @@ -1114,12 +1229,12 @@ end function qmckl_distance_rescaled_f :FRetType: qmckl_exit_code :END: - ~qmckl_distance_rescaled_deriv_e~ computes the matrix of the gradient and laplacian of the + ~qmckl_distance_rescaled_deriv_e~ computes the matrix of the gradient and laplacian of the rescaled distance with respect to the electron coordinates. The derivative is a rank 3 tensor. The first dimension has a dimension of 4 of which the first three coordinates contains the gradient vector and the last index is the laplacian. - - + + \[ C_{ij} = \left( 1 - \exp{-\kappa C_{ij}}\right)/\kappa \] @@ -1130,12 +1245,12 @@ end function qmckl_distance_rescaled_f \nabla (C_{ij}(\mathbf{r}_{ee})) = \left(\frac{\delta C_{ij}(\mathbf{r}_{ee})}{\delta x},\frac{\delta C_{ij}(\mathbf{r}_{ee})}{\delta y},\frac{\delta C_{ij}(\mathbf{r}_{ee})}{\delta z} \right) \] and the laplacian is defined as follows: - + \[ \triangle (C_{ij}(r_{ee})) = \frac{\delta^2}{\delta x^2} + \frac{\delta^2}{\delta y^2} + \frac{\delta^2}{\delta z^2} \] - Using the above three formulae, the expression for the gradient and laplacian is + Using the above three formulae, the expression for the gradient and laplacian is as follows: \[ @@ -1463,6 +1578,11 @@ end function qmckl_distance_rescaled_deriv_e_f #+begin_src c :comments link :tangle (eval c_test) assert (qmckl_context_destroy(context) == QMCKL_SUCCESS); + +#ifdef VFC_CI + vfc_dump_probes(&probes); +#endif + return 0; } diff --git a/org/qmckl_electron.org b/org/qmckl_electron.org index 742ba56..b4b6624 100644 --- a/org/qmckl_electron.org +++ b/org/qmckl_electron.org @@ -608,6 +608,30 @@ qmckl_set_electron_rescale_factor_en(qmckl_context context, return QMCKL_SUCCESS; } + #+end_src + + #+begin_src f90 :comments org :tangle (eval fh_func) :noweb yes +interface + integer(c_int32_t) function qmckl_set_electron_num(context, alpha, beta) bind(C) + use, intrinsic :: iso_c_binding + import + implicit none + + integer (c_int64_t) , intent(in) , value :: context + integer (c_int64_t) , intent(in) , value :: alpha + integer (c_int64_t) , intent(in) , value :: beta + end function +end interface +interface + integer(c_int32_t) function qmckl_set_electron_walk_num(context, walk_num) bind(C) + use, intrinsic :: iso_c_binding + import + implicit none + + integer (c_int64_t) , intent(in) , value :: context + integer (c_int64_t) , intent(in) , value :: walk_num + end function +end interface #+end_src The following function sets the electron coordinates of all the @@ -697,6 +721,20 @@ qmckl_set_electron_coord(qmckl_context context, const char transp, const double* } #+end_src + #+begin_src f90 :comments org :tangle (eval fh_func) :noweb yes +interface + integer(c_int32_t) function qmckl_set_electron_coord(context, transp, coord) bind(C) + use, intrinsic :: iso_c_binding + import + implicit none + + integer (c_int64_t) , intent(in) , value :: context + character , intent(in) , value :: transp + double precision , intent(in) :: coord(*) + end function +end interface + #+end_src + ** Test #+begin_src python :results output :exports none diff --git a/share/doc/qmckl/html/htmlize.el b/share/doc/qmckl/html/htmlize.el new file mode 100644 index 0000000..f5c6d8a --- /dev/null +++ b/share/doc/qmckl/html/htmlize.el @@ -0,0 +1,1882 @@ +;;; htmlize.el --- Convert buffer text and decorations to HTML. -*- lexical-binding: t -*- + +;; Copyright (C) 1997-2003,2005,2006,2009,2011,2012,2014,2017,2018 Hrvoje Niksic + +;; Author: Hrvoje Niksic +;; Homepage: https://github.com/hniksic/emacs-htmlize +;; Keywords: hypermedia, extensions +;; Version: 1.56 + +;; This program 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. + +;; This program 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package converts the buffer text and the associated +;; decorations to HTML. Mail to to discuss +;; features and additions. All suggestions are more than welcome. + +;; To use it, just switch to the buffer you want HTML-ized and type +;; `M-x htmlize-buffer'. You will be switched to a new buffer that +;; contains the resulting HTML code. You can edit and inspect this +;; buffer, or you can just save it with C-x C-w. `M-x htmlize-file' +;; will find a file, fontify it, and save the HTML version in +;; FILE.html, without any additional intervention. `M-x +;; htmlize-many-files' allows you to htmlize any number of files in +;; the same manner. `M-x htmlize-many-files-dired' does the same for +;; files marked in a dired buffer. + +;; htmlize supports three types of HTML output, selected by setting +;; `htmlize-output-type': `css', `inline-css', and `font'. In `css' +;; mode, htmlize uses cascading style sheets to specify colors; it +;; generates classes that correspond to Emacs faces and uses ... to color parts of text. In this mode, the +;; produced HTML is valid under the 4.01 strict DTD, as confirmed by +;; the W3C validator. `inline-css' is like `css', except the CSS is +;; put directly in the STYLE attribute of the SPAN element, making it +;; possible to paste the generated HTML into existing HTML documents. +;; In `font' mode, htmlize uses ... to +;; colorize HTML, which is not standard-compliant, but works better in +;; older browsers. `css' mode is the default. + +;; You can also use htmlize from your Emacs Lisp code. When called +;; non-interactively, `htmlize-buffer' and `htmlize-region' will +;; return the resulting HTML buffer, but will not change current +;; buffer or move the point. htmlize will do its best to work on +;; non-windowing Emacs sessions but the result will be limited to +;; colors supported by the terminal. + +;; htmlize aims for compatibility with older Emacs versions. Please +;; let me know if it doesn't work on the version of GNU Emacs that you +;; are using. The package relies on the presence of CL extensions; +;; please don't try to remove that dependency. I see no practical +;; problems with using the full power of the CL extensions, except +;; that one might learn to like them too much. + +;; The latest version is available at: +;; +;; +;; +;; + +;; Thanks go to the many people who have sent reports and contributed +;; comments, suggestions, and fixes. They include Ron Gut, Bob +;; Weiner, Toni Drabik, Peter Breton, Ville Skytta, Thomas Vogels, +;; Juri Linkov, Maciek Pasternacki, and many others. + +;; User quotes: "You sir, are a sick, sick, _sick_ person. :)" +;; -- Bill Perry, author of Emacs/W3 + + +;;; Code: + +(require 'cl-lib) +(eval-when-compile + (defvar font-lock-auto-fontify) + (defvar font-lock-support-mode) + (defvar global-font-lock-mode)) + +(defconst htmlize-version "1.56") + +(defgroup htmlize nil + "Convert buffer text and faces to HTML." + :group 'hypermedia) + +(defcustom htmlize-head-tags "" + "Additional tags to insert within HEAD of the generated document." + :type 'string + :group 'htmlize) + +(defcustom htmlize-output-type 'css + "Output type of generated HTML, one of `css', `inline-css', or `font'. +When set to `css' (the default), htmlize will generate a style sheet +with description of faces, and use it in the HTML document, specifying +the faces in the actual text with . + +When set to `inline-css', the style will be generated as above, but +placed directly in the STYLE attribute of the span ELEMENT: . This makes it easier to paste the resulting HTML to +other documents. + +When set to `font', the properties will be set using layout tags +, , , , and . + +`css' output is normally preferred, but `font' is still useful for +supporting old, pre-CSS browsers, and both `inline-css' and `font' for +easier embedding of colorized text in foreign HTML documents (no style +sheet to carry around)." + :type '(choice (const css) (const inline-css) (const font)) + :group 'htmlize) + +(defcustom htmlize-use-images t + "Whether htmlize generates `img' for images attached to buffer contents." + :type 'boolean + :group 'htmlize) + +(defcustom htmlize-force-inline-images nil + "Non-nil means generate all images inline using data URLs. +Normally htmlize converts image descriptors with :file properties to +relative URIs, and those with :data properties to data URIs. With this +flag set, the images specified as a file name are loaded into memory and +embedded in the HTML as data URIs." + :type 'boolean + :group 'htmlize) + +(defcustom htmlize-max-alt-text 100 + "Maximum size of text to use as ALT text in images. + +Normally when htmlize encounters text covered by the `display' property +that specifies an image, it generates an `alt' attribute containing the +original text. If the text is larger than `htmlize-max-alt-text' characters, +this will not be done." + :type 'integer + :group 'htmlize) + +(defcustom htmlize-transform-image 'htmlize-default-transform-image + "Function called to modify the image descriptor. + +The function is called with the image descriptor found in the buffer and +the text the image is supposed to replace. It should return a (possibly +different) image descriptor property list or a replacement string to use +instead of of the original buffer text. + +Returning nil is the same as returning the original text." + :type 'boolean + :group 'htmlize) + +(defcustom htmlize-generate-hyperlinks t + "Non-nil means auto-generate the links from URLs and mail addresses in buffer. + +This is on by default; set it to nil if you don't want htmlize to +autogenerate such links. Note that this option only turns off automatic +search for contents that looks like URLs and converting them to links. +It has no effect on whether htmlize respects the `htmlize-link' property." + :type 'boolean + :group 'htmlize) + +(defcustom htmlize-hyperlink-style " + a { + color: inherit; + background-color: inherit; + font: inherit; + text-decoration: inherit; + } + a:hover { + text-decoration: underline; + } +" + "The CSS style used for hyperlinks when in CSS mode." + :type 'string + :group 'htmlize) + +(defcustom htmlize-replace-form-feeds t + "Non-nil means replace form feeds in source code with HTML separators. +Form feeds are the ^L characters at line beginnings that are sometimes +used to separate sections of source code. If this variable is set to +`t', form feed characters are replaced with the
separator. If this +is a string, it specifies the replacement to use. Note that 
 is
+temporarily closed before the separator is inserted, so the default
+replacement is effectively \"
\".  If you specify
+another replacement, don't forget to close and reopen the 
 if you
+want the output to remain valid HTML.
+
+If you need more elaborate processing, set this to nil and use
+htmlize-after-hook."
+  :type 'boolean
+  :group 'htmlize)
+
+(defcustom htmlize-html-charset nil
+  "The charset declared by the resulting HTML documents.
+When non-nil, causes htmlize to insert the following in the HEAD section
+of the generated HTML:
+
+  
+
+where CHARSET is the value you've set for htmlize-html-charset.  Valid
+charsets are defined by MIME and include strings like \"iso-8859-1\",
+\"iso-8859-15\", \"utf-8\", etc.
+
+If you are using non-Latin-1 charsets, you might need to set this for
+your documents to render correctly.  Also, the W3C validator requires
+submitted HTML documents to declare a charset.  So if you care about
+validation, you can use this to prevent the validator from bitching.
+
+Needless to say, if you set this, you should actually make sure that
+the buffer is in the encoding you're claiming it is in.  (This is
+normally achieved by using the correct file coding system for the
+buffer.)  If you don't understand what that means, you should probably
+leave this option in its default setting."
+  :type '(choice (const :tag "Unset" nil)
+		 string)
+  :group 'htmlize)
+
+(defcustom htmlize-convert-nonascii-to-entities t
+  "Whether non-ASCII characters should be converted to HTML entities.
+
+When this is non-nil, characters with codes in the 128-255 range will be
+considered Latin 1 and rewritten as \"&#CODE;\".  Characters with codes
+above 255 will be converted to \"&#UCS;\", where UCS denotes the Unicode
+code point of the character.  If the code point cannot be determined,
+the character will be copied unchanged, as would be the case if the
+option were nil.
+
+When the option is nil, the non-ASCII characters are copied to HTML
+without modification.  In that case, the web server and/or the browser
+must be set to understand the encoding that was used when saving the
+buffer.  (You might also want to specify it by setting
+`htmlize-html-charset'.)
+
+Note that in an HTML entity \"&#CODE;\", CODE is always a UCS code point,
+which has nothing to do with the charset the page is in.  For example,
+\"©\" *always* refers to the copyright symbol, regardless of charset
+specified by the META tag or the charset sent by the HTTP server.  In
+other words, \"©\" is exactly equivalent to \"©\".
+
+For most people htmlize will work fine with this option left at the
+default setting; don't change it unless you know what you're doing."
+  :type 'sexp
+  :group 'htmlize)
+
+(defcustom htmlize-ignore-face-size 'absolute
+  "Whether face size should be ignored when generating HTML.
+If this is nil, face sizes are used.  If set to t, sizes are ignored
+If set to `absolute', only absolute size specifications are ignored.
+Please note that font sizes only work with CSS-based output types."
+  :type '(choice (const :tag "Don't ignore" nil)
+		 (const :tag "Ignore all" t)
+		 (const :tag "Ignore absolute" absolute))
+  :group 'htmlize)
+
+(defcustom htmlize-css-name-prefix ""
+  "The prefix used for CSS names.
+The CSS names that htmlize generates from face names are often too
+generic for CSS files; for example, `font-lock-type-face' is transformed
+to `type'.  Use this variable to add a prefix to the generated names.
+The string \"htmlize-\" is an example of a reasonable prefix."
+  :type 'string
+  :group 'htmlize)
+
+(defcustom htmlize-use-rgb-txt t
+  "Whether `rgb.txt' should be used to convert color names to RGB.
+
+This conversion means determining, for instance, that the color
+\"IndianRed\" corresponds to the (205, 92, 92) RGB triple.  `rgb.txt'
+is the X color database that maps hundreds of color names to such RGB
+triples.  When this variable is non-nil, `htmlize' uses `rgb.txt' to
+look up color names.
+
+If this variable is nil, htmlize queries Emacs for RGB components of
+colors using `color-instance-rgb-components' and `color-values'.
+This can yield incorrect results on non-true-color displays.
+
+If the `rgb.txt' file is not found (which will be the case if you're
+running Emacs on non-X11 systems), this option is ignored."
+  :type 'boolean
+  :group 'htmlize)
+
+(defvar htmlize-face-overrides nil
+  "Overrides for face definitions.
+
+Normally face definitions are taken from Emacs settings for fonts
+in the current frame.  For faces present in this plist, the
+definitions will be used instead.  Keys in the plist are symbols
+naming the face and values are the overriding definitions.  For
+example:
+
+  (setq htmlize-face-overrides
+        '(font-lock-warning-face \"black\"
+          font-lock-function-name-face \"red\"
+          font-lock-comment-face \"blue\"
+          default (:foreground \"dark-green\" :background \"yellow\")))
+
+This variable can be also be `let' bound when running `htmlize-buffer'.")
+
+(defcustom htmlize-untabify t
+  "Non-nil means untabify buffer contents during htmlization."
+  :type 'boolean
+  :group 'htmlize)
+
+(defcustom htmlize-html-major-mode nil
+  "The mode the newly created HTML buffer will be put in.
+Set this to nil if you prefer the default (fundamental) mode."
+  :type '(radio (const :tag "No mode (fundamental)" nil)
+		 (function-item html-mode)
+		 (function :tag "User-defined major mode"))
+  :group 'htmlize)
+
+(defcustom htmlize-pre-style nil
+  "When non-nil, `
' tags will be decorated with style
+information in `font' and `inline-css' modes. This allows a
+consistent background for captures of regions."
+  :type 'boolean
+  :group 'htmlize)
+
+(defvar htmlize-before-hook nil
+  "Hook run before htmlizing a buffer.
+The hook functions are run in the source buffer (not the resulting HTML
+buffer).")
+
+(defvar htmlize-after-hook nil
+  "Hook run after htmlizing a buffer.
+Unlike `htmlize-before-hook', these functions are run in the generated
+HTML buffer.  You may use them to modify the outlook of the final HTML
+output.")
+
+(defvar htmlize-file-hook nil
+  "Hook run by `htmlize-file' after htmlizing a file, but before saving it.")
+
+(defvar htmlize-buffer-places)
+
+;;; Some cross-Emacs compatibility.
+
+;; We need a function that efficiently finds the next change of a
+;; property regardless of whether the change occurred because of a
+;; text property or an extent/overlay.
+(defun htmlize-next-change (pos prop &optional limit)
+  (if prop
+      (next-single-char-property-change pos prop nil limit)
+    (next-char-property-change pos limit)))
+
+(defun htmlize-overlay-faces-at (pos)
+  (delq nil (mapcar (lambda (o) (overlay-get o 'face)) (overlays-at pos))))
+
+(defun htmlize-next-face-change (pos &optional limit)
+  ;; (htmlize-next-change pos 'face limit) would skip over entire
+  ;; overlays that specify the `face' property, even when they
+  ;; contain smaller text properties that also specify `face'.
+  ;; Emacs display engine merges those faces, and so must we.
+  (or limit
+      (setq limit (point-max)))
+  (let ((next-prop (next-single-property-change pos 'face nil limit))
+        (overlay-faces (htmlize-overlay-faces-at pos)))
+    (while (progn
+             (setq pos (next-overlay-change pos))
+             (and (< pos next-prop)
+                  (equal overlay-faces (htmlize-overlay-faces-at pos)))))
+    (setq pos (min pos next-prop))
+    ;; Additionally, we include the entire region that specifies the
+    ;; `display' property.
+    (when (get-char-property pos 'display)
+      (setq pos (next-single-char-property-change pos 'display nil limit)))
+    pos))
+
+(defmacro htmlize-lexlet (&rest letforms)
+  (declare (indent 1) (debug let))
+  (if (and (boundp 'lexical-binding)
+           lexical-binding)
+      `(let ,@letforms)
+    ;; cl extensions have a macro implementing lexical let
+    `(lexical-let ,@letforms)))
+
+
+;;; Transformation of buffer text: HTML escapes, untabification, etc.
+
+(defvar htmlize-basic-character-table
+  ;; Map characters in the 0-127 range to either one-character strings
+  ;; or to numeric entities.
+  (let ((table (make-vector 128 ?\0)))
+    ;; Map characters in the 32-126 range to themselves, others to
+    ;; &#CODE entities;
+    (dotimes (i 128)
+      (setf (aref table i) (if (and (>= i 32) (<= i 126))
+			       (char-to-string i)
+			     (format "&#%d;" i))))
+    ;; Set exceptions manually.
+    (setf
+     ;; Don't escape newline, carriage return, and TAB.
+     (aref table ?\n) "\n"
+     (aref table ?\r) "\r"
+     (aref table ?\t) "\t"
+     ;; Escape &, <, and >.
+     (aref table ?&) "&"
+     (aref table ?<) "<"
+     (aref table ?>) ">"
+     ;; Not escaping '"' buys us a measurable speedup.  It's only
+     ;; necessary to quote it for strings used in attribute values,
+     ;; which htmlize doesn't typically do.
+     ;(aref table ?\") """
+     )
+    table))
+
+;; A cache of HTML representation of non-ASCII characters.  Depending
+;; on the setting of `htmlize-convert-nonascii-to-entities', this maps
+;; non-ASCII characters to either "&#;" or "" (mapconcat's
+;; mapper must always return strings).  It's only filled as characters
+;; are encountered, so that in a buffer with e.g. French text, it will
+;; only ever contain French accented characters as keys.  It's cleared
+;; on each entry to htmlize-buffer-1 to allow modifications of
+;; `htmlize-convert-nonascii-to-entities' to take effect.
+(defvar htmlize-extended-character-cache (make-hash-table :test 'eq))
+
+(defun htmlize-protect-string (string)
+  "HTML-protect string, escaping HTML metacharacters and I18N chars."
+  ;; Only protecting strings that actually contain unsafe or non-ASCII
+  ;; chars removes a lot of unnecessary funcalls and consing.
+  (if (not (string-match "[^\r\n\t -%'-;=?-~]" string))
+      string
+    (mapconcat (lambda (char)
+		 (cond
+		  ((< char 128)
+		   ;; ASCII: use htmlize-basic-character-table.
+		   (aref htmlize-basic-character-table char))
+		  ((gethash char htmlize-extended-character-cache)
+		   ;; We've already seen this char; return the cached
+		   ;; string.
+		   )
+		  ((not htmlize-convert-nonascii-to-entities)
+		   ;; If conversion to entities is not desired, always
+		   ;; copy the char literally.
+		   (setf (gethash char htmlize-extended-character-cache)
+			 (char-to-string char)))
+		  ((< char 256)
+		   ;; Latin 1: no need to call encode-char.
+		   (setf (gethash char htmlize-extended-character-cache)
+			 (format "&#%d;" char)))
+		  ((encode-char char 'ucs)
+                   ;; Must check if encode-char works for CHAR;
+                   ;; it fails for Arabic and possibly elsewhere.
+		   (setf (gethash char htmlize-extended-character-cache)
+			 (format "&#%d;" (encode-char char 'ucs))))
+		  (t
+		   ;; encode-char doesn't work for this char.  Copy it
+		   ;; unchanged and hope for the best.
+		   (setf (gethash char htmlize-extended-character-cache)
+			 (char-to-string char)))))
+	       string "")))
+
+(defun htmlize-attr-escape (string)
+  ;; Like htmlize-protect-string, but also escapes double-quoted
+  ;; strings to make it usable in attribute values.
+  (setq string (htmlize-protect-string string))
+  (if (not (string-match "\"" string))
+      string
+    (mapconcat (lambda (char)
+                 (if (eql char ?\")
+                     """
+                   (char-to-string char)))
+               string "")))
+
+(defsubst htmlize-concat (list)
+  (if (and (consp list) (null (cdr list)))
+      ;; Don't create a new string in the common case where the list only
+      ;; consists of one element.
+      (car list)
+    (apply #'concat list)))
+
+(defun htmlize-format-link (linkprops text)
+  (let ((uri (if (stringp linkprops)
+                 linkprops
+               (plist-get linkprops :uri)))
+        (escaped-text (htmlize-protect-string text)))
+    (if uri
+        (format "%s" (htmlize-attr-escape uri) escaped-text)
+      escaped-text)))
+
+(defun htmlize-escape-or-link (string)
+  ;; Escape STRING and/or add hyperlinks.  STRING comes from a
+  ;; `display' property.
+  (let ((pos 0) (end (length string)) outlist)
+    (while (< pos end)
+      (let* ((link (get-char-property pos 'htmlize-link string))
+             (next-link-change (next-single-property-change
+                                pos 'htmlize-link string end))
+             (chunk (substring string pos next-link-change)))
+        (push
+         (cond (link
+                (htmlize-format-link link chunk))
+               ((get-char-property 0 'htmlize-literal chunk)
+                chunk)
+               (t
+                (htmlize-protect-string chunk)))
+         outlist)
+        (setq pos next-link-change)))
+    (htmlize-concat (nreverse outlist))))
+
+(defun htmlize-display-prop-to-html (display text)
+  (let (desc)
+    (cond ((stringp display)
+           ;; Emacs ignores recursive display properties.
+           (htmlize-escape-or-link display))
+          ((not (eq (car-safe display) 'image))
+           (htmlize-protect-string text))
+          ((null (setq desc (funcall htmlize-transform-image
+                                     (cdr display) text)))
+           (htmlize-escape-or-link text))
+          ((stringp desc)
+           (htmlize-escape-or-link desc))
+          (t
+           (htmlize-generate-image desc text)))))
+
+(defun htmlize-string-to-html (string)
+  ;; Convert the string to HTML, including images attached as
+  ;; `display' property and links as `htmlize-link' property.  In a
+  ;; string without images or links, this is equivalent to
+  ;; `htmlize-protect-string'.
+  (let ((pos 0) (end (length string)) outlist)
+    (while (< pos end)
+      (let* ((display (get-char-property pos 'display string))
+             (next-display-change (next-single-property-change
+                                   pos 'display string end))
+             (chunk (substring string pos next-display-change)))
+        (push
+         (if display
+             (htmlize-display-prop-to-html display chunk)
+           (htmlize-escape-or-link chunk))
+         outlist)
+        (setq pos next-display-change)))
+    (htmlize-concat (nreverse outlist))))
+
+(defun htmlize-default-transform-image (imgprops _text)
+  "Default transformation of image descriptor to something usable in HTML.
+
+If `htmlize-use-images' is nil, the function always returns nil, meaning
+use original text.  Otherwise, it tries to find the image for images that
+specify a file name.  If `htmlize-force-inline-images' is non-nil, it also
+converts the :file attribute to :data and returns the modified property
+list."
+  (when htmlize-use-images
+    (when (plist-get imgprops :file)
+      (let ((location (plist-get (cdr (find-image (list imgprops))) :file)))
+        (when location
+          (setq imgprops (plist-put (cl-copy-list imgprops) :file location)))))
+    (if htmlize-force-inline-images
+        (let ((location (plist-get imgprops :file))
+              data)
+          (when location
+            (with-temp-buffer
+              (condition-case nil
+                  (progn
+                    (insert-file-contents-literally location)
+                    (setq data (buffer-string)))
+                (error nil))))
+          ;; if successful, return the new plist, otherwise return
+          ;; nil, which will use the original text
+          (and data
+               (plist-put (plist-put imgprops :file nil)
+                          :data data)))
+      imgprops)))
+
+(defun htmlize-alt-text (_imgprops origtext)
+  (and (/= (length origtext) 0)
+       (<= (length origtext) htmlize-max-alt-text)
+       (not (string-match "[\0-\x1f]" origtext))
+       origtext))
+
+(defun htmlize-generate-image (imgprops origtext)
+  (let* ((alt-text (htmlize-alt-text imgprops origtext))
+         (alt-attr (if alt-text
+                       (format " alt=\"%s\"" (htmlize-attr-escape alt-text))
+                     "")))
+    (cond ((plist-get imgprops :file)
+           ;; Try to find the image in image-load-path
+           (let* ((found-props (cdr (find-image (list imgprops))))
+                  (file (or (plist-get found-props :file)
+                            (plist-get imgprops :file))))
+             (format ""
+                     (htmlize-attr-escape (file-relative-name file))
+                     alt-attr)))
+          ((plist-get imgprops :data)
+           (format ""
+                   (or (plist-get imgprops :type) "")
+                   (base64-encode-string (plist-get imgprops :data))
+                   alt-attr)))))
+
+(defconst htmlize-ellipsis "...")
+(put-text-property 0 (length htmlize-ellipsis) 'htmlize-ellipsis t htmlize-ellipsis)
+
+(defun htmlize-match-inv-spec (inv)
+  (cl-member inv buffer-invisibility-spec
+             :key (lambda (i)
+                    (if (symbolp i) i (car i)))))
+
+(defun htmlize-decode-invisibility-spec (invisible)
+  ;; Return t, nil, or `ellipsis', depending on how invisible text should be inserted.
+
+  (if (not (listp buffer-invisibility-spec))
+      ;; If buffer-invisibility-spec is not a list, then all
+      ;; characters with non-nil `invisible' property are visible.
+      (not invisible)
+
+    ;; Otherwise, the value of a non-nil `invisible' property can be:
+    ;; 1. a symbol -- make the text invisible if it matches
+    ;;    buffer-invisibility-spec.
+    ;; 2. a list of symbols -- make the text invisible if
+    ;;    any symbol in the list matches
+    ;;    buffer-invisibility-spec.
+    ;; If the match of buffer-invisibility-spec has a non-nil
+    ;; CDR, replace the invisible text with an ellipsis.
+    (let ((match (if (symbolp invisible)
+                     (htmlize-match-inv-spec invisible)
+                   (cl-some #'htmlize-match-inv-spec invisible))))
+      (cond ((null match) t)
+            ((cdr-safe (car match)) 'ellipsis)
+            (t nil)))))
+
+(defun htmlize-add-before-after-strings (beg end text)
+  ;; Find overlays specifying before-string and after-string in [beg,
+  ;; pos).  If any are found, splice them into TEXT and return the new
+  ;; text.
+  (let (additions)
+    (dolist (overlay (overlays-in beg end))
+      (let ((before (overlay-get overlay 'before-string))
+            (after (overlay-get overlay 'after-string)))
+        (when after
+          (push (cons (- (overlay-end overlay) beg)
+                      after)
+                additions))
+        (when before
+          (push (cons (- (overlay-start overlay) beg)
+                      before)
+                additions))))
+    (if additions
+        (let ((textlist nil)
+              (strpos 0))
+          (dolist (add (cl-stable-sort additions #'< :key #'car))
+            (let ((addpos (car add))
+                  (addtext (cdr add)))
+              (push (substring text strpos addpos) textlist)
+              (push addtext textlist)
+              (setq strpos addpos)))
+          (push (substring text strpos) textlist)
+          (apply #'concat (nreverse textlist)))
+      text)))
+
+(defun htmlize-copy-prop (prop beg end string)
+  ;; Copy the specified property from the specified region of the
+  ;; buffer to the target string.  We cannot rely on Emacs to copy the
+  ;; property because we want to handle properties coming from both
+  ;; text properties and overlays.
+  (let ((pos beg))
+    (while (< pos end)
+      (let ((value (get-char-property pos prop))
+            (next-change (htmlize-next-change pos prop end)))
+        (when value
+          (put-text-property (- pos beg) (- next-change beg)
+                             prop value string))
+        (setq pos next-change)))))
+
+(defun htmlize-get-text-with-display (beg end)
+  ;; Like buffer-substring-no-properties, except it copies the
+  ;; `display' property from the buffer, if found.
+  (let ((text (buffer-substring-no-properties beg end)))
+    (htmlize-copy-prop 'display beg end text)
+    (htmlize-copy-prop 'htmlize-link beg end text)
+    (setq text (htmlize-add-before-after-strings beg end text))
+    text))
+
+(defun htmlize-buffer-substring-no-invisible (beg end)
+  ;; Like buffer-substring-no-properties, but don't copy invisible
+  ;; parts of the region.  Where buffer-substring-no-properties
+  ;; mandates an ellipsis to be shown, htmlize-ellipsis is inserted.
+  (let ((pos beg)
+	visible-list invisible show last-show next-change)
+    ;; Iterate over the changes in the `invisible' property and filter
+    ;; out the portions where it's non-nil, i.e. where the text is
+    ;; invisible.
+    (while (< pos end)
+      (setq invisible (get-char-property pos 'invisible)
+	    next-change (htmlize-next-change pos 'invisible end)
+            show (htmlize-decode-invisibility-spec invisible))
+      (cond ((eq show t)
+	     (push (htmlize-get-text-with-display pos next-change)
+                   visible-list))
+            ((and (eq show 'ellipsis)
+                  (not (eq last-show 'ellipsis))
+                  ;; Conflate successive ellipses.
+                  (push htmlize-ellipsis visible-list))))
+      (setq pos next-change last-show show))
+    (htmlize-concat (nreverse visible-list))))
+
+(defun htmlize-trim-ellipsis (text)
+  ;; Remove htmlize-ellipses ("...") from the beginning of TEXT if it
+  ;; starts with it.  It checks for the special property of the
+  ;; ellipsis so it doesn't work on ordinary text that begins with
+  ;; "...".
+  (if (get-text-property 0 'htmlize-ellipsis text)
+      (substring text (length htmlize-ellipsis))
+    text))
+
+(defconst htmlize-tab-spaces
+  ;; A table of strings with spaces.  (aref htmlize-tab-spaces 5) is
+  ;; like (make-string 5 ?\ ), except it doesn't cons.
+  (let ((v (make-vector 32 nil)))
+    (dotimes (i (length v))
+      (setf (aref v i) (make-string i ?\ )))
+    v))
+
+(defun htmlize-untabify-string (text start-column)
+  "Untabify TEXT, assuming it starts at START-COLUMN."
+  (let ((column start-column)
+	(last-match 0)
+	(chunk-start 0)
+	chunks match-pos tab-size)
+    (while (string-match "[\t\n]" text last-match)
+      (setq match-pos (match-beginning 0))
+      (cond ((eq (aref text match-pos) ?\t)
+	     ;; Encountered a tab: create a chunk of text followed by
+	     ;; the expanded tab.
+	     (push (substring text chunk-start match-pos) chunks)
+	     ;; Increase COLUMN by the length of the text we've
+	     ;; skipped since last tab or newline.  (Encountering
+	     ;; newline resets it.)
+	     (cl-incf column (- match-pos last-match))
+	     ;; Calculate tab size based on tab-width and COLUMN.
+	     (setq tab-size (- tab-width (% column tab-width)))
+	     ;; Expand the tab, carefully recreating the `display'
+	     ;; property if one was on the TAB.
+             (let ((display (get-text-property match-pos 'display text))
+                   (expanded-tab (aref htmlize-tab-spaces tab-size)))
+               (when display
+                 (put-text-property 0 tab-size 'display display expanded-tab))
+               (push expanded-tab chunks))
+	     (cl-incf column tab-size)
+	     (setq chunk-start (1+ match-pos)))
+	    (t
+	     ;; Reset COLUMN at beginning of line.
+	     (setq column 0)))
+      (setq last-match (1+ match-pos)))
+    ;; If no chunks have been allocated, it means there have been no
+    ;; tabs to expand.  Return TEXT unmodified.
+    (if (null chunks)
+	text
+      (when (< chunk-start (length text))
+	;; Push the remaining chunk.
+	(push (substring text chunk-start) chunks))
+      ;; Generate the output from the available chunks.
+      (htmlize-concat (nreverse chunks)))))
+
+(defun htmlize-extract-text (beg end trailing-ellipsis)
+  ;; Extract buffer text, sans the invisible parts.  Then
+  ;; untabify it and escape the HTML metacharacters.
+  (let ((text (htmlize-buffer-substring-no-invisible beg end)))
+    (when trailing-ellipsis
+      (setq text (htmlize-trim-ellipsis text)))
+    ;; If TEXT ends up empty, don't change trailing-ellipsis.
+    (when (> (length text) 0)
+      (setq trailing-ellipsis
+            (get-text-property (1- (length text))
+                               'htmlize-ellipsis text)))
+    (when htmlize-untabify
+      (setq text (htmlize-untabify-string text (current-column))))
+    (setq text (htmlize-string-to-html text))
+    (cl-values text trailing-ellipsis)))
+
+(defun htmlize-despam-address (string)
+  "Replace every occurrence of '@' in STRING with %40.
+This is used to protect mailto links without modifying their meaning."
+  ;; Suggested by Ville Skytta.
+  (while (string-match "@" string)
+    (setq string (replace-match "%40" nil t string)))
+  string)
+
+(defun htmlize-make-tmp-overlay (beg end props)
+  (let ((overlay (make-overlay beg end)))
+    (overlay-put overlay 'htmlize-tmp-overlay t)
+    (while props
+      (overlay-put overlay (pop props) (pop props)))
+    overlay))
+
+(defun htmlize-delete-tmp-overlays ()
+  (dolist (overlay (overlays-in (point-min) (point-max)))
+    (when (overlay-get overlay 'htmlize-tmp-overlay)
+      (delete-overlay overlay))))
+
+(defun htmlize-make-link-overlay (beg end uri)
+  (htmlize-make-tmp-overlay beg end `(htmlize-link (:uri ,uri))))
+
+(defun htmlize-create-auto-links ()
+  "Add `htmlize-link' property to all mailto links in the buffer."
+  (save-excursion
+    (goto-char (point-min))
+    (while (re-search-forward
+            "<\\(\\(mailto:\\)?\\([-=+_.a-zA-Z0-9]+@[-_.a-zA-Z0-9]+\\)\\)>"
+            nil t)
+      (let* ((address (match-string 3))
+             (beg (match-beginning 0)) (end (match-end 0))
+             (uri (concat "mailto:" (htmlize-despam-address address))))
+        (htmlize-make-link-overlay beg end uri)))
+    (goto-char (point-min))
+    (while (re-search-forward "<\\(\\(URL:\\)?\\([a-zA-Z]+://[^;]+\\)\\)>"
+                              nil t)
+      (htmlize-make-link-overlay
+       (match-beginning 0) (match-end 0) (match-string 3)))))
+
+;; Tests for htmlize-create-auto-links:
+
+;; 
+;; 
+;; 
+;; 
+;; 
+;; 
+
+(defun htmlize-shadow-form-feeds ()
+  (let ((s "\n
"))
+    (put-text-property 0 (length s) 'htmlize-literal t s)
+    (let ((disp `(display ,s)))
+      (while (re-search-forward "\n\^L" nil t)
+        (let* ((beg (match-beginning 0))
+               (end (match-end 0))
+               (form-feed-pos (1+ beg))
+               ;; don't process ^L if invisible or covered by `display'
+               (show (and (htmlize-decode-invisibility-spec
+                           (get-char-property form-feed-pos 'invisible))
+                          (not (get-char-property form-feed-pos 'display)))))
+          (when show
+            (htmlize-make-tmp-overlay beg end disp)))))))
+
+(defun htmlize-defang-local-variables ()
+  ;; Juri Linkov reports that an HTML-ized "Local variables" can lead
+  ;; visiting the HTML to fail with "Local variables list is not
+  ;; properly terminated".  He suggested changing the phrase to
+  ;; syntactically equivalent HTML that Emacs doesn't recognize.
+  (goto-char (point-min))
+  (while (search-forward "Local Variables:" nil t)
+    (replace-match "Local Variables:" nil t)))
+  
+
+;;; Color handling.
+
+(defvar htmlize-x-library-search-path
+  `(,data-directory
+    "/etc/X11/rgb.txt"
+    "/usr/share/X11/rgb.txt"
+    ;; the remainder of this list really belongs in a museum
+    "/usr/X11R6/lib/X11/"
+    "/usr/X11R5/lib/X11/"
+    "/usr/lib/X11R6/X11/"
+    "/usr/lib/X11R5/X11/"
+    "/usr/local/X11R6/lib/X11/"
+    "/usr/local/X11R5/lib/X11/"
+    "/usr/local/lib/X11R6/X11/"
+    "/usr/local/lib/X11R5/X11/"
+    "/usr/X11/lib/X11/"
+    "/usr/lib/X11/"
+    "/usr/local/lib/X11/"
+    "/usr/X386/lib/X11/"
+    "/usr/x386/lib/X11/"
+    "/usr/XFree86/lib/X11/"
+    "/usr/unsupported/lib/X11/"
+    "/usr/athena/lib/X11/"
+    "/usr/local/x11r5/lib/X11/"
+    "/usr/lpp/Xamples/lib/X11/"
+    "/usr/openwin/lib/X11/"
+    "/usr/openwin/share/lib/X11/"))
+
+(defun htmlize-get-color-rgb-hash (&optional rgb-file)
+  "Return a hash table mapping X color names to RGB values.
+The keys in the hash table are X11 color names, and the values are the
+#rrggbb RGB specifications, extracted from `rgb.txt'.
+
+If RGB-FILE is nil, the function will try hard to find a suitable file
+in the system directories.
+
+If no rgb.txt file is found, return nil."
+  (let ((rgb-file (or rgb-file (locate-file
+				"rgb.txt"
+				htmlize-x-library-search-path)))
+	(hash nil))
+    (when rgb-file
+      (with-temp-buffer
+	(insert-file-contents rgb-file)
+	(setq hash (make-hash-table :test 'equal))
+	(while (not (eobp))
+	  (cond ((looking-at "^\\s-*\\([!#]\\|$\\)")
+		 ;; Skip comments and empty lines.
+		 )
+		((looking-at
+		  "[ \t]*\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\(.*\\)")
+		 (setf (gethash (downcase (match-string 4)) hash)
+		       (format "#%02x%02x%02x"
+			       (string-to-number (match-string 1))
+			       (string-to-number (match-string 2))
+			       (string-to-number (match-string 3)))))
+		(t
+		 (error
+		  "Unrecognized line in %s: %s"
+		  rgb-file
+		  (buffer-substring (point) (progn (end-of-line) (point))))))
+	  (forward-line 1))))
+    hash))
+
+;; Compile the RGB map when loaded.  On systems where rgb.txt is
+;; missing, the value of the variable will be nil, and rgb.txt will
+;; not be used.
+(defvar htmlize-color-rgb-hash (htmlize-get-color-rgb-hash))
+
+;;; Face handling.
+
+(defun htmlize-face-color-internal (face fg)
+  ;; Used only under GNU Emacs.  Return the color of FACE, but don't
+  ;; return "unspecified-fg" or "unspecified-bg".  If the face is
+  ;; `default' and the color is unspecified, look up the color in
+  ;; frame parameters.
+  (let* ((function (if fg #'face-foreground #'face-background))
+	 (color (funcall function face nil t)))
+    (when (and (eq face 'default) (null color))
+      (setq color (cdr (assq (if fg 'foreground-color 'background-color)
+			     (frame-parameters)))))
+    (when (or (eq color 'unspecified)
+	      (equal color "unspecified-fg")
+	      (equal color "unspecified-bg"))
+      (setq color nil))
+    (when (and (eq face 'default)
+	       (null color))
+      ;; Assuming black on white doesn't seem right, but I can't think
+      ;; of anything better to do.
+      (setq color (if fg "black" "white")))
+    color))
+
+(defun htmlize-face-foreground (face)
+  ;; Return the name of the foreground color of FACE.  If FACE does
+  ;; not specify a foreground color, return nil.
+  (htmlize-face-color-internal face t))
+
+(defun htmlize-face-background (face)
+  ;; Return the name of the background color of FACE.  If FACE does
+  ;; not specify a background color, return nil.
+  ;; GNU Emacs.
+  (htmlize-face-color-internal face nil))
+
+;; Convert COLOR to the #RRGGBB string.  If COLOR is already in that
+;; format, it's left unchanged.
+
+(defun htmlize-color-to-rgb (color)
+  (let ((rgb-string nil))
+    (cond ((null color)
+	   ;; Ignore nil COLOR because it means that the face is not
+	   ;; specifying any color.  Hence (htmlize-color-to-rgb nil)
+	   ;; returns nil.
+	   )
+	  ((string-match "\\`#" color)
+	   ;; The color is already in #rrggbb format.
+	   (setq rgb-string color))
+	  ((and htmlize-use-rgb-txt
+		htmlize-color-rgb-hash)
+	   ;; Use of rgb.txt is requested, and it's available on the
+	   ;; system.  Use it.
+	   (setq rgb-string (gethash (downcase color) htmlize-color-rgb-hash)))
+	  (t
+	   ;; We're getting the RGB components from Emacs.
+	   (let ((rgb (mapcar (lambda (arg)
+                                (/ arg 256))
+                              (color-values color))))
+	     (when rgb
+	       (setq rgb-string (apply #'format "#%02x%02x%02x" rgb))))))
+    ;; If RGB-STRING is still nil, it means the color cannot be found,
+    ;; for whatever reason.  In that case just punt and return COLOR.
+    ;; Most browsers support a decent set of color names anyway.
+    (or rgb-string color)))
+
+;; We store the face properties we care about into an
+;; `htmlize-fstruct' type.  That way we only have to analyze face
+;; properties, which can be time consuming, once per each face.  The
+;; mapping between Emacs faces and htmlize-fstructs is established by
+;; htmlize-make-face-map.  The name "fstruct" refers to variables of
+;; type `htmlize-fstruct', while the term "face" is reserved for Emacs
+;; faces.
+
+(cl-defstruct htmlize-fstruct
+  foreground				; foreground color, #rrggbb
+  background				; background color, #rrggbb
+  size					; size
+  boldp					; whether face is bold
+  italicp				; whether face is italic
+  underlinep				; whether face is underlined
+  overlinep				; whether face is overlined
+  strikep				; whether face is struck through
+  css-name				; CSS name of face
+  )
+
+(defun htmlize-face-set-from-keyword-attr (fstruct attr value)
+  ;; For ATTR and VALUE, set the equivalent value in FSTRUCT.
+  (cl-case attr
+    (:foreground
+     (setf (htmlize-fstruct-foreground fstruct) (htmlize-color-to-rgb value)))
+    (:background
+     (setf (htmlize-fstruct-background fstruct) (htmlize-color-to-rgb value)))
+    (:height
+     (setf (htmlize-fstruct-size fstruct) value))
+    (:weight
+     (when (string-match (symbol-name value) "bold")
+       (setf (htmlize-fstruct-boldp fstruct) t)))
+    (:slant
+     (setf (htmlize-fstruct-italicp fstruct) (or (eq value 'italic)
+						 (eq value 'oblique))))
+    (:bold
+     (setf (htmlize-fstruct-boldp fstruct) value))
+    (:italic
+     (setf (htmlize-fstruct-italicp fstruct) value))
+    (:underline
+     (setf (htmlize-fstruct-underlinep fstruct) value))
+    (:overline
+     (setf (htmlize-fstruct-overlinep fstruct) value))
+    (:strike-through
+     (setf (htmlize-fstruct-strikep fstruct) value))))
+
+(defun htmlize-face-size (face)
+  ;; The size (height) of FACE, taking inheritance into account.
+  ;; Only works in Emacs 21 and later.
+  (let* ((face-list (list face))
+         (head face-list)
+         (tail face-list))
+    (while head
+      (let ((inherit (face-attribute (car head) :inherit)))
+        (cond ((listp inherit)
+               (setcdr tail (cl-copy-list inherit))
+               (setq tail (last tail)))
+              ((eq inherit 'unspecified))
+              (t
+               (setcdr tail (list inherit))
+               (setq tail (cdr tail)))))
+      (pop head))
+    (let ((size-list
+           (cl-loop
+            for f in face-list
+            for h = (face-attribute f :height)
+            collect (if (eq h 'unspecified) nil h))))
+      (cl-reduce 'htmlize-merge-size (cons nil size-list)))))
+
+(defun htmlize-face-css-name (face)
+  ;; Generate the css-name property for the given face.  Emacs places
+  ;; no restrictions on the names of symbols that represent faces --
+  ;; any characters may be in the name, even control chars.  We try
+  ;; hard to beat the face name into shape, both esthetically and
+  ;; according to CSS1 specs.
+  (let ((name (downcase (symbol-name face))))
+    (when (string-match "\\`font-lock-" name)
+      ;; font-lock-FOO-face -> FOO.
+      (setq name (replace-match "" t t name)))
+    (when (string-match "-face\\'" name)
+      ;; Drop the redundant "-face" suffix.
+      (setq name (replace-match "" t t name)))
+    (while (string-match "[^-a-zA-Z0-9]" name)
+      ;; Drop the non-alphanumerics.
+      (setq name (replace-match "X" t t name)))
+    (when (string-match "\\`[-0-9]" name)
+      ;; CSS identifiers may not start with a digit.
+      (setq name (concat "X" name)))
+    ;; After these transformations, the face could come out empty.
+    (when (equal name "")
+      (setq name "face"))
+    ;; Apply the prefix.
+    (concat htmlize-css-name-prefix name)))
+
+(defun htmlize-face-to-fstruct-1 (face)
+  "Convert Emacs face FACE to fstruct, internal."
+  (let ((fstruct (make-htmlize-fstruct
+		  :foreground (htmlize-color-to-rgb
+			       (htmlize-face-foreground face))
+		  :background (htmlize-color-to-rgb
+			       (htmlize-face-background face)))))
+    ;; GNU Emacs
+    (dolist (attr '(:weight :slant :underline :overline :strike-through))
+      (let ((value (face-attribute face attr nil t)))
+        (when (and value (not (eq value 'unspecified)))
+          (htmlize-face-set-from-keyword-attr fstruct attr value))))
+    (let ((size (htmlize-face-size face)))
+      (unless (eql size 1.0)            ; ignore non-spec
+        (setf (htmlize-fstruct-size fstruct) size)))
+    (setf (htmlize-fstruct-css-name fstruct) (htmlize-face-css-name face))
+    fstruct))
+
+(defun htmlize-face-to-fstruct (face)
+  (let* ((face-list (or (and (symbolp face)
+                             (cdr (assq face face-remapping-alist)))
+                        (list face)))
+         (fstruct (htmlize-merge-faces
+                   (mapcar (lambda (face)
+                             (if (symbolp face)
+                                 (or (htmlize-get-override-fstruct face)
+                                     (htmlize-face-to-fstruct-1 face))
+                               (htmlize-attrlist-to-fstruct face)))
+                           (nreverse face-list)))))
+    (when (symbolp face)
+      (setf (htmlize-fstruct-css-name fstruct) (htmlize-face-css-name face)))
+    fstruct))
+
+(defmacro htmlize-copy-attr-if-set (attr-list dest source)
+  ;; Generate code with the following pattern:
+  ;; (progn
+  ;;   (when (htmlize-fstruct-ATTR source)
+  ;;     (setf (htmlize-fstruct-ATTR dest) (htmlize-fstruct-ATTR source)))
+  ;;   ...)
+  ;; for the given list of boolean attributes.
+  (cons 'progn
+	(cl-loop for attr in attr-list
+	         for attr-sym = (intern (format "htmlize-fstruct-%s" attr))
+	         collect `(when (,attr-sym ,source)
+                            (setf (,attr-sym ,dest) (,attr-sym ,source))))))
+
+(defun htmlize-merge-size (merged next)
+  ;; Calculate the size of the merge of MERGED and NEXT.
+  (cond ((null merged)     next)
+	((integerp next)   next)
+	((null next)       merged)
+	((floatp merged)   (* merged next))
+	((integerp merged) (round (* merged next)))))
+
+(defun htmlize-merge-two-faces (merged next)
+  (htmlize-copy-attr-if-set
+   (foreground background boldp italicp underlinep overlinep strikep)
+   merged next)
+  (setf (htmlize-fstruct-size merged)
+	(htmlize-merge-size (htmlize-fstruct-size merged)
+			    (htmlize-fstruct-size next)))
+  merged)
+
+(defun htmlize-merge-faces (fstruct-list)
+  (cond ((null fstruct-list)
+	 ;; Nothing to do, return a dummy face.
+	 (make-htmlize-fstruct))
+	((null (cdr fstruct-list))
+	 ;; Optimize for the common case of a single face, simply
+	 ;; return it.
+	 (car fstruct-list))
+	(t
+	 (cl-reduce #'htmlize-merge-two-faces
+		    (cons (make-htmlize-fstruct) fstruct-list)))))
+
+;; GNU Emacs 20+ supports attribute lists in `face' properties.  For
+;; example, you can use `(:foreground "red" :weight bold)' as an
+;; overlay's "face", or you can even use a list of such lists, etc.
+;; We call those "attrlists".
+;;
+;; htmlize supports attrlist by converting them to fstructs, the same
+;; as with regular faces.
+
+(defun htmlize-attrlist-to-fstruct (attrlist &optional name)
+  ;; Like htmlize-face-to-fstruct, but accepts an ATTRLIST as input.
+  (let ((fstruct (make-htmlize-fstruct)))
+    (cond ((eq (car attrlist) 'foreground-color)
+	   ;; ATTRLIST is (foreground-color . COLOR)
+	   (setf (htmlize-fstruct-foreground fstruct)
+		 (htmlize-color-to-rgb (cdr attrlist))))
+	  ((eq (car attrlist) 'background-color)
+	   ;; ATTRLIST is (background-color . COLOR)
+	   (setf (htmlize-fstruct-background fstruct)
+		 (htmlize-color-to-rgb (cdr attrlist))))
+	  (t
+	   ;; ATTRLIST is a plist.
+	   (while attrlist
+	     (let ((attr (pop attrlist))
+		   (value (pop attrlist)))
+	       (when (and value (not (eq value 'unspecified)))
+		 (htmlize-face-set-from-keyword-attr fstruct attr value))))))
+    (setf (htmlize-fstruct-css-name fstruct) (or name "custom"))
+    fstruct))
+
+(defun htmlize-decode-face-prop (prop)
+  "Turn face property PROP into a list of face-like objects."
+  ;; PROP can be a symbol naming a face, a string naming such a
+  ;; symbol, a cons (foreground-color . COLOR) or (background-color
+  ;; COLOR), a property list (:attr1 val1 :attr2 val2 ...), or a list
+  ;; of any of those.
+  ;;
+  ;; (htmlize-decode-face-prop 'face) -> (face)
+  ;; (htmlize-decode-face-prop '(face1 face2)) -> (face1 face2)
+  ;; (htmlize-decode-face-prop '(:attr "val")) -> ((:attr "val"))
+  ;; (htmlize-decode-face-prop '((:attr "val") face (foreground-color "red")))
+  ;;   -> ((:attr "val") face (foreground-color "red"))
+  ;;
+  ;; Unrecognized atoms or non-face symbols/strings are silently
+  ;; stripped away.
+  (cond ((null prop)
+         nil)
+        ((symbolp prop)
+         (and (facep prop)
+              (list prop)))
+        ((stringp prop)
+         (and (facep (intern-soft prop))
+              (list prop)))
+        ((atom prop)
+         nil)
+        ((and (symbolp (car prop))
+              (eq ?: (aref (symbol-name (car prop)) 0)))
+         (list prop))
+        ((or (eq (car prop) 'foreground-color)
+             (eq (car prop) 'background-color))
+         (list prop))
+        (t
+         (apply #'nconc (mapcar #'htmlize-decode-face-prop prop)))))
+
+(defun htmlize-get-override-fstruct (face)
+  (let* ((raw-def (plist-get htmlize-face-overrides face))
+         (def (cond ((stringp raw-def) (list :foreground raw-def))
+                    ((listp raw-def) raw-def)
+                    (t
+                     (error (format (concat "face override must be an "
+                                            "attribute list or string, got %s")
+                                    raw-def))))))
+    (and def
+         (htmlize-attrlist-to-fstruct def (symbol-name face)))))
+
+(defun htmlize-make-face-map (faces)
+  ;; Return a hash table mapping Emacs faces to htmlize's fstructs.
+  ;; The keys are either face symbols or attrlists, so the test
+  ;; function must be `equal'.
+  (let ((face-map (make-hash-table :test 'equal))
+	css-names)
+    (dolist (face faces)
+      (unless (gethash face face-map)
+	;; Haven't seen FACE yet; convert it to an fstruct and cache
+	;; it.
+	(let ((fstruct (htmlize-face-to-fstruct face)))
+	  (setf (gethash face face-map) fstruct)
+	  (let* ((css-name (htmlize-fstruct-css-name fstruct))
+		 (new-name css-name)
+		 (i 0))
+	    ;; Uniquify the face's css-name by using NAME-1, NAME-2,
+	    ;; etc.
+	    (while (member new-name css-names)
+	      (setq new-name (format "%s-%s" css-name (cl-incf i))))
+	    (unless (equal new-name css-name)
+	      (setf (htmlize-fstruct-css-name fstruct) new-name))
+	    (push new-name css-names)))))
+    face-map))
+
+(defun htmlize-unstringify-face (face)
+  "If FACE is a string, return it interned, otherwise return it unchanged."
+  (if (stringp face)
+      (intern face)
+    face))
+
+(defun htmlize-faces-in-buffer ()
+  "Return a list of faces used in the current buffer.
+This is the set of faces specified by the `face' text property and by buffer
+overlays that specify `face'."
+  (let (faces)
+    ;; Faces used by text properties.
+    (let ((pos (point-min)) face-prop next)
+      (while (< pos (point-max))
+        (setq face-prop (get-text-property pos 'face)
+              next (or (next-single-property-change pos 'face) (point-max)))
+        (setq faces (cl-nunion (htmlize-decode-face-prop face-prop)
+                               faces :test 'equal))
+        (setq pos next)))
+    ;; Faces used by overlays.
+    (dolist (overlay (overlays-in (point-min) (point-max)))
+      (let ((face-prop (overlay-get overlay 'face)))
+        (setq faces (cl-nunion (htmlize-decode-face-prop face-prop)
+                               faces :test 'equal))))
+    faces))
+
+(if (>= emacs-major-version 25)
+    (defun htmlize-sorted-overlays-at (pos)
+      (overlays-at pos t))
+
+  (defun htmlize-sorted-overlays-at (pos)
+    ;; Like OVERLAYS-AT with the SORTED argument, for older Emacsen.
+    (let ((overlays (overlays-at pos)))
+      (setq overlays (cl-sort overlays #'<
+                              :key (lambda (o)
+                                     (- (overlay-end o) (overlay-start o)))))
+      (setq overlays
+            (cl-stable-sort overlays #'<
+                            :key (lambda (o)
+                                   (let ((prio (overlay-get o 'priority)))
+                                     (if (numberp prio) prio 0)))))
+      (nreverse overlays))))
+
+
+;; htmlize-faces-at-point returns the faces in use at point.  The
+;; faces are sorted by increasing priority, i.e. the last face takes
+;; precedence.
+;;
+;; This returns all the faces in the `face' property and all the faces
+;; in the overlays at point.
+
+(defun htmlize-faces-at-point ()
+  (let (all-faces)
+    ;; Faces from text properties.
+    (let ((face-prop (get-text-property (point) 'face)))
+      ;; we need to reverse the `face' prop because we want
+      ;; more specific faces to come later
+      (setq all-faces (nreverse (htmlize-decode-face-prop face-prop))))
+    ;; Faces from overlays.
+    (let ((overlays
+           ;; Collect overlays at point that specify `face'.
+           (cl-delete-if-not (lambda (o)
+                               (overlay-get o 'face))
+                             (nreverse (htmlize-sorted-overlays-at (point)))))
+          list face-prop)
+      (dolist (overlay overlays)
+        (setq face-prop (overlay-get overlay 'face)
+              list (nconc (htmlize-decode-face-prop face-prop) list)))
+      ;; Under "Merging Faces" the manual explicitly states
+      ;; that faces specified by overlays take precedence over
+      ;; faces specified by text properties.
+      (setq all-faces (nconc all-faces list)))
+    all-faces))
+
+;; htmlize supports generating HTML in several flavors, some of which
+;; use CSS, and others the  element.  We take an OO approach and
+;; define "methods" that indirect to the functions that depend on
+;; `htmlize-output-type'.  The currently used methods are `doctype',
+;; `insert-head', `body-tag', `pre-tag', and `text-markup'.  Not all
+;; output types define all methods.
+;;
+;; Methods are called either with (htmlize-method METHOD ARGS...) 
+;; special form, or by accessing the function with
+;; (htmlize-method-function 'METHOD) and calling (funcall FUNCTION).
+;; The latter form is useful in tight loops because `htmlize-method'
+;; conses.
+
+(defmacro htmlize-method (method &rest args)
+  ;; Expand to (htmlize-TYPE-METHOD ...ARGS...).  TYPE is the value of
+  ;; `htmlize-output-type' at run time.
+  `(funcall (htmlize-method-function ',method) ,@args))
+
+(defun htmlize-method-function (method)
+  ;; Return METHOD's function definition for the current output type.
+  ;; The returned object can be safely funcalled.
+  (let ((sym (intern (format "htmlize-%s-%s" htmlize-output-type method))))
+    (indirect-function (if (fboundp sym)
+			   sym
+			 (let ((default (intern (concat "htmlize-default-"
+							(symbol-name method)))))
+			   (if (fboundp default)
+			       default
+			     'ignore))))))
+
+(defvar htmlize-memoization-table (make-hash-table :test 'equal))
+
+(defmacro htmlize-memoize (key generator)
+  "Return the value of GENERATOR, memoized as KEY.
+That means that GENERATOR will be evaluated and returned the first time
+it's called with the same value of KEY.  All other times, the cached
+\(memoized) value will be returned."
+  (let ((value (cl-gensym)))
+    `(let ((,value (gethash ,key htmlize-memoization-table)))
+       (unless ,value
+	 (setq ,value ,generator)
+	 (setf (gethash ,key htmlize-memoization-table) ,value))
+       ,value)))
+
+;;; Default methods.
+
+(defun htmlize-default-doctype ()
+  nil					; no doc-string
+  ;; Note that the `font' output is technically invalid under this DTD
+  ;; because the DTD doesn't allow embedding  in 
.
+  ""
+  )
+
+(defun htmlize-default-body-tag (face-map)
+  nil					; no doc-string
+  face-map ; shut up the byte-compiler
+  "")
+
+(defun htmlize-default-pre-tag (face-map)
+  nil					; no doc-string
+  face-map ; shut up the byte-compiler
+  "
")
+
+
+;;; CSS based output support.
+
+;; Internal function; not a method.
+(defun htmlize-css-specs (fstruct)
+  (let (result)
+    (when (htmlize-fstruct-foreground fstruct)
+      (push (format "color: %s;" (htmlize-fstruct-foreground fstruct))
+	    result))
+    (when (htmlize-fstruct-background fstruct)
+      (push (format "background-color: %s;"
+		    (htmlize-fstruct-background fstruct))
+	    result))
+    (let ((size (htmlize-fstruct-size fstruct)))
+      (when (and size (not (eq htmlize-ignore-face-size t)))
+	(cond ((floatp size)
+	       (push (format "font-size: %d%%;" (* 100 size)) result))
+	      ((not (eq htmlize-ignore-face-size 'absolute))
+	       (push (format "font-size: %spt;" (/ size 10.0)) result)))))
+    (when (htmlize-fstruct-boldp fstruct)
+      (push "font-weight: bold;" result))
+    (when (htmlize-fstruct-italicp fstruct)
+      (push "font-style: italic;" result))
+    (when (htmlize-fstruct-underlinep fstruct)
+      (push "text-decoration: underline;" result))
+    (when (htmlize-fstruct-overlinep fstruct)
+      (push "text-decoration: overline;" result))
+    (when (htmlize-fstruct-strikep fstruct)
+      (push "text-decoration: line-through;" result))
+    (nreverse result)))
+
+(defun htmlize-css-insert-head (buffer-faces face-map)
+  (insert "    \n"))
+
+(defun htmlize-css-text-markup (fstruct-list buffer)
+  ;; Open the markup needed to insert text colored with FACES into
+  ;; BUFFER.  Return the function that closes the markup.
+
+  ;; In CSS mode, this is easy: just nest the text in one  tag for each face in FSTRUCT-LIST.
+  (dolist (fstruct fstruct-list)
+    (princ "" buffer))
+  (htmlize-lexlet ((fstruct-list fstruct-list) (buffer buffer))
+    (lambda ()
+      (dolist (fstruct fstruct-list)
+        (ignore fstruct)                ; shut up the byte-compiler
+        (princ "" buffer)))))
+
+;; `inline-css' output support.
+
+(defun htmlize-inline-css-body-tag (face-map)
+  (format ""
+	  (mapconcat #'identity (htmlize-css-specs (gethash 'default face-map))
+		     " ")))
+
+(defun htmlize-inline-css-pre-tag (face-map)
+  (if htmlize-pre-style
+      (format "
"
+              (mapconcat #'identity (htmlize-css-specs (gethash 'default face-map))
+                         " "))
+    (format "
")))
+
+(defun htmlize-inline-css-text-markup (fstruct-list buffer)
+  (let* ((merged (htmlize-merge-faces fstruct-list))
+	 (style (htmlize-memoize
+		 merged
+		 (let ((specs (htmlize-css-specs merged)))
+		   (and specs
+			(mapconcat #'identity (htmlize-css-specs merged) " "))))))
+    (when style
+      (princ "" buffer))
+    (htmlize-lexlet ((style style) (buffer buffer))
+      (lambda ()
+        (when style
+          (princ "" buffer))))))
+
+;;; `font' tag based output support.
+
+(defun htmlize-font-body-tag (face-map)
+  (let ((fstruct (gethash 'default face-map)))
+    (format ""
+	    (htmlize-fstruct-foreground fstruct)
+	    (htmlize-fstruct-background fstruct))))
+
+(defun htmlize-font-pre-tag (face-map)
+  (if htmlize-pre-style
+      (let ((fstruct (gethash 'default face-map)))
+        (format "
"
+                (htmlize-fstruct-foreground fstruct)
+                (htmlize-fstruct-background fstruct)))
+    (format "
")))
+       
+(defun htmlize-font-text-markup (fstruct-list buffer)
+  ;; In `font' mode, we use the traditional HTML means of altering
+  ;; presentation:  tag for colors,  for bold,  for
+  ;; underline, and  for strike-through.
+  (let* ((merged (htmlize-merge-faces fstruct-list))
+	 (markup (htmlize-memoize
+		  merged
+		  (cons (concat
+			 (and (htmlize-fstruct-foreground merged)
+			      (format "" (htmlize-fstruct-foreground merged)))
+			 (and (htmlize-fstruct-boldp merged)      "")
+			 (and (htmlize-fstruct-italicp merged)    "")
+			 (and (htmlize-fstruct-underlinep merged) "")
+			 (and (htmlize-fstruct-strikep merged)    ""))
+			(concat
+			 (and (htmlize-fstruct-strikep merged)    "")
+			 (and (htmlize-fstruct-underlinep merged) "")
+			 (and (htmlize-fstruct-italicp merged)    "")
+			 (and (htmlize-fstruct-boldp merged)      "")
+			 (and (htmlize-fstruct-foreground merged) ""))))))
+    (princ (car markup) buffer)
+    (htmlize-lexlet ((markup markup) (buffer buffer))
+      (lambda ()
+        (princ (cdr markup) buffer)))))
+
+(defun htmlize-buffer-1 ()
+  ;; Internal function; don't call it from outside this file.  Htmlize
+  ;; current buffer, writing the resulting HTML to a new buffer, and
+  ;; return it.  Unlike htmlize-buffer, this doesn't change current
+  ;; buffer or use switch-to-buffer.
+  (save-excursion
+    ;; Protect against the hook changing the current buffer.
+    (save-excursion
+      (run-hooks 'htmlize-before-hook))
+    ;; Convince font-lock support modes to fontify the entire buffer
+    ;; in advance.
+    (htmlize-ensure-fontified)
+    (clrhash htmlize-extended-character-cache)
+    (clrhash htmlize-memoization-table)
+    ;; It's important that the new buffer inherits default-directory
+    ;; from the current buffer.
+    (let ((htmlbuf (generate-new-buffer (if (buffer-file-name)
+                                            (htmlize-make-file-name
+                                             (file-name-nondirectory
+                                              (buffer-file-name)))
+                                          "*html*")))
+          (completed nil))
+      (unwind-protect
+          (let* ((buffer-faces (htmlize-faces-in-buffer))
+                 (face-map (htmlize-make-face-map (cl-adjoin 'default buffer-faces)))
+                 (places (cl-gensym))
+                 (title (if (buffer-file-name)
+                            (file-name-nondirectory (buffer-file-name))
+                          (buffer-name))))
+            (when htmlize-generate-hyperlinks
+              (htmlize-create-auto-links))
+            (when htmlize-replace-form-feeds
+              (htmlize-shadow-form-feeds))
+
+            ;; Initialize HTMLBUF and insert the HTML prolog.
+            (with-current-buffer htmlbuf
+              (buffer-disable-undo)
+              (insert (htmlize-method doctype) ?\n
+                      (format "\n"
+                              htmlize-version htmlize-output-type)
+                      "\n  ")
+              (put places 'head-start (point-marker))
+              (insert "\n"
+                      "    " (htmlize-protect-string title) "\n"
+                      (if htmlize-html-charset
+                          (format (concat "    \n")
+                                  htmlize-html-charset)
+                        "")
+                      htmlize-head-tags)
+              (htmlize-method insert-head buffer-faces face-map)
+              (insert "  ")
+              (put places 'head-end (point-marker))
+              (insert "\n  ")
+              (put places 'body-start (point-marker))
+              (insert (htmlize-method body-tag face-map)
+                      "\n    ")
+              (put places 'content-start (point-marker))
+              (insert (htmlize-method pre-tag face-map) "\n"))
+            (let ((text-markup
+                   ;; Get the inserter method, so we can funcall it inside
+                   ;; the loop.  Not calling `htmlize-method' in the loop
+                   ;; body yields a measurable speed increase.
+                   (htmlize-method-function 'text-markup))
+                  ;; Declare variables used in loop body outside the loop
+                  ;; because it's faster to establish `let' bindings only
+                  ;; once.
+                  next-change text face-list trailing-ellipsis
+                  fstruct-list last-fstruct-list
+                  (close-markup (lambda ())))
+              ;; This loop traverses and reads the source buffer, appending
+              ;; the resulting HTML to HTMLBUF.  This method is fast
+              ;; because: 1) it doesn't require examining the text
+              ;; properties char by char (htmlize-next-face-change is used
+              ;; to move between runs with the same face), and 2) it doesn't
+              ;; require frequent buffer switches, which are slow because
+              ;; they rebind all buffer-local vars.
+              (goto-char (point-min))
+              (while (not (eobp))
+                (setq next-change (htmlize-next-face-change (point)))
+                ;; Get faces in use between (point) and NEXT-CHANGE, and
+                ;; convert them to fstructs.
+                (setq face-list (htmlize-faces-at-point)
+                      fstruct-list (delq nil (mapcar (lambda (f)
+                                                       (gethash f face-map))
+                                                     face-list)))
+                (cl-multiple-value-setq (text trailing-ellipsis)
+                  (htmlize-extract-text (point) next-change trailing-ellipsis))
+                ;; Don't bother writing anything if there's no text (this
+                ;; happens in invisible regions).
+                (when (> (length text) 0)
+                  ;; Open the new markup if necessary and insert the text.
+                  (when (not (cl-equalp fstruct-list last-fstruct-list))
+                    (funcall close-markup)
+                    (setq last-fstruct-list fstruct-list
+                          close-markup (funcall text-markup fstruct-list htmlbuf)))
+                  (princ text htmlbuf))
+                (goto-char next-change))
+
+              ;; We've gone through the buffer; close the markup from
+              ;; the last run, if any.
+              (funcall close-markup))
+
+            ;; Insert the epilog and post-process the buffer.
+            (with-current-buffer htmlbuf
+              (insert "
")
+              (put places 'content-end (point-marker))
+              (insert "\n  ")
+              (put places 'body-end (point-marker))
+              (insert "\n\n")
+              (htmlize-defang-local-variables)
+              (goto-char (point-min))
+              (when htmlize-html-major-mode
+                ;; What sucks about this is that the minor modes, most notably
+                ;; font-lock-mode, won't be initialized.  Oh well.
+                (funcall htmlize-html-major-mode))
+              (set (make-local-variable 'htmlize-buffer-places)
+                   (symbol-plist places))
+              (run-hooks 'htmlize-after-hook)
+              (buffer-enable-undo))
+            (setq completed t)
+            htmlbuf)
+
+        (when (not completed)
+          (kill-buffer htmlbuf))
+        (htmlize-delete-tmp-overlays)))))
+
+;; Utility functions.
+
+(defmacro htmlize-with-fontify-message (&rest body)
+  ;; When forcing fontification of large buffers in
+  ;; htmlize-ensure-fontified, inform the user that he is waiting for
+  ;; font-lock, not for htmlize to finish.
+  `(progn
+     (if (> (buffer-size) 65536)
+	 (message "Forcing fontification of %s..."
+		  (buffer-name (current-buffer))))
+     ,@body
+     (if (> (buffer-size) 65536)
+	 (message "Forcing fontification of %s...done"
+		  (buffer-name (current-buffer))))))
+
+(defun htmlize-ensure-fontified ()
+  ;; If font-lock is being used, ensure that the "support" modes
+  ;; actually fontify the buffer.  If font-lock is not in use, we
+  ;; don't care because, except in htmlize-file, we don't force
+  ;; font-lock on the user.
+  (when font-lock-mode
+    ;; In part taken from ps-print-ensure-fontified in GNU Emacs 21.
+    (when (and (boundp 'jit-lock-mode)
+               (symbol-value 'jit-lock-mode))
+      (htmlize-with-fontify-message
+       (jit-lock-fontify-now (point-min) (point-max))))
+
+    (if (fboundp 'font-lock-ensure)
+        (font-lock-ensure)
+      ;; Emacs prior to 25.1
+      (with-no-warnings
+        (font-lock-mode 1)
+        (font-lock-fontify-buffer)))))
+
+
+;;;###autoload
+(defun htmlize-buffer (&optional buffer)
+  "Convert BUFFER to HTML, preserving colors and decorations.
+
+The generated HTML is available in a new buffer, which is returned.
+When invoked interactively, the new buffer is selected in the current
+window.  The title of the generated document will be set to the buffer's
+file name or, if that's not available, to the buffer's name.
+
+Note that htmlize doesn't fontify your buffers, it only uses the
+decorations that are already present.  If you don't set up font-lock or
+something else to fontify your buffers, the resulting HTML will be
+plain.  Likewise, if you don't like the choice of colors, fix the mode
+that created them, or simply alter the faces it uses."
+  (interactive)
+  (let ((htmlbuf (with-current-buffer (or buffer (current-buffer))
+		   (htmlize-buffer-1))))
+    (when (interactive-p)
+      (switch-to-buffer htmlbuf))
+    htmlbuf))
+
+;;;###autoload
+(defun htmlize-region (beg end)
+  "Convert the region to HTML, preserving colors and decorations.
+See `htmlize-buffer' for details."
+  (interactive "r")
+  ;; Don't let zmacs region highlighting end up in HTML.
+  (when (fboundp 'zmacs-deactivate-region)
+    (zmacs-deactivate-region))
+  (let ((htmlbuf (save-restriction
+		   (narrow-to-region beg end)
+		   (htmlize-buffer-1))))
+    (when (interactive-p)
+      (switch-to-buffer htmlbuf))
+    htmlbuf))
+
+(defun htmlize-region-for-paste (beg end)
+  "Htmlize the region and return just the HTML as a string.
+This forces the `inline-css' style and only returns the HTML body,
+but without the BODY tag.  This should make it useful for inserting
+the text to another HTML buffer."
+  (let* ((htmlize-output-type 'inline-css)
+	 (htmlbuf (htmlize-region beg end)))
+    (unwind-protect
+	(with-current-buffer htmlbuf
+	  (buffer-substring (plist-get htmlize-buffer-places 'content-start)
+			    (plist-get htmlize-buffer-places 'content-end)))
+      (kill-buffer htmlbuf))))
+
+(defun htmlize-region-save-screenshot (beg end)
+  "Save the htmlized (see `htmlize-region-for-paste') region in
+the kill ring. Uses `inline-css', with style information in
+`
' tags, so that the rendering of the marked up text
+approximates the buffer as closely as possible."
+  (interactive "r")
+  (let ((htmlize-pre-style t))
+    (kill-new (htmlize-region-for-paste beg end)))
+  (deactivate-mark))
+
+(defun htmlize-make-file-name (file)
+  "Make an HTML file name from FILE.
+
+In its default implementation, this simply appends `.html' to FILE.
+This function is called by htmlize to create the buffer file name, and
+by `htmlize-file' to create the target file name.
+
+More elaborate transformations are conceivable, such as changing FILE's
+extension to `.html' (\"file.c\" -> \"file.html\").  If you want them,
+overload this function to do it and htmlize will comply."
+  (concat file ".html"))
+
+;; Older implementation of htmlize-make-file-name that changes FILE's
+;; extension to ".html".
+;(defun htmlize-make-file-name (file)
+;  (let ((extension (file-name-extension file))
+;	(sans-extension (file-name-sans-extension file)))
+;    (if (or (equal extension "html")
+;	    (equal extension "htm")
+;	    (equal sans-extension ""))
+;	(concat file ".html")
+;      (concat sans-extension ".html"))))
+
+;;;###autoload
+(defun htmlize-file (file &optional target)
+  "Load FILE, fontify it, convert it to HTML, and save the result.
+
+Contents of FILE are inserted into a temporary buffer, whose major mode
+is set with `normal-mode' as appropriate for the file type.  The buffer
+is subsequently fontified with `font-lock' and converted to HTML.  Note
+that, unlike `htmlize-buffer', this function explicitly turns on
+font-lock.  If a form of highlighting other than font-lock is desired,
+please use `htmlize-buffer' directly on buffers so highlighted.
+
+Buffers currently visiting FILE are unaffected by this function.  The
+function does not change current buffer or move the point.
+
+If TARGET is specified and names a directory, the resulting file will be
+saved there instead of to FILE's directory.  If TARGET is specified and
+does not name a directory, it will be used as output file name."
+  (interactive (list (read-file-name
+		      "HTML-ize file: "
+		      nil nil nil (and (buffer-file-name)
+				       (file-name-nondirectory
+					(buffer-file-name))))))
+  (let ((output-file (if (and target (not (file-directory-p target)))
+			 target
+		       (expand-file-name
+			(htmlize-make-file-name (file-name-nondirectory file))
+			(or target (file-name-directory file)))))
+	;; Try to prevent `find-file-noselect' from triggering
+	;; font-lock because we'll fontify explicitly below.
+	(font-lock-mode nil)
+	(font-lock-auto-fontify nil)
+	(global-font-lock-mode nil)
+	;; Ignore the size limit for the purposes of htmlization.
+	(font-lock-maximum-size nil))
+    (with-temp-buffer
+      ;; Insert FILE into the temporary buffer.
+      (insert-file-contents file)
+      ;; Set the file name so normal-mode and htmlize-buffer-1 pick it
+      ;; up.  Restore it afterwards so with-temp-buffer's kill-buffer
+      ;; doesn't complain about killing a modified buffer.
+      (let ((buffer-file-name file))
+	;; Set the major mode for the sake of font-lock.
+	(normal-mode)
+	;; htmlize the buffer and save the HTML.
+	(with-current-buffer (htmlize-buffer-1)
+	  (unwind-protect
+	      (progn
+		(run-hooks 'htmlize-file-hook)
+		(write-region (point-min) (point-max) output-file))
+	    (kill-buffer (current-buffer)))))))
+  ;; I haven't decided on a useful return value yet, so just return
+  ;; nil.
+  nil)
+
+;;;###autoload
+(defun htmlize-many-files (files &optional target-directory)
+  "Convert FILES to HTML and save the corresponding HTML versions.
+
+FILES should be a list of file names to convert.  This function calls
+`htmlize-file' on each file; see that function for details.  When
+invoked interactively, you are prompted for a list of files to convert,
+terminated with RET.
+
+If TARGET-DIRECTORY is specified, the HTML files will be saved to that
+directory.  Normally, each HTML file is saved to the directory of the
+corresponding source file."
+  (interactive
+   (list
+    (let (list file)
+      ;; Use empty string as DEFAULT because setting DEFAULT to nil
+      ;; defaults to the directory name, which is not what we want.
+      (while (not (equal (setq file (read-file-name
+				     "HTML-ize file (RET to finish): "
+				     (and list (file-name-directory
+						(car list)))
+				     "" t))
+			 ""))
+	(push file list))
+      (nreverse list))))
+  ;; Verify that TARGET-DIRECTORY is indeed a directory.  If it's a
+  ;; file, htmlize-file will use it as target, and that doesn't make
+  ;; sense.
+  (and target-directory
+       (not (file-directory-p target-directory))
+       (error "target-directory must name a directory: %s" target-directory))
+  (dolist (file files)
+    (htmlize-file file target-directory)))
+
+;;;###autoload
+(defun htmlize-many-files-dired (arg &optional target-directory)
+  "HTMLize dired-marked files."
+  (interactive "P")
+  (htmlize-many-files (dired-get-marked-files nil arg) target-directory))
+
+(provide 'htmlize)
+
+;; Local Variables:
+;; byte-compile-warnings: (not unresolved obsolete)
+;; End:
+
+;;; htmlize.el ends here