Home Explore Help
Sign In
txlyre
/
avram
1
0
Fork 0
Files Issues 0 Pull Requests 0 Wiki
Browse Source

deleted redundant copy of src tree from gh-pages branch

Dennis Furey 12 years ago
parent
e34c58efae
commit
a4eea462b2
53 changed files with 0 additions and 25538 deletions
Unified View Show Diff Stats
  1. 0 23
      src/Makefile.am
  2. 0 1228
      src/Makefile.in
  3. 0 706
      src/apply.c
  4. 0 855
      src/avram.c
  5. 0 394
      src/bes.c
  6. 0 289
      src/branches.c
  7. 0 789
      src/chrcodes.c
  8. 0 520
      src/cmdline.c
  9. 0 77
      src/com.fun
  10. 0 318
      src/compare.c
  11. 0 520
      src/complexlib.c
  12. 0 245
      src/decons.c
  13. 0 161
      src/error.c
  14. 0 27
      src/exf.c
  15. 0 29
      src/exfsrc.fun
  16. 0 946
      src/exmodes.c
  17. 0 705
      src/farms.c
  18. 0 390
      src/fftw.c
  19. 0 216
      src/fnames.c
  20. 0 260
      src/formin.c
  21. 0 316
      src/formout.c
  22. 0 477
      src/glpklib.c
  23. 0 364
      src/gsldiflib.c
  24. 0 260
      src/gslevu.c
  25. 0 523
      src/gslintlib.c
  26. 0 344
      src/harminv.c
  27. 0 182
      src/instruct.c
  28. 0 272
      src/jobs.c
  29. 0 680
      src/kinsol.c
  30. 0 2113
      src/lapack.c
  31. 0 323
      src/libfuns.c
  32. 0 683
      src/listfuns.c
  33. 0 540
      src/lists.c
  34. 0 542
      src/lpsolve.c
  35. 0 614
      src/matcon.c
  36. 0 609
      src/mathlib.c
  37. 0 32
      src/memmove.c
  38. 0 1247
      src/minpack.c
  39. 0 1534
      src/mpfr.c
  40. 0 961
      src/mtwist.c
  41. 0 612
      src/mwrap.c
  42. 0 133
      src/portals.c
  43. 0 133
      src/ports.c
  44. 0 224
      src/profile.c
  45. 0 413
      src/rawio.c
  46. 0 431
      src/remote.c
  47. 0 34
      src/rewrite.c
  48. 0 522
      src/rmathlib.c
  49. 0 807
      src/servlist.c
  50. 0 467
      src/umf.c
  51. 0 260
      src/vglue.c
  52. 0 148
      src/vman.c
  53. 0 40
      src/xstrerror.c

+ 0 - 23
src/Makefile.am
View File 

@@ -1,23 +0,0 @@
 
-EXTRA_DIST              = com.fun exfsrc.fun
 
-
 
-bin_PROGRAMS            = avram
 
-
 
-avram_CFLAGS            = $(AM_CFLAGS)
 
-
 
-avram_LDADD             = -lm
 
-
 
-avram_LDFLAGS           = -export-dynamic
 
-
 
-MAINTAINERCLEANFILES	= Makefile.in
 
-
 
-INCLUDES		= -I$(top_builddir) -I$(top_srcdir) $(LTDLINCL)
 
-
 
-avram_SOURCES     = avram.c error.c xstrerror.c \
 
-lists.c branches.c chrcodes.c rawio.c formin.c formout.c fnames.c \
 
-cmdline.c compare.c decons.c ports.c portals.c profile.c instruct.c \
 
-listfuns.c matcon.c apply.c exmodes.c vman.c memmove.c rewrite.c exf.c \
 
-mathlib.c complexlib.c rmathlib.c mtwist.c \
 
-gslintlib.c gsldiflib.c gslevu.c glpklib.c umf.c mpfr.c \
 
-lapack.c fftw.c minpack.c kinsol.c libfuns.c mwrap.c bes.c lpsolve.c \
 
-harminv.c remote.c servlist.c jobs.c farms.c vglue.c
 
-

+ 0 - 1228
src/Makefile.in
View File 

@@ -1,1228 +0,0 @@
 
-# Makefile.in generated by automake 1.11.1 from Makefile.am.
 
-# @configure_input@
 
-
 
-# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
 
-# 2003, 2004, 2005, 2006, 2007, 2008, 2009  Free Software Foundation,
 
-# Inc.
 
-# This Makefile.in is free software; the Free Software Foundation
 
-# gives unlimited permission to copy and/or distribute it,
 
-# with or without modifications, as long as this notice is preserved.
 
-
 
-# This program is distributed in the hope that it will be useful,
 
-# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
 
-# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
 
-# PARTICULAR PURPOSE.
 
-
 
-@SET_MAKE@
 
-
 
-VPATH = @srcdir@
 
-pkgdatadir = $(datadir)/@PACKAGE@
 
-pkgincludedir = $(includedir)/@PACKAGE@
 
-pkglibdir = $(libdir)/@PACKAGE@
 
-pkglibexecdir = $(libexecdir)/@PACKAGE@
 
-am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
 
-install_sh_DATA = $(install_sh) -c -m 644
 
-install_sh_PROGRAM = $(install_sh) -c
 
-install_sh_SCRIPT = $(install_sh) -c
 
-INSTALL_HEADER = $(INSTALL_DATA)
 
-transform = $(program_transform_name)
 
-NORMAL_INSTALL = :
 
-PRE_INSTALL = :
 
-POST_INSTALL = :
 
-NORMAL_UNINSTALL = :
 
-PRE_UNINSTALL = :
 
-POST_UNINSTALL = :
 
-bin_PROGRAMS = avram$(EXEEXT)
 
-subdir = src
 
-DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.in
 
-ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
 
-am__aclocal_m4_deps = $(top_srcdir)/configure.in
 
-am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
 
-	$(ACLOCAL_M4)
 
-mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs
 
-CONFIG_HEADER = $(top_builddir)/config.h
 
-CONFIG_CLEAN_FILES =
 
-CONFIG_CLEAN_VPATH_FILES =
 
-am__installdirs = "$(DESTDIR)$(bindir)"
 
-PROGRAMS = $(bin_PROGRAMS)
 
-am_avram_OBJECTS = avram-avram.$(OBJEXT) avram-error.$(OBJEXT) \
 
-	avram-xstrerror.$(OBJEXT) avram-lists.$(OBJEXT) \
 
-	avram-branches.$(OBJEXT) avram-chrcodes.$(OBJEXT) \
 
-	avram-rawio.$(OBJEXT) avram-formin.$(OBJEXT) \
 
-	avram-formout.$(OBJEXT) avram-fnames.$(OBJEXT) \
 
-	avram-cmdline.$(OBJEXT) avram-compare.$(OBJEXT) \
 
-	avram-decons.$(OBJEXT) avram-ports.$(OBJEXT) \
 
-	avram-portals.$(OBJEXT) avram-profile.$(OBJEXT) \
 
-	avram-instruct.$(OBJEXT) avram-listfuns.$(OBJEXT) \
 
-	avram-matcon.$(OBJEXT) avram-apply.$(OBJEXT) \
 
-	avram-exmodes.$(OBJEXT) avram-vman.$(OBJEXT) \
 
-	avram-memmove.$(OBJEXT) avram-rewrite.$(OBJEXT) \
 
-	avram-exf.$(OBJEXT) avram-mathlib.$(OBJEXT) \
 
-	avram-complexlib.$(OBJEXT) avram-rmathlib.$(OBJEXT) \
 
-	avram-mtwist.$(OBJEXT) avram-gslintlib.$(OBJEXT) \
 
-	avram-gsldiflib.$(OBJEXT) avram-gslevu.$(OBJEXT) \
 
-	avram-glpklib.$(OBJEXT) avram-umf.$(OBJEXT) \
 
-	avram-mpfr.$(OBJEXT) avram-lapack.$(OBJEXT) \
 
-	avram-fftw.$(OBJEXT) avram-minpack.$(OBJEXT) \
 
-	avram-kinsol.$(OBJEXT) avram-libfuns.$(OBJEXT) \
 
-	avram-mwrap.$(OBJEXT) avram-bes.$(OBJEXT) \
 
-	avram-lpsolve.$(OBJEXT) avram-harminv.$(OBJEXT) \
 
-	avram-remote.$(OBJEXT) avram-servlist.$(OBJEXT) \
 
-	avram-jobs.$(OBJEXT) avram-farms.$(OBJEXT) \
 
-	avram-vglue.$(OBJEXT)
 
-avram_OBJECTS = $(am_avram_OBJECTS)
 
-avram_DEPENDENCIES =
 
-avram_LINK = $(CCLD) $(avram_CFLAGS) $(CFLAGS) $(avram_LDFLAGS) \
 
-	$(LDFLAGS) -o $@
 
-DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir)
 
-depcomp = $(SHELL) $(top_srcdir)/depcomp
 
-am__depfiles_maybe = depfiles
 
-am__mv = mv -f
 
-COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \
 
-	$(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS)
 
-CCLD = $(CC)
 
-LINK = $(CCLD) $(AM_CFLAGS) $(CFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o $@
 
-SOURCES = $(avram_SOURCES)
 
-DIST_SOURCES = $(avram_SOURCES)
 
-ETAGS = etags
 
-CTAGS = ctags
 
-DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
 
-ACLOCAL = @ACLOCAL@
 
-AMTAR = @AMTAR@
 
-AUTOCONF = @AUTOCONF@
 
-AUTOHEADER = @AUTOHEADER@
 
-AUTOMAKE = @AUTOMAKE@
 
-AWK = @AWK@
 
-CC = @CC@
 
-CCDEPMODE = @CCDEPMODE@
 
-CFLAGS = @CFLAGS@
 
-CPP = @CPP@
 
-CPPFLAGS = @CPPFLAGS@
 
-CYGPATH_W = @CYGPATH_W@
 
-DEFS = @DEFS@
 
-DEPDIR = @DEPDIR@
 
-ECHO_C = @ECHO_C@
 
-ECHO_N = @ECHO_N@
 
-ECHO_T = @ECHO_T@
 
-EGREP = @EGREP@
 
-EXEEXT = @EXEEXT@
 
-GREP = @GREP@
 
-INSTALL = @INSTALL@
 
-INSTALL_DATA = @INSTALL_DATA@
 
-INSTALL_PROGRAM = @INSTALL_PROGRAM@
 
-INSTALL_SCRIPT = @INSTALL_SCRIPT@
 
-INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
 
-ISODATE = @ISODATE@
 
-LDFLAGS = @LDFLAGS@
 
-LIBGCRYPT_CFLAGS = @LIBGCRYPT_CFLAGS@
 
-LIBGCRYPT_CONFIG = @LIBGCRYPT_CONFIG@
 
-LIBGCRYPT_LIBS = @LIBGCRYPT_LIBS@
 
-LIBOBJS = @LIBOBJS@
 
-LIBS = @LIBS@
 
-LTLIBOBJS = @LTLIBOBJS@
 
-MAKEINFO = @MAKEINFO@
 
-MKDIR_P = @MKDIR_P@
 
-OBJEXT = @OBJEXT@
 
-PACKAGE = @PACKAGE@
 
-PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
 
-PACKAGE_NAME = @PACKAGE_NAME@
 
-PACKAGE_STRING = @PACKAGE_STRING@
 
-PACKAGE_TARNAME = @PACKAGE_TARNAME@
 
-PACKAGE_URL = @PACKAGE_URL@
 
-PACKAGE_VERSION = @PACKAGE_VERSION@
 
-PATH_SEPARATOR = @PATH_SEPARATOR@
 
-SET_MAKE = @SET_MAKE@
 
-SHELL = @SHELL@
 
-STRIP = @STRIP@
 
-VERSION = @VERSION@
 
-abs_builddir = @abs_builddir@
 
-abs_srcdir = @abs_srcdir@
 
-abs_top_builddir = @abs_top_builddir@
 
-abs_top_srcdir = @abs_top_srcdir@
 
-ac_ct_CC = @ac_ct_CC@
 
-am__include = @am__include@
 
-am__leading_dot = @am__leading_dot@
 
-am__quote = @am__quote@
 
-am__tar = @am__tar@
 
-am__untar = @am__untar@
 
-bindir = @bindir@
 
-build_alias = @build_alias@
 
-builddir = @builddir@
 
-datadir = @datadir@
 
-datarootdir = @datarootdir@
 
-docdir = @docdir@
 
-dvidir = @dvidir@
 
-exec_prefix = @exec_prefix@
 
-host_alias = @host_alias@
 
-htmldir = @htmldir@
 
-includedir = @includedir@
 
-infodir = @infodir@
 
-install_sh = @install_sh@
 
-libdir = @libdir@
 
-libexecdir = @libexecdir@
 
-localedir = @localedir@
 
-localstatedir = @localstatedir@
 
-mandir = @mandir@
 
-mkdir_p = @mkdir_p@
 
-oldincludedir = @oldincludedir@
 
-pdfdir = @pdfdir@
 
-prefix = @prefix@
 
-program_transform_name = @program_transform_name@
 
-psdir = @psdir@
 
-sbindir = @sbindir@
 
-sharedstatedir = @sharedstatedir@
 
-srcdir = @srcdir@
 
-sysconfdir = @sysconfdir@
 
-target_alias = @target_alias@
 
-top_build_prefix = @top_build_prefix@
 
-top_builddir = @top_builddir@
 
-top_srcdir = @top_srcdir@
 
-EXTRA_DIST = com.fun exfsrc.fun
 
-avram_CFLAGS = $(AM_CFLAGS)
 
-avram_LDADD = -lm
 
-avram_LDFLAGS = -export-dynamic
 
-MAINTAINERCLEANFILES = Makefile.in
 
-INCLUDES = -I$(top_builddir) -I$(top_srcdir) $(LTDLINCL)
 
-avram_SOURCES = avram.c error.c xstrerror.c \
 
-lists.c branches.c chrcodes.c rawio.c formin.c formout.c fnames.c \
 
-cmdline.c compare.c decons.c ports.c portals.c profile.c instruct.c \
 
-listfuns.c matcon.c apply.c exmodes.c vman.c memmove.c rewrite.c exf.c \
 
-mathlib.c complexlib.c rmathlib.c mtwist.c \
 
-gslintlib.c gsldiflib.c gslevu.c glpklib.c umf.c mpfr.c \
 
-lapack.c fftw.c minpack.c kinsol.c libfuns.c mwrap.c bes.c lpsolve.c \
 
-harminv.c remote.c servlist.c jobs.c farms.c vglue.c
 
-
 
-all: all-am
 
-
 
-.SUFFIXES:
 
-.SUFFIXES: .c .o .obj
 
-$(srcdir)/Makefile.in:  $(srcdir)/Makefile.am  $(am__configure_deps)
 
-	@for dep in $?; do \
 
-	  case '$(am__configure_deps)' in \
 
-	    *$$dep*) \
 
-	      ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
 
-	        && { if test -f $@; then exit 0; else break; fi; }; \
 
-	      exit 1;; \
 
-	  esac; \
 
-	done; \
 
-	echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/Makefile'; \
 
-	$(am__cd) $(top_srcdir) && \
 
-	  $(AUTOMAKE) --gnu src/Makefile
 
-.PRECIOUS: Makefile
 
-Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
 
-	@case '$?' in \
 
-	  *config.status*) \
 
-	    cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
 
-	  *) \
 
-	    echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
 
-	    cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
 
-	esac;
 
-
 
-$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
 
-	cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
 
-
 
-$(top_srcdir)/configure:  $(am__configure_deps)
 
-	cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
 
-$(ACLOCAL_M4):  $(am__aclocal_m4_deps)
 
-	cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
 
-$(am__aclocal_m4_deps):
 
-install-binPROGRAMS: $(bin_PROGRAMS)
 
-	@$(NORMAL_INSTALL)
 
-	test -z "$(bindir)" || $(MKDIR_P) "$(DESTDIR)$(bindir)"
 
-	@list='$(bin_PROGRAMS)'; test -n "$(bindir)" || list=; \
 
-	for p in $$list; do echo "$$p $$p"; done | \
 
-	sed 's/$(EXEEXT)$$//' | \
 
-	while read p p1; do if test -f $$p; \
 
-	  then echo "$$p"; echo "$$p"; else :; fi; \
 
-	done | \
 
-	sed -e 'p;s,.*/,,;n;h' -e 's|.*|.|' \
 
-	    -e 'p;x;s,.*/,,;s/$(EXEEXT)$$//;$(transform);s/$$/$(EXEEXT)/' | \
 
-	sed 'N;N;N;s,\n, ,g' | \
 
-	$(AWK) 'BEGIN { files["."] = ""; dirs["."] = 1 } \
 
-	  { d=$$3; if (dirs[d] != 1) { print "d", d; dirs[d] = 1 } \
 
-	    if ($$2 == $$4) files[d] = files[d] " " $$1; \
 
-	    else { print "f", $$3 "/" $$4, $$1; } } \
 
-	  END { for (d in files) print "f", d, files[d] }' | \
 
-	while read type dir files; do \
 
-	    if test "$$dir" = .; then dir=; else dir=/$$dir; fi; \
 
-	    test -z "$$files" || { \
 
-	      echo " $(INSTALL_PROGRAM_ENV) $(INSTALL_PROGRAM) $$files '$(DESTDIR)$(bindir)$$dir'"; \
 
-	      $(INSTALL_PROGRAM_ENV) $(INSTALL_PROGRAM) $$files "$(DESTDIR)$(bindir)$$dir" || exit $$?; \
 
-	    } \
 
-	; done
 
-
 
-uninstall-binPROGRAMS:
 
-	@$(NORMAL_UNINSTALL)
 
-	@list='$(bin_PROGRAMS)'; test -n "$(bindir)" || list=; \
 
-	files=`for p in $$list; do echo "$$p"; done | \
 
-	  sed -e 'h;s,^.*/,,;s/$(EXEEXT)$$//;$(transform)' \
 
-	      -e 's/$$/$(EXEEXT)/' `; \
 
-	test -n "$$list" || exit 0; \
 
-	echo " ( cd '$(DESTDIR)$(bindir)' && rm -f" $$files ")"; \
 
-	cd "$(DESTDIR)$(bindir)" && rm -f $$files
 
-
 
-clean-binPROGRAMS:
 
-	-test -z "$(bin_PROGRAMS)" || rm -f $(bin_PROGRAMS)
 
-avram$(EXEEXT): $(avram_OBJECTS) $(avram_DEPENDENCIES) 
-	@rm -f avram$(EXEEXT)
 
-	$(avram_LINK) $(avram_OBJECTS) $(avram_LDADD) $(LIBS)
 
-
 
-mostlyclean-compile:
 
-	-rm -f *.$(OBJEXT)
 
-
 
-distclean-compile:
 
-	-rm -f *.tab.c
 
-
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-apply.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-avram.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-bes.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-branches.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-chrcodes.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-cmdline.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-compare.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-complexlib.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-decons.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-error.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-exf.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-exmodes.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-farms.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-fftw.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-fnames.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-formin.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-formout.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-glpklib.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-gsldiflib.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-gslevu.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-gslintlib.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-harminv.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-instruct.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-jobs.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-kinsol.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-lapack.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-libfuns.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-listfuns.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-lists.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-lpsolve.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-matcon.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-mathlib.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-memmove.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-minpack.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-mpfr.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-mtwist.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-mwrap.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-portals.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-ports.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-profile.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-rawio.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-remote.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-rewrite.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-rmathlib.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-servlist.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-umf.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-vglue.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-vman.Po@am__quote@
 
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/avram-xstrerror.Po@am__quote@
 
-
 
-.c.o:
 
-@am__fastdepCC_TRUE@	$(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $<
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$<' object='$@' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(COMPILE) -c $<
 
-
 
-.c.obj:
 
-@am__fastdepCC_TRUE@	$(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ `$(CYGPATH_W) '$<'`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$<' object='$@' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(COMPILE) -c `$(CYGPATH_W) '$<'`
 
-
 
-avram-avram.o: avram.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-avram.o -MD -MP -MF $(DEPDIR)/avram-avram.Tpo -c -o avram-avram.o `test -f 'avram.c' || echo '$(srcdir)/'`avram.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-avram.Tpo $(DEPDIR)/avram-avram.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='avram.c' object='avram-avram.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-avram.o `test -f 'avram.c' || echo '$(srcdir)/'`avram.c
 
-
 
-avram-avram.obj: avram.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-avram.obj -MD -MP -MF $(DEPDIR)/avram-avram.Tpo -c -o avram-avram.obj `if test -f 'avram.c'; then $(CYGPATH_W) 'avram.c'; else $(CYGPATH_W) '$(srcdir)/avram.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-avram.Tpo $(DEPDIR)/avram-avram.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='avram.c' object='avram-avram.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-avram.obj `if test -f 'avram.c'; then $(CYGPATH_W) 'avram.c'; else $(CYGPATH_W) '$(srcdir)/avram.c'; fi`
 
-
 
-avram-error.o: error.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-error.o -MD -MP -MF $(DEPDIR)/avram-error.Tpo -c -o avram-error.o `test -f 'error.c' || echo '$(srcdir)/'`error.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-error.Tpo $(DEPDIR)/avram-error.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='error.c' object='avram-error.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-error.o `test -f 'error.c' || echo '$(srcdir)/'`error.c
 
-
 
-avram-error.obj: error.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-error.obj -MD -MP -MF $(DEPDIR)/avram-error.Tpo -c -o avram-error.obj `if test -f 'error.c'; then $(CYGPATH_W) 'error.c'; else $(CYGPATH_W) '$(srcdir)/error.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-error.Tpo $(DEPDIR)/avram-error.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='error.c' object='avram-error.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-error.obj `if test -f 'error.c'; then $(CYGPATH_W) 'error.c'; else $(CYGPATH_W) '$(srcdir)/error.c'; fi`
 
-
 
-avram-xstrerror.o: xstrerror.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-xstrerror.o -MD -MP -MF $(DEPDIR)/avram-xstrerror.Tpo -c -o avram-xstrerror.o `test -f 'xstrerror.c' || echo '$(srcdir)/'`xstrerror.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-xstrerror.Tpo $(DEPDIR)/avram-xstrerror.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='xstrerror.c' object='avram-xstrerror.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-xstrerror.o `test -f 'xstrerror.c' || echo '$(srcdir)/'`xstrerror.c
 
-
 
-avram-xstrerror.obj: xstrerror.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-xstrerror.obj -MD -MP -MF $(DEPDIR)/avram-xstrerror.Tpo -c -o avram-xstrerror.obj `if test -f 'xstrerror.c'; then $(CYGPATH_W) 'xstrerror.c'; else $(CYGPATH_W) '$(srcdir)/xstrerror.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-xstrerror.Tpo $(DEPDIR)/avram-xstrerror.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='xstrerror.c' object='avram-xstrerror.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-xstrerror.obj `if test -f 'xstrerror.c'; then $(CYGPATH_W) 'xstrerror.c'; else $(CYGPATH_W) '$(srcdir)/xstrerror.c'; fi`
 
-
 
-avram-lists.o: lists.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-lists.o -MD -MP -MF $(DEPDIR)/avram-lists.Tpo -c -o avram-lists.o `test -f 'lists.c' || echo '$(srcdir)/'`lists.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-lists.Tpo $(DEPDIR)/avram-lists.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='lists.c' object='avram-lists.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-lists.o `test -f 'lists.c' || echo '$(srcdir)/'`lists.c
 
-
 
-avram-lists.obj: lists.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-lists.obj -MD -MP -MF $(DEPDIR)/avram-lists.Tpo -c -o avram-lists.obj `if test -f 'lists.c'; then $(CYGPATH_W) 'lists.c'; else $(CYGPATH_W) '$(srcdir)/lists.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-lists.Tpo $(DEPDIR)/avram-lists.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='lists.c' object='avram-lists.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-lists.obj `if test -f 'lists.c'; then $(CYGPATH_W) 'lists.c'; else $(CYGPATH_W) '$(srcdir)/lists.c'; fi`
 
-
 
-avram-branches.o: branches.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-branches.o -MD -MP -MF $(DEPDIR)/avram-branches.Tpo -c -o avram-branches.o `test -f 'branches.c' || echo '$(srcdir)/'`branches.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-branches.Tpo $(DEPDIR)/avram-branches.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='branches.c' object='avram-branches.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-branches.o `test -f 'branches.c' || echo '$(srcdir)/'`branches.c
 
-
 
-avram-branches.obj: branches.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-branches.obj -MD -MP -MF $(DEPDIR)/avram-branches.Tpo -c -o avram-branches.obj `if test -f 'branches.c'; then $(CYGPATH_W) 'branches.c'; else $(CYGPATH_W) '$(srcdir)/branches.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-branches.Tpo $(DEPDIR)/avram-branches.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='branches.c' object='avram-branches.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-branches.obj `if test -f 'branches.c'; then $(CYGPATH_W) 'branches.c'; else $(CYGPATH_W) '$(srcdir)/branches.c'; fi`
 
-
 
-avram-chrcodes.o: chrcodes.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-chrcodes.o -MD -MP -MF $(DEPDIR)/avram-chrcodes.Tpo -c -o avram-chrcodes.o `test -f 'chrcodes.c' || echo '$(srcdir)/'`chrcodes.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-chrcodes.Tpo $(DEPDIR)/avram-chrcodes.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='chrcodes.c' object='avram-chrcodes.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-chrcodes.o `test -f 'chrcodes.c' || echo '$(srcdir)/'`chrcodes.c
 
-
 
-avram-chrcodes.obj: chrcodes.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-chrcodes.obj -MD -MP -MF $(DEPDIR)/avram-chrcodes.Tpo -c -o avram-chrcodes.obj `if test -f 'chrcodes.c'; then $(CYGPATH_W) 'chrcodes.c'; else $(CYGPATH_W) '$(srcdir)/chrcodes.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-chrcodes.Tpo $(DEPDIR)/avram-chrcodes.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='chrcodes.c' object='avram-chrcodes.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-chrcodes.obj `if test -f 'chrcodes.c'; then $(CYGPATH_W) 'chrcodes.c'; else $(CYGPATH_W) '$(srcdir)/chrcodes.c'; fi`
 
-
 
-avram-rawio.o: rawio.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-rawio.o -MD -MP -MF $(DEPDIR)/avram-rawio.Tpo -c -o avram-rawio.o `test -f 'rawio.c' || echo '$(srcdir)/'`rawio.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-rawio.Tpo $(DEPDIR)/avram-rawio.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='rawio.c' object='avram-rawio.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-rawio.o `test -f 'rawio.c' || echo '$(srcdir)/'`rawio.c
 
-
 
-avram-rawio.obj: rawio.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-rawio.obj -MD -MP -MF $(DEPDIR)/avram-rawio.Tpo -c -o avram-rawio.obj `if test -f 'rawio.c'; then $(CYGPATH_W) 'rawio.c'; else $(CYGPATH_W) '$(srcdir)/rawio.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-rawio.Tpo $(DEPDIR)/avram-rawio.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='rawio.c' object='avram-rawio.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-rawio.obj `if test -f 'rawio.c'; then $(CYGPATH_W) 'rawio.c'; else $(CYGPATH_W) '$(srcdir)/rawio.c'; fi`
 
-
 
-avram-formin.o: formin.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-formin.o -MD -MP -MF $(DEPDIR)/avram-formin.Tpo -c -o avram-formin.o `test -f 'formin.c' || echo '$(srcdir)/'`formin.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-formin.Tpo $(DEPDIR)/avram-formin.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='formin.c' object='avram-formin.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-formin.o `test -f 'formin.c' || echo '$(srcdir)/'`formin.c
 
-
 
-avram-formin.obj: formin.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-formin.obj -MD -MP -MF $(DEPDIR)/avram-formin.Tpo -c -o avram-formin.obj `if test -f 'formin.c'; then $(CYGPATH_W) 'formin.c'; else $(CYGPATH_W) '$(srcdir)/formin.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-formin.Tpo $(DEPDIR)/avram-formin.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='formin.c' object='avram-formin.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-formin.obj `if test -f 'formin.c'; then $(CYGPATH_W) 'formin.c'; else $(CYGPATH_W) '$(srcdir)/formin.c'; fi`
 
-
 
-avram-formout.o: formout.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-formout.o -MD -MP -MF $(DEPDIR)/avram-formout.Tpo -c -o avram-formout.o `test -f 'formout.c' || echo '$(srcdir)/'`formout.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-formout.Tpo $(DEPDIR)/avram-formout.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='formout.c' object='avram-formout.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-formout.o `test -f 'formout.c' || echo '$(srcdir)/'`formout.c
 
-
 
-avram-formout.obj: formout.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-formout.obj -MD -MP -MF $(DEPDIR)/avram-formout.Tpo -c -o avram-formout.obj `if test -f 'formout.c'; then $(CYGPATH_W) 'formout.c'; else $(CYGPATH_W) '$(srcdir)/formout.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-formout.Tpo $(DEPDIR)/avram-formout.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='formout.c' object='avram-formout.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-formout.obj `if test -f 'formout.c'; then $(CYGPATH_W) 'formout.c'; else $(CYGPATH_W) '$(srcdir)/formout.c'; fi`
 
-
 
-avram-fnames.o: fnames.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-fnames.o -MD -MP -MF $(DEPDIR)/avram-fnames.Tpo -c -o avram-fnames.o `test -f 'fnames.c' || echo '$(srcdir)/'`fnames.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-fnames.Tpo $(DEPDIR)/avram-fnames.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='fnames.c' object='avram-fnames.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-fnames.o `test -f 'fnames.c' || echo '$(srcdir)/'`fnames.c
 
-
 
-avram-fnames.obj: fnames.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-fnames.obj -MD -MP -MF $(DEPDIR)/avram-fnames.Tpo -c -o avram-fnames.obj `if test -f 'fnames.c'; then $(CYGPATH_W) 'fnames.c'; else $(CYGPATH_W) '$(srcdir)/fnames.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-fnames.Tpo $(DEPDIR)/avram-fnames.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='fnames.c' object='avram-fnames.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-fnames.obj `if test -f 'fnames.c'; then $(CYGPATH_W) 'fnames.c'; else $(CYGPATH_W) '$(srcdir)/fnames.c'; fi`
 
-
 
-avram-cmdline.o: cmdline.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-cmdline.o -MD -MP -MF $(DEPDIR)/avram-cmdline.Tpo -c -o avram-cmdline.o `test -f 'cmdline.c' || echo '$(srcdir)/'`cmdline.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-cmdline.Tpo $(DEPDIR)/avram-cmdline.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='cmdline.c' object='avram-cmdline.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-cmdline.o `test -f 'cmdline.c' || echo '$(srcdir)/'`cmdline.c
 
-
 
-avram-cmdline.obj: cmdline.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-cmdline.obj -MD -MP -MF $(DEPDIR)/avram-cmdline.Tpo -c -o avram-cmdline.obj `if test -f 'cmdline.c'; then $(CYGPATH_W) 'cmdline.c'; else $(CYGPATH_W) '$(srcdir)/cmdline.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-cmdline.Tpo $(DEPDIR)/avram-cmdline.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='cmdline.c' object='avram-cmdline.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-cmdline.obj `if test -f 'cmdline.c'; then $(CYGPATH_W) 'cmdline.c'; else $(CYGPATH_W) '$(srcdir)/cmdline.c'; fi`
 
-
 
-avram-compare.o: compare.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-compare.o -MD -MP -MF $(DEPDIR)/avram-compare.Tpo -c -o avram-compare.o `test -f 'compare.c' || echo '$(srcdir)/'`compare.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-compare.Tpo $(DEPDIR)/avram-compare.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='compare.c' object='avram-compare.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-compare.o `test -f 'compare.c' || echo '$(srcdir)/'`compare.c
 
-
 
-avram-compare.obj: compare.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-compare.obj -MD -MP -MF $(DEPDIR)/avram-compare.Tpo -c -o avram-compare.obj `if test -f 'compare.c'; then $(CYGPATH_W) 'compare.c'; else $(CYGPATH_W) '$(srcdir)/compare.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-compare.Tpo $(DEPDIR)/avram-compare.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='compare.c' object='avram-compare.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-compare.obj `if test -f 'compare.c'; then $(CYGPATH_W) 'compare.c'; else $(CYGPATH_W) '$(srcdir)/compare.c'; fi`
 
-
 
-avram-decons.o: decons.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-decons.o -MD -MP -MF $(DEPDIR)/avram-decons.Tpo -c -o avram-decons.o `test -f 'decons.c' || echo '$(srcdir)/'`decons.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-decons.Tpo $(DEPDIR)/avram-decons.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='decons.c' object='avram-decons.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-decons.o `test -f 'decons.c' || echo '$(srcdir)/'`decons.c
 
-
 
-avram-decons.obj: decons.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-decons.obj -MD -MP -MF $(DEPDIR)/avram-decons.Tpo -c -o avram-decons.obj `if test -f 'decons.c'; then $(CYGPATH_W) 'decons.c'; else $(CYGPATH_W) '$(srcdir)/decons.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-decons.Tpo $(DEPDIR)/avram-decons.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='decons.c' object='avram-decons.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-decons.obj `if test -f 'decons.c'; then $(CYGPATH_W) 'decons.c'; else $(CYGPATH_W) '$(srcdir)/decons.c'; fi`
 
-
 
-avram-ports.o: ports.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-ports.o -MD -MP -MF $(DEPDIR)/avram-ports.Tpo -c -o avram-ports.o `test -f 'ports.c' || echo '$(srcdir)/'`ports.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-ports.Tpo $(DEPDIR)/avram-ports.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='ports.c' object='avram-ports.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-ports.o `test -f 'ports.c' || echo '$(srcdir)/'`ports.c
 
-
 
-avram-ports.obj: ports.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-ports.obj -MD -MP -MF $(DEPDIR)/avram-ports.Tpo -c -o avram-ports.obj `if test -f 'ports.c'; then $(CYGPATH_W) 'ports.c'; else $(CYGPATH_W) '$(srcdir)/ports.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-ports.Tpo $(DEPDIR)/avram-ports.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='ports.c' object='avram-ports.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-ports.obj `if test -f 'ports.c'; then $(CYGPATH_W) 'ports.c'; else $(CYGPATH_W) '$(srcdir)/ports.c'; fi`
 
-
 
-avram-portals.o: portals.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-portals.o -MD -MP -MF $(DEPDIR)/avram-portals.Tpo -c -o avram-portals.o `test -f 'portals.c' || echo '$(srcdir)/'`portals.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-portals.Tpo $(DEPDIR)/avram-portals.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='portals.c' object='avram-portals.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-portals.o `test -f 'portals.c' || echo '$(srcdir)/'`portals.c
 
-
 
-avram-portals.obj: portals.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-portals.obj -MD -MP -MF $(DEPDIR)/avram-portals.Tpo -c -o avram-portals.obj `if test -f 'portals.c'; then $(CYGPATH_W) 'portals.c'; else $(CYGPATH_W) '$(srcdir)/portals.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-portals.Tpo $(DEPDIR)/avram-portals.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='portals.c' object='avram-portals.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-portals.obj `if test -f 'portals.c'; then $(CYGPATH_W) 'portals.c'; else $(CYGPATH_W) '$(srcdir)/portals.c'; fi`
 
-
 
-avram-profile.o: profile.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-profile.o -MD -MP -MF $(DEPDIR)/avram-profile.Tpo -c -o avram-profile.o `test -f 'profile.c' || echo '$(srcdir)/'`profile.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-profile.Tpo $(DEPDIR)/avram-profile.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='profile.c' object='avram-profile.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-profile.o `test -f 'profile.c' || echo '$(srcdir)/'`profile.c
 
-
 
-avram-profile.obj: profile.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-profile.obj -MD -MP -MF $(DEPDIR)/avram-profile.Tpo -c -o avram-profile.obj `if test -f 'profile.c'; then $(CYGPATH_W) 'profile.c'; else $(CYGPATH_W) '$(srcdir)/profile.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-profile.Tpo $(DEPDIR)/avram-profile.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='profile.c' object='avram-profile.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-profile.obj `if test -f 'profile.c'; then $(CYGPATH_W) 'profile.c'; else $(CYGPATH_W) '$(srcdir)/profile.c'; fi`
 
-
 
-avram-instruct.o: instruct.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-instruct.o -MD -MP -MF $(DEPDIR)/avram-instruct.Tpo -c -o avram-instruct.o `test -f 'instruct.c' || echo '$(srcdir)/'`instruct.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-instruct.Tpo $(DEPDIR)/avram-instruct.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='instruct.c' object='avram-instruct.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-instruct.o `test -f 'instruct.c' || echo '$(srcdir)/'`instruct.c
 
-
 
-avram-instruct.obj: instruct.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-instruct.obj -MD -MP -MF $(DEPDIR)/avram-instruct.Tpo -c -o avram-instruct.obj `if test -f 'instruct.c'; then $(CYGPATH_W) 'instruct.c'; else $(CYGPATH_W) '$(srcdir)/instruct.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-instruct.Tpo $(DEPDIR)/avram-instruct.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='instruct.c' object='avram-instruct.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-instruct.obj `if test -f 'instruct.c'; then $(CYGPATH_W) 'instruct.c'; else $(CYGPATH_W) '$(srcdir)/instruct.c'; fi`
 
-
 
-avram-listfuns.o: listfuns.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-listfuns.o -MD -MP -MF $(DEPDIR)/avram-listfuns.Tpo -c -o avram-listfuns.o `test -f 'listfuns.c' || echo '$(srcdir)/'`listfuns.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-listfuns.Tpo $(DEPDIR)/avram-listfuns.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='listfuns.c' object='avram-listfuns.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-listfuns.o `test -f 'listfuns.c' || echo '$(srcdir)/'`listfuns.c
 
-
 
-avram-listfuns.obj: listfuns.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-listfuns.obj -MD -MP -MF $(DEPDIR)/avram-listfuns.Tpo -c -o avram-listfuns.obj `if test -f 'listfuns.c'; then $(CYGPATH_W) 'listfuns.c'; else $(CYGPATH_W) '$(srcdir)/listfuns.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-listfuns.Tpo $(DEPDIR)/avram-listfuns.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='listfuns.c' object='avram-listfuns.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-listfuns.obj `if test -f 'listfuns.c'; then $(CYGPATH_W) 'listfuns.c'; else $(CYGPATH_W) '$(srcdir)/listfuns.c'; fi`
 
-
 
-avram-matcon.o: matcon.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-matcon.o -MD -MP -MF $(DEPDIR)/avram-matcon.Tpo -c -o avram-matcon.o `test -f 'matcon.c' || echo '$(srcdir)/'`matcon.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-matcon.Tpo $(DEPDIR)/avram-matcon.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='matcon.c' object='avram-matcon.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-matcon.o `test -f 'matcon.c' || echo '$(srcdir)/'`matcon.c
 
-
 
-avram-matcon.obj: matcon.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-matcon.obj -MD -MP -MF $(DEPDIR)/avram-matcon.Tpo -c -o avram-matcon.obj `if test -f 'matcon.c'; then $(CYGPATH_W) 'matcon.c'; else $(CYGPATH_W) '$(srcdir)/matcon.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-matcon.Tpo $(DEPDIR)/avram-matcon.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='matcon.c' object='avram-matcon.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-matcon.obj `if test -f 'matcon.c'; then $(CYGPATH_W) 'matcon.c'; else $(CYGPATH_W) '$(srcdir)/matcon.c'; fi`
 
-
 
-avram-apply.o: apply.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-apply.o -MD -MP -MF $(DEPDIR)/avram-apply.Tpo -c -o avram-apply.o `test -f 'apply.c' || echo '$(srcdir)/'`apply.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-apply.Tpo $(DEPDIR)/avram-apply.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='apply.c' object='avram-apply.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-apply.o `test -f 'apply.c' || echo '$(srcdir)/'`apply.c
 
-
 
-avram-apply.obj: apply.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-apply.obj -MD -MP -MF $(DEPDIR)/avram-apply.Tpo -c -o avram-apply.obj `if test -f 'apply.c'; then $(CYGPATH_W) 'apply.c'; else $(CYGPATH_W) '$(srcdir)/apply.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-apply.Tpo $(DEPDIR)/avram-apply.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='apply.c' object='avram-apply.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-apply.obj `if test -f 'apply.c'; then $(CYGPATH_W) 'apply.c'; else $(CYGPATH_W) '$(srcdir)/apply.c'; fi`
 
-
 
-avram-exmodes.o: exmodes.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-exmodes.o -MD -MP -MF $(DEPDIR)/avram-exmodes.Tpo -c -o avram-exmodes.o `test -f 'exmodes.c' || echo '$(srcdir)/'`exmodes.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-exmodes.Tpo $(DEPDIR)/avram-exmodes.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='exmodes.c' object='avram-exmodes.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-exmodes.o `test -f 'exmodes.c' || echo '$(srcdir)/'`exmodes.c
 
-
 
-avram-exmodes.obj: exmodes.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-exmodes.obj -MD -MP -MF $(DEPDIR)/avram-exmodes.Tpo -c -o avram-exmodes.obj `if test -f 'exmodes.c'; then $(CYGPATH_W) 'exmodes.c'; else $(CYGPATH_W) '$(srcdir)/exmodes.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-exmodes.Tpo $(DEPDIR)/avram-exmodes.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='exmodes.c' object='avram-exmodes.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-exmodes.obj `if test -f 'exmodes.c'; then $(CYGPATH_W) 'exmodes.c'; else $(CYGPATH_W) '$(srcdir)/exmodes.c'; fi`
 
-
 
-avram-vman.o: vman.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-vman.o -MD -MP -MF $(DEPDIR)/avram-vman.Tpo -c -o avram-vman.o `test -f 'vman.c' || echo '$(srcdir)/'`vman.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-vman.Tpo $(DEPDIR)/avram-vman.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='vman.c' object='avram-vman.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-vman.o `test -f 'vman.c' || echo '$(srcdir)/'`vman.c
 
-
 
-avram-vman.obj: vman.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-vman.obj -MD -MP -MF $(DEPDIR)/avram-vman.Tpo -c -o avram-vman.obj `if test -f 'vman.c'; then $(CYGPATH_W) 'vman.c'; else $(CYGPATH_W) '$(srcdir)/vman.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-vman.Tpo $(DEPDIR)/avram-vman.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='vman.c' object='avram-vman.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-vman.obj `if test -f 'vman.c'; then $(CYGPATH_W) 'vman.c'; else $(CYGPATH_W) '$(srcdir)/vman.c'; fi`
 
-
 
-avram-memmove.o: memmove.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-memmove.o -MD -MP -MF $(DEPDIR)/avram-memmove.Tpo -c -o avram-memmove.o `test -f 'memmove.c' || echo '$(srcdir)/'`memmove.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-memmove.Tpo $(DEPDIR)/avram-memmove.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='memmove.c' object='avram-memmove.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-memmove.o `test -f 'memmove.c' || echo '$(srcdir)/'`memmove.c
 
-
 
-avram-memmove.obj: memmove.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-memmove.obj -MD -MP -MF $(DEPDIR)/avram-memmove.Tpo -c -o avram-memmove.obj `if test -f 'memmove.c'; then $(CYGPATH_W) 'memmove.c'; else $(CYGPATH_W) '$(srcdir)/memmove.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-memmove.Tpo $(DEPDIR)/avram-memmove.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='memmove.c' object='avram-memmove.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-memmove.obj `if test -f 'memmove.c'; then $(CYGPATH_W) 'memmove.c'; else $(CYGPATH_W) '$(srcdir)/memmove.c'; fi`
 
-
 
-avram-rewrite.o: rewrite.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-rewrite.o -MD -MP -MF $(DEPDIR)/avram-rewrite.Tpo -c -o avram-rewrite.o `test -f 'rewrite.c' || echo '$(srcdir)/'`rewrite.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-rewrite.Tpo $(DEPDIR)/avram-rewrite.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='rewrite.c' object='avram-rewrite.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-rewrite.o `test -f 'rewrite.c' || echo '$(srcdir)/'`rewrite.c
 
-
 
-avram-rewrite.obj: rewrite.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-rewrite.obj -MD -MP -MF $(DEPDIR)/avram-rewrite.Tpo -c -o avram-rewrite.obj `if test -f 'rewrite.c'; then $(CYGPATH_W) 'rewrite.c'; else $(CYGPATH_W) '$(srcdir)/rewrite.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-rewrite.Tpo $(DEPDIR)/avram-rewrite.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='rewrite.c' object='avram-rewrite.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-rewrite.obj `if test -f 'rewrite.c'; then $(CYGPATH_W) 'rewrite.c'; else $(CYGPATH_W) '$(srcdir)/rewrite.c'; fi`
 
-
 
-avram-exf.o: exf.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-exf.o -MD -MP -MF $(DEPDIR)/avram-exf.Tpo -c -o avram-exf.o `test -f 'exf.c' || echo '$(srcdir)/'`exf.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-exf.Tpo $(DEPDIR)/avram-exf.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='exf.c' object='avram-exf.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-exf.o `test -f 'exf.c' || echo '$(srcdir)/'`exf.c
 
-
 
-avram-exf.obj: exf.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-exf.obj -MD -MP -MF $(DEPDIR)/avram-exf.Tpo -c -o avram-exf.obj `if test -f 'exf.c'; then $(CYGPATH_W) 'exf.c'; else $(CYGPATH_W) '$(srcdir)/exf.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-exf.Tpo $(DEPDIR)/avram-exf.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='exf.c' object='avram-exf.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-exf.obj `if test -f 'exf.c'; then $(CYGPATH_W) 'exf.c'; else $(CYGPATH_W) '$(srcdir)/exf.c'; fi`
 
-
 
-avram-mathlib.o: mathlib.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-mathlib.o -MD -MP -MF $(DEPDIR)/avram-mathlib.Tpo -c -o avram-mathlib.o `test -f 'mathlib.c' || echo '$(srcdir)/'`mathlib.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-mathlib.Tpo $(DEPDIR)/avram-mathlib.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='mathlib.c' object='avram-mathlib.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-mathlib.o `test -f 'mathlib.c' || echo '$(srcdir)/'`mathlib.c
 
-
 
-avram-mathlib.obj: mathlib.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-mathlib.obj -MD -MP -MF $(DEPDIR)/avram-mathlib.Tpo -c -o avram-mathlib.obj `if test -f 'mathlib.c'; then $(CYGPATH_W) 'mathlib.c'; else $(CYGPATH_W) '$(srcdir)/mathlib.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-mathlib.Tpo $(DEPDIR)/avram-mathlib.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='mathlib.c' object='avram-mathlib.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-mathlib.obj `if test -f 'mathlib.c'; then $(CYGPATH_W) 'mathlib.c'; else $(CYGPATH_W) '$(srcdir)/mathlib.c'; fi`
 
-
 
-avram-complexlib.o: complexlib.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-complexlib.o -MD -MP -MF $(DEPDIR)/avram-complexlib.Tpo -c -o avram-complexlib.o `test -f 'complexlib.c' || echo '$(srcdir)/'`complexlib.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-complexlib.Tpo $(DEPDIR)/avram-complexlib.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='complexlib.c' object='avram-complexlib.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-complexlib.o `test -f 'complexlib.c' || echo '$(srcdir)/'`complexlib.c
 
-
 
-avram-complexlib.obj: complexlib.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-complexlib.obj -MD -MP -MF $(DEPDIR)/avram-complexlib.Tpo -c -o avram-complexlib.obj `if test -f 'complexlib.c'; then $(CYGPATH_W) 'complexlib.c'; else $(CYGPATH_W) '$(srcdir)/complexlib.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-complexlib.Tpo $(DEPDIR)/avram-complexlib.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='complexlib.c' object='avram-complexlib.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-complexlib.obj `if test -f 'complexlib.c'; then $(CYGPATH_W) 'complexlib.c'; else $(CYGPATH_W) '$(srcdir)/complexlib.c'; fi`
 
-
 
-avram-rmathlib.o: rmathlib.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-rmathlib.o -MD -MP -MF $(DEPDIR)/avram-rmathlib.Tpo -c -o avram-rmathlib.o `test -f 'rmathlib.c' || echo '$(srcdir)/'`rmathlib.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-rmathlib.Tpo $(DEPDIR)/avram-rmathlib.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='rmathlib.c' object='avram-rmathlib.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-rmathlib.o `test -f 'rmathlib.c' || echo '$(srcdir)/'`rmathlib.c
 
-
 
-avram-rmathlib.obj: rmathlib.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-rmathlib.obj -MD -MP -MF $(DEPDIR)/avram-rmathlib.Tpo -c -o avram-rmathlib.obj `if test -f 'rmathlib.c'; then $(CYGPATH_W) 'rmathlib.c'; else $(CYGPATH_W) '$(srcdir)/rmathlib.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-rmathlib.Tpo $(DEPDIR)/avram-rmathlib.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='rmathlib.c' object='avram-rmathlib.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-rmathlib.obj `if test -f 'rmathlib.c'; then $(CYGPATH_W) 'rmathlib.c'; else $(CYGPATH_W) '$(srcdir)/rmathlib.c'; fi`
 
-
 
-avram-mtwist.o: mtwist.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-mtwist.o -MD -MP -MF $(DEPDIR)/avram-mtwist.Tpo -c -o avram-mtwist.o `test -f 'mtwist.c' || echo '$(srcdir)/'`mtwist.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-mtwist.Tpo $(DEPDIR)/avram-mtwist.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='mtwist.c' object='avram-mtwist.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-mtwist.o `test -f 'mtwist.c' || echo '$(srcdir)/'`mtwist.c
 
-
 
-avram-mtwist.obj: mtwist.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-mtwist.obj -MD -MP -MF $(DEPDIR)/avram-mtwist.Tpo -c -o avram-mtwist.obj `if test -f 'mtwist.c'; then $(CYGPATH_W) 'mtwist.c'; else $(CYGPATH_W) '$(srcdir)/mtwist.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-mtwist.Tpo $(DEPDIR)/avram-mtwist.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='mtwist.c' object='avram-mtwist.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-mtwist.obj `if test -f 'mtwist.c'; then $(CYGPATH_W) 'mtwist.c'; else $(CYGPATH_W) '$(srcdir)/mtwist.c'; fi`
 
-
 
-avram-gslintlib.o: gslintlib.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-gslintlib.o -MD -MP -MF $(DEPDIR)/avram-gslintlib.Tpo -c -o avram-gslintlib.o `test -f 'gslintlib.c' || echo '$(srcdir)/'`gslintlib.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-gslintlib.Tpo $(DEPDIR)/avram-gslintlib.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='gslintlib.c' object='avram-gslintlib.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-gslintlib.o `test -f 'gslintlib.c' || echo '$(srcdir)/'`gslintlib.c
 
-
 
-avram-gslintlib.obj: gslintlib.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-gslintlib.obj -MD -MP -MF $(DEPDIR)/avram-gslintlib.Tpo -c -o avram-gslintlib.obj `if test -f 'gslintlib.c'; then $(CYGPATH_W) 'gslintlib.c'; else $(CYGPATH_W) '$(srcdir)/gslintlib.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-gslintlib.Tpo $(DEPDIR)/avram-gslintlib.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='gslintlib.c' object='avram-gslintlib.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-gslintlib.obj `if test -f 'gslintlib.c'; then $(CYGPATH_W) 'gslintlib.c'; else $(CYGPATH_W) '$(srcdir)/gslintlib.c'; fi`
 
-
 
-avram-gsldiflib.o: gsldiflib.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-gsldiflib.o -MD -MP -MF $(DEPDIR)/avram-gsldiflib.Tpo -c -o avram-gsldiflib.o `test -f 'gsldiflib.c' || echo '$(srcdir)/'`gsldiflib.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-gsldiflib.Tpo $(DEPDIR)/avram-gsldiflib.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='gsldiflib.c' object='avram-gsldiflib.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-gsldiflib.o `test -f 'gsldiflib.c' || echo '$(srcdir)/'`gsldiflib.c
 
-
 
-avram-gsldiflib.obj: gsldiflib.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-gsldiflib.obj -MD -MP -MF $(DEPDIR)/avram-gsldiflib.Tpo -c -o avram-gsldiflib.obj `if test -f 'gsldiflib.c'; then $(CYGPATH_W) 'gsldiflib.c'; else $(CYGPATH_W) '$(srcdir)/gsldiflib.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-gsldiflib.Tpo $(DEPDIR)/avram-gsldiflib.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='gsldiflib.c' object='avram-gsldiflib.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-gsldiflib.obj `if test -f 'gsldiflib.c'; then $(CYGPATH_W) 'gsldiflib.c'; else $(CYGPATH_W) '$(srcdir)/gsldiflib.c'; fi`
 
-
 
-avram-gslevu.o: gslevu.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-gslevu.o -MD -MP -MF $(DEPDIR)/avram-gslevu.Tpo -c -o avram-gslevu.o `test -f 'gslevu.c' || echo '$(srcdir)/'`gslevu.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-gslevu.Tpo $(DEPDIR)/avram-gslevu.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='gslevu.c' object='avram-gslevu.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-gslevu.o `test -f 'gslevu.c' || echo '$(srcdir)/'`gslevu.c
 
-
 
-avram-gslevu.obj: gslevu.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-gslevu.obj -MD -MP -MF $(DEPDIR)/avram-gslevu.Tpo -c -o avram-gslevu.obj `if test -f 'gslevu.c'; then $(CYGPATH_W) 'gslevu.c'; else $(CYGPATH_W) '$(srcdir)/gslevu.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-gslevu.Tpo $(DEPDIR)/avram-gslevu.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='gslevu.c' object='avram-gslevu.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-gslevu.obj `if test -f 'gslevu.c'; then $(CYGPATH_W) 'gslevu.c'; else $(CYGPATH_W) '$(srcdir)/gslevu.c'; fi`
 
-
 
-avram-glpklib.o: glpklib.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-glpklib.o -MD -MP -MF $(DEPDIR)/avram-glpklib.Tpo -c -o avram-glpklib.o `test -f 'glpklib.c' || echo '$(srcdir)/'`glpklib.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-glpklib.Tpo $(DEPDIR)/avram-glpklib.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='glpklib.c' object='avram-glpklib.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-glpklib.o `test -f 'glpklib.c' || echo '$(srcdir)/'`glpklib.c
 
-
 
-avram-glpklib.obj: glpklib.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-glpklib.obj -MD -MP -MF $(DEPDIR)/avram-glpklib.Tpo -c -o avram-glpklib.obj `if test -f 'glpklib.c'; then $(CYGPATH_W) 'glpklib.c'; else $(CYGPATH_W) '$(srcdir)/glpklib.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-glpklib.Tpo $(DEPDIR)/avram-glpklib.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='glpklib.c' object='avram-glpklib.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-glpklib.obj `if test -f 'glpklib.c'; then $(CYGPATH_W) 'glpklib.c'; else $(CYGPATH_W) '$(srcdir)/glpklib.c'; fi`
 
-
 
-avram-umf.o: umf.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-umf.o -MD -MP -MF $(DEPDIR)/avram-umf.Tpo -c -o avram-umf.o `test -f 'umf.c' || echo '$(srcdir)/'`umf.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-umf.Tpo $(DEPDIR)/avram-umf.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='umf.c' object='avram-umf.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-umf.o `test -f 'umf.c' || echo '$(srcdir)/'`umf.c
 
-
 
-avram-umf.obj: umf.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-umf.obj -MD -MP -MF $(DEPDIR)/avram-umf.Tpo -c -o avram-umf.obj `if test -f 'umf.c'; then $(CYGPATH_W) 'umf.c'; else $(CYGPATH_W) '$(srcdir)/umf.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-umf.Tpo $(DEPDIR)/avram-umf.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='umf.c' object='avram-umf.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-umf.obj `if test -f 'umf.c'; then $(CYGPATH_W) 'umf.c'; else $(CYGPATH_W) '$(srcdir)/umf.c'; fi`
 
-
 
-avram-mpfr.o: mpfr.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-mpfr.o -MD -MP -MF $(DEPDIR)/avram-mpfr.Tpo -c -o avram-mpfr.o `test -f 'mpfr.c' || echo '$(srcdir)/'`mpfr.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-mpfr.Tpo $(DEPDIR)/avram-mpfr.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='mpfr.c' object='avram-mpfr.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-mpfr.o `test -f 'mpfr.c' || echo '$(srcdir)/'`mpfr.c
 
-
 
-avram-mpfr.obj: mpfr.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-mpfr.obj -MD -MP -MF $(DEPDIR)/avram-mpfr.Tpo -c -o avram-mpfr.obj `if test -f 'mpfr.c'; then $(CYGPATH_W) 'mpfr.c'; else $(CYGPATH_W) '$(srcdir)/mpfr.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-mpfr.Tpo $(DEPDIR)/avram-mpfr.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='mpfr.c' object='avram-mpfr.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-mpfr.obj `if test -f 'mpfr.c'; then $(CYGPATH_W) 'mpfr.c'; else $(CYGPATH_W) '$(srcdir)/mpfr.c'; fi`
 
-
 
-avram-lapack.o: lapack.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-lapack.o -MD -MP -MF $(DEPDIR)/avram-lapack.Tpo -c -o avram-lapack.o `test -f 'lapack.c' || echo '$(srcdir)/'`lapack.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-lapack.Tpo $(DEPDIR)/avram-lapack.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='lapack.c' object='avram-lapack.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-lapack.o `test -f 'lapack.c' || echo '$(srcdir)/'`lapack.c
 
-
 
-avram-lapack.obj: lapack.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-lapack.obj -MD -MP -MF $(DEPDIR)/avram-lapack.Tpo -c -o avram-lapack.obj `if test -f 'lapack.c'; then $(CYGPATH_W) 'lapack.c'; else $(CYGPATH_W) '$(srcdir)/lapack.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-lapack.Tpo $(DEPDIR)/avram-lapack.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='lapack.c' object='avram-lapack.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-lapack.obj `if test -f 'lapack.c'; then $(CYGPATH_W) 'lapack.c'; else $(CYGPATH_W) '$(srcdir)/lapack.c'; fi`
 
-
 
-avram-fftw.o: fftw.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-fftw.o -MD -MP -MF $(DEPDIR)/avram-fftw.Tpo -c -o avram-fftw.o `test -f 'fftw.c' || echo '$(srcdir)/'`fftw.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-fftw.Tpo $(DEPDIR)/avram-fftw.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='fftw.c' object='avram-fftw.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-fftw.o `test -f 'fftw.c' || echo '$(srcdir)/'`fftw.c
 
-
 
-avram-fftw.obj: fftw.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-fftw.obj -MD -MP -MF $(DEPDIR)/avram-fftw.Tpo -c -o avram-fftw.obj `if test -f 'fftw.c'; then $(CYGPATH_W) 'fftw.c'; else $(CYGPATH_W) '$(srcdir)/fftw.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-fftw.Tpo $(DEPDIR)/avram-fftw.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='fftw.c' object='avram-fftw.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-fftw.obj `if test -f 'fftw.c'; then $(CYGPATH_W) 'fftw.c'; else $(CYGPATH_W) '$(srcdir)/fftw.c'; fi`
 
-
 
-avram-minpack.o: minpack.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-minpack.o -MD -MP -MF $(DEPDIR)/avram-minpack.Tpo -c -o avram-minpack.o `test -f 'minpack.c' || echo '$(srcdir)/'`minpack.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-minpack.Tpo $(DEPDIR)/avram-minpack.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='minpack.c' object='avram-minpack.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-minpack.o `test -f 'minpack.c' || echo '$(srcdir)/'`minpack.c
 
-
 
-avram-minpack.obj: minpack.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-minpack.obj -MD -MP -MF $(DEPDIR)/avram-minpack.Tpo -c -o avram-minpack.obj `if test -f 'minpack.c'; then $(CYGPATH_W) 'minpack.c'; else $(CYGPATH_W) '$(srcdir)/minpack.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-minpack.Tpo $(DEPDIR)/avram-minpack.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='minpack.c' object='avram-minpack.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-minpack.obj `if test -f 'minpack.c'; then $(CYGPATH_W) 'minpack.c'; else $(CYGPATH_W) '$(srcdir)/minpack.c'; fi`
 
-
 
-avram-kinsol.o: kinsol.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-kinsol.o -MD -MP -MF $(DEPDIR)/avram-kinsol.Tpo -c -o avram-kinsol.o `test -f 'kinsol.c' || echo '$(srcdir)/'`kinsol.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-kinsol.Tpo $(DEPDIR)/avram-kinsol.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='kinsol.c' object='avram-kinsol.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-kinsol.o `test -f 'kinsol.c' || echo '$(srcdir)/'`kinsol.c
 
-
 
-avram-kinsol.obj: kinsol.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-kinsol.obj -MD -MP -MF $(DEPDIR)/avram-kinsol.Tpo -c -o avram-kinsol.obj `if test -f 'kinsol.c'; then $(CYGPATH_W) 'kinsol.c'; else $(CYGPATH_W) '$(srcdir)/kinsol.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-kinsol.Tpo $(DEPDIR)/avram-kinsol.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='kinsol.c' object='avram-kinsol.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-kinsol.obj `if test -f 'kinsol.c'; then $(CYGPATH_W) 'kinsol.c'; else $(CYGPATH_W) '$(srcdir)/kinsol.c'; fi`
 
-
 
-avram-libfuns.o: libfuns.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-libfuns.o -MD -MP -MF $(DEPDIR)/avram-libfuns.Tpo -c -o avram-libfuns.o `test -f 'libfuns.c' || echo '$(srcdir)/'`libfuns.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-libfuns.Tpo $(DEPDIR)/avram-libfuns.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='libfuns.c' object='avram-libfuns.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-libfuns.o `test -f 'libfuns.c' || echo '$(srcdir)/'`libfuns.c
 
-
 
-avram-libfuns.obj: libfuns.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-libfuns.obj -MD -MP -MF $(DEPDIR)/avram-libfuns.Tpo -c -o avram-libfuns.obj `if test -f 'libfuns.c'; then $(CYGPATH_W) 'libfuns.c'; else $(CYGPATH_W) '$(srcdir)/libfuns.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-libfuns.Tpo $(DEPDIR)/avram-libfuns.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='libfuns.c' object='avram-libfuns.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-libfuns.obj `if test -f 'libfuns.c'; then $(CYGPATH_W) 'libfuns.c'; else $(CYGPATH_W) '$(srcdir)/libfuns.c'; fi`
 
-
 
-avram-mwrap.o: mwrap.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-mwrap.o -MD -MP -MF $(DEPDIR)/avram-mwrap.Tpo -c -o avram-mwrap.o `test -f 'mwrap.c' || echo '$(srcdir)/'`mwrap.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-mwrap.Tpo $(DEPDIR)/avram-mwrap.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='mwrap.c' object='avram-mwrap.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-mwrap.o `test -f 'mwrap.c' || echo '$(srcdir)/'`mwrap.c
 
-
 
-avram-mwrap.obj: mwrap.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-mwrap.obj -MD -MP -MF $(DEPDIR)/avram-mwrap.Tpo -c -o avram-mwrap.obj `if test -f 'mwrap.c'; then $(CYGPATH_W) 'mwrap.c'; else $(CYGPATH_W) '$(srcdir)/mwrap.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-mwrap.Tpo $(DEPDIR)/avram-mwrap.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='mwrap.c' object='avram-mwrap.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-mwrap.obj `if test -f 'mwrap.c'; then $(CYGPATH_W) 'mwrap.c'; else $(CYGPATH_W) '$(srcdir)/mwrap.c'; fi`
 
-
 
-avram-bes.o: bes.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-bes.o -MD -MP -MF $(DEPDIR)/avram-bes.Tpo -c -o avram-bes.o `test -f 'bes.c' || echo '$(srcdir)/'`bes.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-bes.Tpo $(DEPDIR)/avram-bes.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='bes.c' object='avram-bes.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-bes.o `test -f 'bes.c' || echo '$(srcdir)/'`bes.c
 
-
 
-avram-bes.obj: bes.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-bes.obj -MD -MP -MF $(DEPDIR)/avram-bes.Tpo -c -o avram-bes.obj `if test -f 'bes.c'; then $(CYGPATH_W) 'bes.c'; else $(CYGPATH_W) '$(srcdir)/bes.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-bes.Tpo $(DEPDIR)/avram-bes.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='bes.c' object='avram-bes.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-bes.obj `if test -f 'bes.c'; then $(CYGPATH_W) 'bes.c'; else $(CYGPATH_W) '$(srcdir)/bes.c'; fi`
 
-
 
-avram-lpsolve.o: lpsolve.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-lpsolve.o -MD -MP -MF $(DEPDIR)/avram-lpsolve.Tpo -c -o avram-lpsolve.o `test -f 'lpsolve.c' || echo '$(srcdir)/'`lpsolve.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-lpsolve.Tpo $(DEPDIR)/avram-lpsolve.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='lpsolve.c' object='avram-lpsolve.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-lpsolve.o `test -f 'lpsolve.c' || echo '$(srcdir)/'`lpsolve.c
 
-
 
-avram-lpsolve.obj: lpsolve.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-lpsolve.obj -MD -MP -MF $(DEPDIR)/avram-lpsolve.Tpo -c -o avram-lpsolve.obj `if test -f 'lpsolve.c'; then $(CYGPATH_W) 'lpsolve.c'; else $(CYGPATH_W) '$(srcdir)/lpsolve.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-lpsolve.Tpo $(DEPDIR)/avram-lpsolve.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='lpsolve.c' object='avram-lpsolve.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-lpsolve.obj `if test -f 'lpsolve.c'; then $(CYGPATH_W) 'lpsolve.c'; else $(CYGPATH_W) '$(srcdir)/lpsolve.c'; fi`
 
-
 
-avram-harminv.o: harminv.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-harminv.o -MD -MP -MF $(DEPDIR)/avram-harminv.Tpo -c -o avram-harminv.o `test -f 'harminv.c' || echo '$(srcdir)/'`harminv.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-harminv.Tpo $(DEPDIR)/avram-harminv.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='harminv.c' object='avram-harminv.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-harminv.o `test -f 'harminv.c' || echo '$(srcdir)/'`harminv.c
 
-
 
-avram-harminv.obj: harminv.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-harminv.obj -MD -MP -MF $(DEPDIR)/avram-harminv.Tpo -c -o avram-harminv.obj `if test -f 'harminv.c'; then $(CYGPATH_W) 'harminv.c'; else $(CYGPATH_W) '$(srcdir)/harminv.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-harminv.Tpo $(DEPDIR)/avram-harminv.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='harminv.c' object='avram-harminv.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-harminv.obj `if test -f 'harminv.c'; then $(CYGPATH_W) 'harminv.c'; else $(CYGPATH_W) '$(srcdir)/harminv.c'; fi`
 
-
 
-avram-remote.o: remote.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-remote.o -MD -MP -MF $(DEPDIR)/avram-remote.Tpo -c -o avram-remote.o `test -f 'remote.c' || echo '$(srcdir)/'`remote.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-remote.Tpo $(DEPDIR)/avram-remote.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='remote.c' object='avram-remote.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-remote.o `test -f 'remote.c' || echo '$(srcdir)/'`remote.c
 
-
 
-avram-remote.obj: remote.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-remote.obj -MD -MP -MF $(DEPDIR)/avram-remote.Tpo -c -o avram-remote.obj `if test -f 'remote.c'; then $(CYGPATH_W) 'remote.c'; else $(CYGPATH_W) '$(srcdir)/remote.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-remote.Tpo $(DEPDIR)/avram-remote.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='remote.c' object='avram-remote.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-remote.obj `if test -f 'remote.c'; then $(CYGPATH_W) 'remote.c'; else $(CYGPATH_W) '$(srcdir)/remote.c'; fi`
 
-
 
-avram-servlist.o: servlist.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-servlist.o -MD -MP -MF $(DEPDIR)/avram-servlist.Tpo -c -o avram-servlist.o `test -f 'servlist.c' || echo '$(srcdir)/'`servlist.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-servlist.Tpo $(DEPDIR)/avram-servlist.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='servlist.c' object='avram-servlist.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-servlist.o `test -f 'servlist.c' || echo '$(srcdir)/'`servlist.c
 
-
 
-avram-servlist.obj: servlist.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-servlist.obj -MD -MP -MF $(DEPDIR)/avram-servlist.Tpo -c -o avram-servlist.obj `if test -f 'servlist.c'; then $(CYGPATH_W) 'servlist.c'; else $(CYGPATH_W) '$(srcdir)/servlist.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-servlist.Tpo $(DEPDIR)/avram-servlist.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='servlist.c' object='avram-servlist.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-servlist.obj `if test -f 'servlist.c'; then $(CYGPATH_W) 'servlist.c'; else $(CYGPATH_W) '$(srcdir)/servlist.c'; fi`
 
-
 
-avram-jobs.o: jobs.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-jobs.o -MD -MP -MF $(DEPDIR)/avram-jobs.Tpo -c -o avram-jobs.o `test -f 'jobs.c' || echo '$(srcdir)/'`jobs.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-jobs.Tpo $(DEPDIR)/avram-jobs.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='jobs.c' object='avram-jobs.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-jobs.o `test -f 'jobs.c' || echo '$(srcdir)/'`jobs.c
 
-
 
-avram-jobs.obj: jobs.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-jobs.obj -MD -MP -MF $(DEPDIR)/avram-jobs.Tpo -c -o avram-jobs.obj `if test -f 'jobs.c'; then $(CYGPATH_W) 'jobs.c'; else $(CYGPATH_W) '$(srcdir)/jobs.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-jobs.Tpo $(DEPDIR)/avram-jobs.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='jobs.c' object='avram-jobs.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-jobs.obj `if test -f 'jobs.c'; then $(CYGPATH_W) 'jobs.c'; else $(CYGPATH_W) '$(srcdir)/jobs.c'; fi`
 
-
 
-avram-farms.o: farms.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-farms.o -MD -MP -MF $(DEPDIR)/avram-farms.Tpo -c -o avram-farms.o `test -f 'farms.c' || echo '$(srcdir)/'`farms.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-farms.Tpo $(DEPDIR)/avram-farms.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='farms.c' object='avram-farms.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-farms.o `test -f 'farms.c' || echo '$(srcdir)/'`farms.c
 
-
 
-avram-farms.obj: farms.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-farms.obj -MD -MP -MF $(DEPDIR)/avram-farms.Tpo -c -o avram-farms.obj `if test -f 'farms.c'; then $(CYGPATH_W) 'farms.c'; else $(CYGPATH_W) '$(srcdir)/farms.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-farms.Tpo $(DEPDIR)/avram-farms.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='farms.c' object='avram-farms.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-farms.obj `if test -f 'farms.c'; then $(CYGPATH_W) 'farms.c'; else $(CYGPATH_W) '$(srcdir)/farms.c'; fi`
 
-
 
-avram-vglue.o: vglue.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-vglue.o -MD -MP -MF $(DEPDIR)/avram-vglue.Tpo -c -o avram-vglue.o `test -f 'vglue.c' || echo '$(srcdir)/'`vglue.c
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-vglue.Tpo $(DEPDIR)/avram-vglue.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='vglue.c' object='avram-vglue.o' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-vglue.o `test -f 'vglue.c' || echo '$(srcdir)/'`vglue.c
 
-
 
-avram-vglue.obj: vglue.c
 
-@am__fastdepCC_TRUE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -MT avram-vglue.obj -MD -MP -MF $(DEPDIR)/avram-vglue.Tpo -c -o avram-vglue.obj `if test -f 'vglue.c'; then $(CYGPATH_W) 'vglue.c'; else $(CYGPATH_W) '$(srcdir)/vglue.c'; fi`
 
-@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/avram-vglue.Tpo $(DEPDIR)/avram-vglue.Po
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='vglue.c' object='avram-vglue.obj' libtool=no @AMDEPBACKSLASH@
 
-@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 
-@am__fastdepCC_FALSE@	$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(avram_CFLAGS) $(CFLAGS) -c -o avram-vglue.obj `if test -f 'vglue.c'; then $(CYGPATH_W) 'vglue.c'; else $(CYGPATH_W) '$(srcdir)/vglue.c'; fi`
 
-
 
-ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
 
-	list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
 
-	unique=`for i in $$list; do \
 
-	    if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
 
-	  done | \
 
-	  $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
 
-	      END { if (nonempty) { for (i in files) print i; }; }'`; \
 
-	mkid -fID $$unique
 
-tags: TAGS
 
-
 
-TAGS:  $(HEADERS) $(SOURCES)  $(TAGS_DEPENDENCIES) \
 
-		$(TAGS_FILES) $(LISP)
 
-	set x; \
 
-	here=`pwd`; \
 
-	list='$(SOURCES) $(HEADERS)  $(LISP) $(TAGS_FILES)'; \
 
-	unique=`for i in $$list; do \
 
-	    if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
 
-	  done | \
 
-	  $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
 
-	      END { if (nonempty) { for (i in files) print i; }; }'`; \
 
-	shift; \
 
-	if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
 
-	  test -n "$$unique" || unique=$$empty_fix; \
 
-	  if test $$# -gt 0; then \
 
-	    $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
 
-	      "$$@" $$unique; \
 
-	  else \
 
-	    $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
 
-	      $$unique; \
 
-	  fi; \
 
-	fi
 
-ctags: CTAGS
 
-CTAGS:  $(HEADERS) $(SOURCES)  $(TAGS_DEPENDENCIES) \
 
-		$(TAGS_FILES) $(LISP)
 
-	list='$(SOURCES) $(HEADERS)  $(LISP) $(TAGS_FILES)'; \
 
-	unique=`for i in $$list; do \
 
-	    if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
 
-	  done | \
 
-	  $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
 
-	      END { if (nonempty) { for (i in files) print i; }; }'`; \
 
-	test -z "$(CTAGS_ARGS)$$unique" \
 
-	  || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
 
-	     $$unique
 
-
 
-GTAGS:
 
-	here=`$(am__cd) $(top_builddir) && pwd` \
 
-	  && $(am__cd) $(top_srcdir) \
 
-	  && gtags -i $(GTAGS_ARGS) "$$here"
 
-
 
-distclean-tags:
 
-	-rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
 
-
 
-distdir: $(DISTFILES)
 
-	@srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
 
-	topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
 
-	list='$(DISTFILES)'; \
 
-	  dist_files=`for file in $$list; do echo $$file; done | \
 
-	  sed -e "s|^$$srcdirstrip/||;t" \
 
-	      -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
 
-	case $$dist_files in \
 
-	  */*) $(MKDIR_P) `echo "$$dist_files" | \
 
-			   sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
 
-			   sort -u` ;; \
 
-	esac; \
 
-	for file in $$dist_files; do \
 
-	  if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
 
-	  if test -d $$d/$$file; then \
 
-	    dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
 
-	    if test -d "$(distdir)/$$file"; then \
 
-	      find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
 
-	    fi; \
 
-	    if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
 
-	      cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
 
-	      find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
 
-	    fi; \
 
-	    cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
 
-	  else \
 
-	    test -f "$(distdir)/$$file" \
 
-	    || cp -p $$d/$$file "$(distdir)/$$file" \
 
-	    || exit 1; \
 
-	  fi; \
 
-	done
 
-check-am: all-am
 
-check: check-am
 
-all-am: Makefile $(PROGRAMS)
 
-installdirs:
 
-	for dir in "$(DESTDIR)$(bindir)"; do \
 
-	  test -z "$$dir" || $(MKDIR_P) "$$dir"; \
 
-	done
 
-install: install-am
 
-install-exec: install-exec-am
 
-install-data: install-data-am
 
-uninstall: uninstall-am
 
-
 
-install-am: all-am
 
-	@$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
 
-
 
-installcheck: installcheck-am
 
-install-strip:
 
-	$(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
 
-	  install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
 
-	  `test -z '$(STRIP)' || \
 
-	    echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
 
-mostlyclean-generic:
 
-
 
-clean-generic:
 
-
 
-distclean-generic:
 
-	-test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
 
-	-test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
 
-
 
-maintainer-clean-generic:
 
-	@echo "This command is intended for maintainers to use"
 
-	@echo "it deletes files that may require special tools to rebuild."
 
-	-test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES)
 
-clean: clean-am
 
-
 
-clean-am: clean-binPROGRAMS clean-generic mostlyclean-am
 
-
 
-distclean: distclean-am
 
-	-rm -rf ./$(DEPDIR)
 
-	-rm -f Makefile
 
-distclean-am: clean-am distclean-compile distclean-generic \
 
-	distclean-tags
 
-
 
-dvi: dvi-am
 
-
 
-dvi-am:
 
-
 
-html: html-am
 
-
 
-html-am:
 
-
 
-info: info-am
 
-
 
-info-am:
 
-
 
-install-data-am:
 
-
 
-install-dvi: install-dvi-am
 
-
 
-install-dvi-am:
 
-
 
-install-exec-am: install-binPROGRAMS
 
-
 
-install-html: install-html-am
 
-
 
-install-html-am:
 
-
 
-install-info: install-info-am
 
-
 
-install-info-am:
 
-
 
-install-man:
 
-
 
-install-pdf: install-pdf-am
 
-
 
-install-pdf-am:
 
-
 
-install-ps: install-ps-am
 
-
 
-install-ps-am:
 
-
 
-installcheck-am:
 
-
 
-maintainer-clean: maintainer-clean-am
 
-	-rm -rf ./$(DEPDIR)
 
-	-rm -f Makefile
 
-maintainer-clean-am: distclean-am maintainer-clean-generic
 
-
 
-mostlyclean: mostlyclean-am
 
-
 
-mostlyclean-am: mostlyclean-compile mostlyclean-generic
 
-
 
-pdf: pdf-am
 
-
 
-pdf-am:
 
-
 
-ps: ps-am
 
-
 
-ps-am:
 
-
 
-uninstall-am: uninstall-binPROGRAMS
 
-
 
-.MAKE: install-am install-strip
 
-
 
-.PHONY: CTAGS GTAGS all all-am check check-am clean clean-binPROGRAMS \
 
-	clean-generic ctags distclean distclean-compile \
 
-	distclean-generic distclean-tags distdir dvi dvi-am html \
 
-	html-am info info-am install install-am install-binPROGRAMS \
 
-	install-data install-data-am install-dvi install-dvi-am \
 
-	install-exec install-exec-am install-html install-html-am \
 
-	install-info install-info-am install-man install-pdf \
 
-	install-pdf-am install-ps install-ps-am install-strip \
 
-	installcheck installcheck-am installdirs maintainer-clean \
 
-	maintainer-clean-generic mostlyclean mostlyclean-compile \
 
-	mostlyclean-generic pdf pdf-am ps ps-am tags uninstall \
 
-	uninstall-am uninstall-binPROGRAMS
 
-
 
-
 
-# Tell versions [3.59,3.63) of GNU make to not export all variables.
 
-# Otherwise a system limit (for SysV at least) may be exceeded.
 
-.NOEXPORT:

+ 0 - 706
src/apply.c
View File 

@@ -1,706 +0,0 @@
 
-
 
-/* contains the universal function and some supporting operations
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.  
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/vman.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/compare.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/libfuns.h>
 
-#include <avm/decons.h>
 
-#include <avm/instruct.h>
 
-#include <avm/portals.h>
 
-#include <avm/ports.h>
 
-#include <avm/profile.h>
 
-#include <avm/formout.h>
 
-#include <avm/exmodes.h>
 
-#include <avm/remote.h>
 
-#include <avm/apply.h>
 
-
 
-/* Non-zero means static variables have been initialized. */
 
-static int initialized = 0;
 
-
 
-/* This is the virtual code for a function that transforms arbitary
 
-   virtual code into that which employs only the combinators that are
 
-   known to the avm_apply function. */
 
-static list interpreter;
 
-
 
-/* These are all error messages represented as lists of lists of
 
-   character representations. */
 
-static list unsupported_hook;
 
-static list invalid_deconstruction;
 
-static list invalid_recursion;
 
-static list memory_overflow;
 
-static list reset;
 
-
 
-/* This is the current or emulated version number of avram represented
 
-   as a list of character representations. */
 
-static list avram_version_number;
 
-
 
-/* this message, when embedded in a program using the note combinator,
 
-   indicates that map and reduce combinators in the descendents should
 
-   be executed remotely if possible */
 
-static list parallel;
 
-static list nondeterministic;
 
-
 
-/* if a concurrent thread sets this, avm_apply will interrupt itself,
 
-   and so will avm_harvest */
 
-flag _avm_reset = 0;
 
-
 
-
 
-
 
-
 
-
 
-
 
-static counter
 
-exception (errors, additional_errors)
 
-     counter errors;
 
-     int additional_errors;
 
-
 
-     /* This adds to an error counter and checks for overflow. */
 
-{
 
-  counter result;
 
-
 
-  if (!additional_errors)
 
-    return (errors);
 
-  else if ((result = errors + additional_errors) < errors)
 
-    avm_error ("counter overflow (code 4)");
 
-  return (result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-dispatch (errors, result, client, next)
 
-     counter errors;
 
-     list result;
 
-     port client;
 
-     instruction *next;
 
-
 
-     /* This routine plugs a result into the appropriate port, joins
 
-        results of constructions, and chooses conditional
 
-        branches. The caller should regard the result parameter as
 
-        having been disposed of. */
 
-{
 
-  port old_client;
 
-  portal old;
 
-  int done;
 
-
 
-  if (done = !client)
 
-    avm_internal_error (7);
 
-  else
 
-    do
 
-      {
 
-	if (errors != client->errors)
 
-	  {
 
-	    if (client->predicating)
 
-	      {
 
-		if (!*next)
 
-		  avm_internal_error (8);
 
-		else
 
-		  {
 
-		    avm_sever (client);
 
-		    client = (*next)->client;
 
-		    avm_retire (next);
 
-		    avm_retire (next);
 
-		  }
 
-	      }
 
-	    else if (client->parent)
 
-	      {
 
-		if (!((client = (old_client = client)->parent)->descendents->left))
 
-		  avm_internal_error (9);
 
-		else if (old_client == client->descendents->left)
 
-		  avm_retire (next);
 
-		else
 
-		  avm_dispose (client->descendents->left->contents);
 
-		avm_sever (client->descendents->left);
 
-		avm_sever (client->descendents->right);
 
-	      }
 
-	    else if (*next)
 
-	      {
 
-		client = (*next)->client;
 
-		avm_retire (next);
 
-	      }
 
-	  }
 
-	if (errors != client->errors)
 
-	  {
 
-	    if (done = (*next ? 0 : !(client->parent)))
 
-	      {
 
-		client->contents = result;
 
-		client->errors = errors;
 
-	      }
 
-	  }
 
-	else if (done = client->predicating)
 
-	  {
 
-	    if (result)
 
-	      avm_dispose (result);
 
-	    else
 
-	      avm_reschedule (next);
 
-	    avm_retire (next);
 
-	    avm_sever (client);
 
-	  }
 
-	else
 
-	  {
 
-	    client->contents = result;
 
-	    if (client->impetus)
 
-	      {
 
-		if (client->impetus->interpretation)
 
-		  avm_internal_error (10);
 
-		client->impetus->interpretation = avm_copied (result);
 
-	      }
 
-	    if (!(done=!(client->parent ? (client == client->parent->descendents->right) : 0)))
 
-	      {
 
-		if (!((client=(old_client=client)->parent)->descendents->left)?errors!=client->descendents->left->errors:0)
 
-		  avm_internal_error (11);
 
-		if (!(result = avm_recoverable_join (client->descendents->left->contents, result)))
 
-		  {
 
-		    result = avm_copied (memory_overflow);
 
-		    errors = exception (errors, 1);
 
-		  }
 
-		avm_sever (client->descendents->left);
 
-		old = client->descendents;
 
-		client->descendents = old->alters;
 
-		avm_seal (old);
 
-		avm_sever (old_client);
 
-	      }
 
-	  }
 
-      }
 
-    while (!done);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_recoverable_apply (operator, operand, fault)
 
-     list operator;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* This routine computes the universal function, setting the
 
-        fault to true in the event of an exception. The function takes
 
-        the form of a big case statement, and operates on a stack of
 
-        instructions.  Each instruction has an operator and operand to
 
-        be evaluated together, and a pointer to a place to store the
 
-        result of the evaluation. The pointer will point to the result
 
-        field of some instruction below it in the stack, except in the
 
-        case of the bottom instruction, where it points to the result
 
-        to be returned, and in the case of a predicate to a
 
-        conditional combinator, which points to the bit bucket. The
 
-        form macro takes the top operator and decides what operation
 
-        it represents. If it can't be evaluated immediately, it is
 
-        broken up into smaller operations that are pushed onto the
 
-        stack. If the form of the operator is not recognized, it is
 
-        translated to a simpler form by applying the interpreter to
 
-        it, which is done by pushing the interpreter and the operator
 
-        onto the stack. If an operator was previously translated in
 
-        this way, the result of the translation might still be lying
 
-        around and will be reused. */
 
-{
 
-  list message;
 
-  port bit_bucket;
 
-  score new_sheet;
 
-  instruction current;
 
-  struct avm_packet result;
 
-  portal new_descendent;
 
-  int success, overflow;
 
-  flag balanceable;
 
-
 
-  enum forms
 
-  { INTERPRETIVE, CONSTANT, CONDITIONAL, COMPOSITION, CONSTRUCTION, GUARD,
 
-    DECONSTRUCT, REFER, RECUR, HOOK, COMPARATOR, RACE, REVERSE, HAVE, MAP, SORT,
 
-    CONCATENATE, DISTRIBUTE, TRANSPOSE, PROFILE, NOTE, WEIGHT, MEMBER, KNOWN, REDUCE,
 
-    DECONSTRUCT_LEFT, DECONSTRUCT_RIGHT, IDENTITY, LIBRARY, VERSION_NUMBER, INTERACTIVE
 
-  };
 
-
 
-#define rex current->remotely_executable
 
-#define gr current->granularity
 
-#define ba current->non_deterministic
 
-#define elevel current->datum.errors
 
-#define program current->actor.contents
 
-#define pointer program->tail
 
-#define false_branch program->tail
 
-#define failure exception(elevel,1)
 
-#define predicate program->head->head
 
-#define exception_handler program->tail
 
-#define true_branch program->head->tail
 
-#define right_side program->tail
 
-#define next (current->dependents)
 
-#define constant_value program->head->tail
 
-#define destination current->client
 
-#define left_compositor program->head->head
 
-#define right_compositor program->head->tail
 
-#define player program->tail->tail->tail->head->head
 
-#define noted_operator program->tail->tail->tail->tail->head
 
-#define notation program->tail->tail->tail->tail->tail
 
-#define team program->tail->tail->tail->head->tail
 
-#define left_side program->head->head
 
-#define guarded_operator program->head->tail
 
-#define recurrence program->head->head->tail
 
-#define reference program->head->head->head
 
-#define left_racer program->tail->tail->head
 
-#define right_racer program->tail->tail->tail
 
-#define library_name program->tail->head->head
 
-#define function_name program->tail->head->tail
 
-#define have_library_name program->tail->head->tail
 
-#define have_function_name program->tail->tail->tail
 
-#define robot program->tail->tail->head->tail
 
-#define argument (current->datum.contents)
 
-#define game current->sheet
 
-#define left_deconstruction (argument?avm_copied(argument->head):avm_copied(invalid_deconstruction))
 
-#define right_deconstruction (argument?avm_copied(argument->tail):avm_copied(invalid_deconstruction))
 
-#define mapped_function program->tail->head->tail
 
-#define reduced_function program->tail->head->head
 
-#define vacuous_case program->tail->head->tail
 
-#define sorting_predicate program->tail->head->head
 
-
 
-#define form(o) o?(\
 
-   o->interpretation?\
 
-      KNOWN:\
 
-      o->head?(\
 
-         o->tail?(\
 
-            o->head->head?(\
 
-               o->head->tail?\
 
-                  CONDITIONAL:\
 
-                  CONSTRUCTION):\
 
-               o->head->tail?\
 
-                  GUARD:\
 
-                  o->tail->head?(\
 
-                     o->tail->tail?(\
 
-                        o->tail->head->head?(\
 
-                           o->tail->head->tail?(\
 
-                              o->tail->tail->head?\
 
-                                 INTERPRETIVE:\
 
-                                 o->tail->tail->tail?\
 
-                                    INTERPRETIVE:\
 
-                                    LIBRARY):\
 
-                              o->tail->tail->head?(\
 
-                                 o->tail->tail->tail?\
 
-                                    INTERPRETIVE:\
 
-                                    o->tail->head->head->head?\
 
-                                       INTERPRETIVE:\
 
-                                       o->tail->head->head->tail?\
 
-                                          INTERPRETIVE:\
 
-                                          o->tail->tail->head->head?\
 
-                                             INTERPRETIVE:\
 
-                                             o->tail->tail->head->tail?\
 
-                                                INTERACTIVE:\
 
-                                                INTERPRETIVE):\
 
-                                 o->tail->tail->tail?\
 
-                                    INTERPRETIVE:\
 
-                                    o->tail->head->tail?\
 
-                                       INTERPRETIVE:\
 
-                                       SORT):\
 
-                           o->tail->head->tail?(\
 
-                              o->tail->tail->head?\
 
-                                 INTERPRETIVE:\
 
-                                 o->tail->tail->tail?\
 
-                                    HAVE:\
 
-                                    INTERPRETIVE):\
 
-                              o->tail->tail->head?(\
 
-                                 o->tail->tail->tail?\
 
-                                    RACE:\
 
-                                    INTERPRETIVE):\
 
-                                 o->tail->tail->tail?(\
 
-                                    o->tail->tail->tail->head?(\
 
-                                       o->tail->tail->tail->head->head?\
 
-                                          PROFILE:\
 
-                                          o->tail->tail->tail->head->tail?\
 
-                                             HOOK:\
 
-                                             VERSION_NUMBER):\
 
-                                       o->tail->tail->tail->tail?(\
 
-                                          o->tail->tail->tail->tail->head?\
 
-                                             NOTE:\
 
-                                             HOOK):\
 
-                                          WEIGHT):\
 
-                                    TRANSPOSE):\
 
-		        o->tail->head->head?\
 
-                           REDUCE:\
 
-                           o->tail->head->tail?\
 
-                              MAP:\
 
-			      MEMBER):		\
 
-                     o->tail->tail?(\
 
-                        o->tail->tail->head?\
 
-                           INTERPRETIVE:\
 
-                           o->tail->tail->tail?\
 
-                              INTERPRETIVE:\
 
-                              REVERSE):\
 
-                        CONCATENATE):\
 
-            o->head->head?(\
 
-               o->head->tail?\
 
-                  COMPOSITION:\
 
-                  o->head->head->head?(\
 
-                     o->head->head->tail?\
 
-                        INTERPRETIVE:\
 
-                        REFER):\
 
-                     o->head->head->tail?\
 
-                        RECUR:\
 
-                        DISTRIBUTE):\
 
-               CONSTANT):\
 
-         o->tail?\
 
-            DECONSTRUCT:\
 
-            COMPARATOR):\
 
-   INTERPRETIVE
 
-
 
-  if (!initialized)
 
-    avm_initialize_apply ();
 
-  if (!operator)
 
-    avm_error ("empty operator");
 
-  current = NULL;
 
-  memset (&result, overflow = 0, sizeof (result));
 
-  success = avm_scheduled (operator, 0, operand, &result, &current, avm_entries (NULL, &message, fault), 0, 0, 0);
 
-  avm_dispose (operand);
 
-  avm_dispose (operator);
 
-  if (result.errors = *fault)
 
-    result.contents = avm_copied (message);
 
-  else if (result.errors = !(success ? success-- : 0))
 
-    result.contents = avm_copied (memory_overflow);
 
-  else
 
-      while (current)
 
-	{
 
-	  (game->reductions)++;
 
-	  switch (form (program))
 
-	    {
 
-	    case RACE:
 
-	    case HOOK: dispatch (failure, avm_copied (unsupported_hook), destination, &next);
 
-	      break;
 
-	    case CONSTANT: dispatch (elevel, avm_copied (constant_value), destination, &next);
 
-	      break;
 
-	    case VERSION_NUMBER: dispatch (elevel, avm_copied (avram_version_number), destination, &next);
 
-	      break;
 
-	    case KNOWN:
 
-	      overflow = ! avm_scheduled (program->interpretation, elevel, argument, destination, &next, game, rex, ba, gr);
 
-	      break;
 
-	    case REVERSE: message = avm_reversal (argument, fault);
 
-	      dispatch (exception (elevel, *fault), message, destination, &next);
 
-	      break;
 
-	    case INTERACTIVE: message = avm_recoverable_interact (robot, fault);
 
-	      dispatch (exception (elevel, *fault), message, destination, &next);
 
-	      break;
 
-	    case WEIGHT: message = avm_measurement (argument, fault);
 
-	      dispatch (exception (elevel, *fault), message, destination, &next);
 
-	      break;
 
-	    case DISTRIBUTE: message = avm_distribution (argument, fault);
 
-	      dispatch (exception (elevel, *fault), message, destination, &next);
 
-	      break;
 
-	    case DECONSTRUCT: message = avm_deconstruction (pointer, argument, fault);
 
-	      dispatch (exception (elevel, *fault), message, destination, &next);
 
-	      break;
 
-	    case CONCATENATE: message = avm_concatenation (argument, fault);
 
-	      dispatch (exception (elevel, *fault), message, destination, &next);
 
-	      break;
 
-	    case TRANSPOSE: message = avm_transposition (avm_copied (argument), fault);
 
-	      dispatch (exception (elevel, *fault), message, destination, &next);
 
-	      break;
 
-	    case MEMBER: message = avm_membership (argument, fault);
 
-	      dispatch (exception (elevel, *fault), message, destination, &next);
 
-	      break;
 
-	    case COMPARATOR: message = avm_comparison (argument, fault);
 
-	      dispatch (exception (elevel, *fault), message, destination,&next);
 
-	      break;
 
-	    case HAVE: message = avm_have_library_call (have_library_name, have_function_name, fault);
 
-	      dispatch (exception (elevel, *fault), message, destination, &next);
 
-	      break;
 
-	    case COMPOSITION: success = avm_scheduled (left_compositor, elevel, NULL, destination, &next, game, rex, ba, gr);
 
-	      success += avm_scheduled (right_compositor, elevel, argument, &(next->datum), &next, game, rex, ba, gr);
 
-	      overflow=(success < 2);
 
-	      break;
 
-	    case GUARD: success = avm_scheduled (exception_handler, failure, NULL, destination,&next, game, rex, ba, gr);
 
-	      success += avm_scheduled(guarded_operator, elevel, argument, &(next->datum), &next, game, rex, ba, gr);
 
-	      overflow=(success < 2);
 
-	      break;
 
-	    case REFER: if (!(overflow=!(message =avm_recoverable_join (avm_copied (reference), avm_copied (argument)))))
 
-		overflow = !avm_scheduled (reference, elevel, message, destination, &next, game, rex, ba, gr);
 
-	      avm_dispose (message);
 
-	      break;
 
-	    case MAP: if (current->remotely_executable)
 
-		{
 
-		  current->remotely_executable = 0;
 
-		  if (avm_remotely_mapped (mapped_function, argument, &message, current->granularity, fault))
 
-		    {
 
-		      dispatch (exception (elevel, *fault), message, destination, &next);
 
-		      break;
 
-		    }
 
-		}
 
-	    case REDUCE: if (current->remotely_executable)
 
-		{
 
-		  current->remotely_executable = 0;
 
-		  if (avm_remotely_reduced (reduced_function, vacuous_case, argument, &message, current->granularity, 
-					    current->non_deterministic, fault))
 
-		    {
 
-		      dispatch (exception (elevel, *fault), message, destination, &next);
 
-		      break;
 
-		    }
 
-		}
 
-	    case SORT: if (current->remotely_executable)
 
-		{
 
-		  current->remotely_executable = 0;
 
-		  if (avm_remotely_sorted (sorting_predicate, argument, &message, current->granularity, fault))
 
-		    {
 
-		      dispatch (exception (elevel, *fault), message, destination, &next);
 
-		      break;
 
-		    }
 
-		}
 
-	    case INTERPRETIVE: success = avm_scheduled (NULL, elevel, argument, destination, &next,game, rex, ba, gr);
 
-	      if (success ? (program->internal) : 0)
 
-		(next->actor.impetus = program)->facilitator = &(next->actor);
 
-	      overflow = ((success += avm_scheduled (interpreter, 0, program, &(next->actor), &next, game, rex, ba, gr)) < 2);
 
-	      break;
 
-	    case PROFILE: new_sheet = avm_entries (team, &message, fault);
 
-	      if (*fault)
 
-		dispatch (failure, avm_copied (message), destination, &next);
 
-	      else
 
-		overflow = !avm_scheduled (player, elevel, argument, destination, &next, new_sheet, rex, ba, gr);
 
-	      break;
 
-	    case CONDITIONAL: if (!(overflow = !(bit_bucket = avm_newport (elevel, NULL, 1))))
 
-		{
 
-		  success = avm_scheduled (true_branch, elevel, argument, destination, &next, game, rex, ba, gr);
 
-		  success += avm_scheduled (false_branch, elevel, argument, destination, &next, game, rex, ba, gr);
 
-		  success += avm_scheduled (predicate, elevel, argument, bit_bucket, &next, game, rex, ba, gr);
 
-		  if (overflow = (success < 3))
 
-		    avm_sever (bit_bucket);
 
-		}
 
-	      break;
 
-	    case LIBRARY: library_name->characterization = function_name->characterization = 0;
 
-	      if (program->characterization > 255)
 
-		{                                                                      /* avoid repeated lookups */
 
-		  library_name->characterization = program->characterization >> 8;
 
-		  function_name->characterization = program->characterization & 0xff;
 
-		}
 
-	      message = avm_library_call (library_name, function_name, argument, fault);
 
-	      program->characterization = (library_name->characterization << 8) | function_name->characterization;
 
-	      dispatch (exception (elevel, *fault), message, destination,&next);
 
-	      break;
 
-	    case RECUR: message = avm_deconstruction (recurrence, argument, fault);
 
-	      if (*fault ? 1 : !(message ? message->head : 0))
 
-		dispatch (failure, avm_copied (invalid_recursion),destination, &next);
 
-	      else
 
-		overflow = !avm_scheduled (message->head, elevel, message,destination, &next, game, rex, ba, gr);
 
-	      avm_dispose (message);
 
-	      break;
 
-	    case NOTE: 
-	      if (current->remotely_executable ? NULL : notation)
 
-		{
 
-		  message = avm_binary_comparison (notation->head, nondeterministic, fault);
 
-		  balanceable = ! ! message;
 
-		  message = (*fault ? message : message ? message : avm_binary_comparison (notation->head, parallel, fault));
 
-		  if (*fault)
 
-		    dispatch (exception (elevel, *fault), message, destination, &next);
 
-		  else if (message)
 
-		    {
 
-		      current->remotely_executable = 1;
 
-		      current->non_deterministic = balanceable;
 
-		      current->granularity = avm_counter (notation->tail);
 
-		      avm_dispose (message);
 
-		    }
 
-		}
 
-	      if (!overflow)
 
-		overflow = ! avm_scheduled (noted_operator, elevel, argument, destination, &next, game, rex, ba, gr);
 
-	      break;
 
-	    case CONSTRUCTION:
 
-	      if (current->remotely_executable)
 
-		{
 
-		  current->remotely_executable = 0;
 
-		  if (avm_remotely_constructed (left_side, right_side, argument, &message, fault))
 
-		    {
 
-		      dispatch (exception (elevel, *fault), message, destination, &next);
 
-		      break;
 
-		    }
 
-		}
 
-	      if (!(overflow = !(new_descendent = avm_new_portal (destination->descendents))))
 
-		{
 
-		  if (overflow = !(new_descendent->left = avm_newport (elevel, destination, 0)))
 
-		    avm_seal (new_descendent);
 
-		  else if (overflow = !(new_descendent->right = avm_newport (elevel, destination, 0)))
 
-		    {
 
-		      avm_sever (new_descendent->left);
 
-		      avm_seal (new_descendent);
 
-		    }
 
-		  else
 
-		    {
 
-		      success = avm_scheduled (right_side, elevel, argument, new_descendent->right, &next, game, rex, ba, gr);
 
-		      success += avm_scheduled (left_side, elevel, argument, new_descendent->left, &next, game, rex, ba, gr);
 
-		      if (!(overflow = (success < 2)))
 
-			destination->descendents = new_descendent;
 
-		      else
 
-			{
 
-			  avm_sever (new_descendent->left);
 
-			  avm_sever (new_descendent->right);
 
-			  avm_seal (new_descendent);
 
-			}
 
-		    }
 
-		}
 
-	      break;
 
-	    default: avm_internal_error (12);
 
-	    }
 
-	  if (_avm_reset)
 
-	    dispatch (failure, avm_copied (reset), destination, &next);
 
-	  else if (overflow ? overflow-- : 0)
 
-	    {
 
-	      while (success ? success-- : 0)
 
-		avm_retire (&next);
 
-	      dispatch (failure, avm_copied (memory_overflow), destination, &next);
 
-	    }
 
-	  avm_retire (&(current));
 
-	}
 
-  *fault = (*fault ? 1 : result.errors);
 
-  return (result.contents);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_apply (operator, operand)
 
-     list operator;
 
-     list operand;
 
-
 
-     /* This routine computes the universal function, printing an
 
-        error message and exiting in the event of an exception. This
 
-        is the one that's used by avram. */
 
-{
 
-  int fault;
 
-  list result;
 
-
 
-  fault = 0;
 
-  result = avm_recoverable_apply (operator, operand, &fault);
 
-  if (fault)
 
-    {
 
-      avm_output (stderr, "standard error", NULL, result, 0);
 
-      fprintf (stderr, "\n");
 
-      exit (EXIT_FAILURE);
 
-    }
 
-  return (result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_apply ()
 
-{
 
-
 
-#include "rewrite.c"
 
-
 
-  /* compatible with an old undocumented character set */
 
-
 
-char *olde_interpreter = "{jmxksShi_z{CkjmK_ZKyxno@soKx{y=NfkpoKmH{Iyl>EuoGwg\
 
-IoH[zrfZrYKwzYIs^z{[C`_xZrKin{ZsSIKfckjslk`itkmv{jnKHhpZPxxo<exskkqFiv@kfc^zK\
 
-KyGvrxP^zyx[CFityPqMiB<Hs`_Z>cfcswoyWOxxhyneuyPqNsn`skw]jXqDDs`ozgZ>criIZxvSJ\
 
-hlogiwTF[PbLU=nrFVzORiVpdGhGz<LcfOZgZXogiFziY=XXjrakRmvizMOEXmt<_{iZpzhoz]DGt\
 
-glegv`svkS@ohiGHyyIXXySOvJ^zeIyGpPtGxLkpNsMGX`]Hw\\g[Fb<D{^bkh^sqWslogqowrCIq\
 
-aTY\\M_NgZFVzyQGkFs\\gZ_lnI?Debg<BK\\GM>z<D{f`[rBgXrkZ_[hSOSS`[_{MYLO<Hs\\>Ky\
 
-RZmMZ?It@{sD]\\]`oN<kvlFsm>{@GyYW`[kLIaYC{FyTUN`LkqsogsXF>IxLkc{zaaP\\_ZDIuD`\
 
-`pd<Lc\\<Oz>ivDstvflGyAUCyTGyZLy`qtng[byQy?kSSXGz>i{vxoQGOcLktLzLL\\<it\\s\\O\
 
-zOEyY?NDsea>{gPf[ahAYMazl?IyNqJSfiCeSwNN>z=KxqOWjg\\FOtN>zgz<fk]?t\\s\\G[Jf\\\
 
-OEyNfcpW\\F[kPuNaYOQ\\_Z]BWSPen=E{pBB>it\\svjAUMLHoAN>it@Et>IvktLz`{yFZ<itd\\\
 
-evANg[oiyKn_gfblktQW_fMlMQoSiDBK]?y<oUj]<bL=_tivFZ=>Zgze>[RMxeKtfitpFO[n@yim[\
 
->XaLRuDGvyAX`QKyVkx><kvkv@X_O=N>sfiuFzGZ=>Z<e{zQQFLcleIx<egu=bqMwoSw<`g<FsoZE\
 
-h?K[kY=OIT@Et@ExY_ZJ]gt=GtfcFitivi{xYHl<FZ>bkl<_{TNjGwxUPnhp\\BK_oMFgyoIXydWB\
 
-RGZGZKcaoP<fZFsdFT=GvgZ?GyqR>Ffit<_zm>{X]Vg[=GS`Lb<>scle?X^yBghSqPHyGKvgZ{YQN\
 
-]tFZ?Itg>it=GtFcqEaAj?GxLk\\Fsv^@\\oZLu[\\nFsqFd`^IWLPgqz>HR\\=?Z<NzkiVfv[fet\
 
->cnlHs^itGZdQyIDFc\\gZ=KzoD>IvqqI<\\O[bd\\]_fU?zOILP\\FZFs_wfpQa@qONknc\\<>c\
 
-\\o[@s]arBB>s\\OzDIzt?>{t_gf^g[I@AYquOIW>_hitHsoNq@kqbg\\>gZNcnc\\F[E_yYYOHOZ\
 
-DItLzg>N>z=nI=<@sl]byD@rli>ULMIt>cooH^[yQLHd@k^_uF[FZ<Gz_fvdHbK]?vkyD<g[hFLNZ\
 
-qNqEEL^aR>o[F[QoFNzkff@<^ZFK^_uFZ@EunKD\\<Gzgz=>Z<=_xfNf[>@UjDxEL<euFZQVg^ivi\
 
-wO@gnOzFK^_tizlw>@Et@EtitFZMbFkLQWiPNnk>_viTP\\oZ?It^@fU`EvOzFKfixfnhGZGZfs^c\
 
-cNfGfy<mHnNe^_tONB>ItDs\\<h<iu`EvOz<NzL]>FivgZ<N{GZdE>fOZ>q><h`{^cHG{>{gEit>s\
 
-bLc^it^<Nz<NzFs^GZf<\\xp\\<hU>[XvN>zN>z<<Lxbs\\GZ?Ix^itgZ?IwHc^ExF<<G[op\\Fs\
 
-\\gZeT=?nWZ<et<oZ?It>c\\>k]PfeixcD\\BK\\Tz>Fc\\@KNc\\FZ<exev^Ybd\\@KGH<GZ>sh=\
 
->eUF[F[FZNcneoM>c]\\Bs\\euP>DdzNc`etdz>i><HH\\O{FZ`LdzFK^_tdzEHANLc^gtnOzFK^_\
 
-vO{HL<ixfc^U>Z`{eKu`EtNhc`>s\\>sbLcbLc\\GZ\\>c\\oZbs\\GZ<ivWZFc\\gX<Lxbseit=?\
 
-qFz=IfZ<Lx<LxetFKvn<LfRetFG@Et?LD\\\\]<Fy@MPfTp\\G>^l<<";
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  _avm_reset = 0;
 
-  avm_initialize_lists ();
 
-  avm_initialize_chrcodes ();
 
-  avm_initialize_compare ();
 
-  avm_initialize_listfuns ();
 
-  avm_initialize_libfuns ();
 
-  avm_initialize_decons ();
 
-  avm_initialize_instruct ();
 
-  avm_initialize_portals ();
 
-  avm_initialize_ports ();
 
-  avm_initialize_profile ();
 
-  avm_initialize_formout ();
 
-  avm_initialize_exmodes ();
 
-  parallel = avm_strung ("par");
 
-  nondeterministic = avm_strung ("npar");
 
-  unsupported_hook = avm_join (avm_strung ("unsupported hook"), NULL);
 
-  invalid_deconstruction = avm_join (avm_strung ("invalid deconstruction"), NULL);
 
-  invalid_recursion = avm_join (avm_strung ("invalid recursion"), NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  reset = avm_join (avm_strung ("reset"), NULL);
 
-  avram_version_number = avm_join (avm_strung (avm_version ()), NULL);
 
-  interpreter = avm_scanned_list (avm_prior_to_version ("0.1.0") ? olde_interpreter : interpreter_code);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_apply ()
 
-{
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (parallel);
 
-  avm_dispose (nondeterministic);
 
-  avm_dispose (unsupported_hook);
 
-  avm_dispose (avram_version_number);
 
-  avm_dispose (interpreter);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (reset);
 
-  avm_dispose (invalid_deconstruction);
 
-  avm_dispose (invalid_recursion);
 
-  parallel = NULL;
 
-  nondeterministic = NULL;
 
-  unsupported_hook = NULL;
 
-  avram_version_number = NULL;
 
-  interpreter = NULL;
 
-  memory_overflow = NULL;
 
-  reset = NULL;
 
-  invalid_recursion = NULL;
 
-  invalid_deconstruction = NULL;
 
-}
 
-

+ 0 - 855
src/avram.c
View File 

@@ -1,855 +0,0 @@
 
-/* 
-   avram - Applicative ViRtuAl Machine code interpreter
 
-
 
-   Copyright (C) 2006-2010 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-*/
 
-
 
-#define _GNU_SOURCE
 
-
 
-#include <stdio.h>
 
-#include <avm/common.h>
 
-#include <avm/apply.h>
 
-#include <avm/branches.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/cmdline.h>
 
-#include <avm/compare.h>
 
-#include <avm/decons.h>
 
-#include <avm/error.h>
 
-#include <avm/vman.h>
 
-#include <avm/exmodes.h>
 
-#include <avm/fnames.h>
 
-#include <avm/formin.h>
 
-#include <avm/formout.h>
 
-#include <avm/instruct.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/matcon.h>
 
-#include <avm/libfuns.h>
 
-#include <avm/lists.h>
 
-#include <avm/portals.h>
 
-#include <avm/ports.h>
 
-#include <avm/profile.h>
 
-#include <avm/rawio.h>
 
-#include <avm/mwrap.h>
 
-#include <avm/remote.h>
 
-#include <avm/jobs.h>
 
-#include <avm/farms.h>
 
-#include <avm/vglue.h>
 
-#include <avm/servlist.h>
 
-
 
-
 
-
 
-/*------------------------------------------- memory management --------------------------------------------------- */
 
-
 
-
 
-
 
-static void
 
-initialize_everything ()
 
-     /* This initializes some static variables used by the library. */
 
-{
 
-  avm_initialize_cmdline ();
 
-  avm_initialize_exmodes ();
 
-  avm_initialize_remote ();
 
-  avm_initialize_apply ();
 
-  avm_initialize_formin ();
 
-  avm_initialize_formout ();
 
-  avm_initialize_mwrap ();
 
-  avm_initialize_rawio ();	/* the rest are initialized indirectly */
 
-}
 
-
 
-
 
-
 
-static void
 
-reclaim_everything ()
 
-
 
-     /* This reclaims static variables used by the library and checks
 
-        for memory leaks. */
 
-{
 
-  avm_count_apply ();
 
-  avm_count_branches ();
 
-  avm_count_chrcodes ();
 
-  avm_count_cmdline ();
 
-  avm_count_compare ();
 
-  avm_count_decons ();
 
-  avm_count_exmodes ();
 
-  avm_count_remote ();
 
-  avm_count_fnames ();
 
-  avm_count_formin ();
 
-  avm_count_formout ();
 
-  avm_count_instruct ();
 
-  avm_count_listfuns ();
 
-  avm_count_matcon ();
 
-  avm_count_libfuns ();
 
-  avm_count_portals ();
 
-  avm_count_ports ();
 
-  avm_count_profile ();
 
-  avm_count_rawio ();
 
-  avm_count_libfuns ();
 
-  avm_count_mwrap ();
 
-  avm_count_jobs ();
 
-  avm_count_farms ();
 
-  avm_count_vglue ();
 
-  avm_count_servlist ();
 
-  avm_count_lists ();    /* this one should be last */
 
-
 
-}
 
-
 
-
 
-
 
-
 
-
 
-/*------------------------------------------- information display ------------------------------------------------- */
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-show_version ()
 
-
 
-     /* prints a copyright notice and exits */
 
-{
 
-  char *notice = "\
 
-Copyright (C) 2001,2006-2010 Dennis Furey. avram comes with NO WARRANTY,\n\
 
-to the extent permitted by law. You may redistribute copies of avram\n\
 
-under the terms of the GNU General Public License. For more information\n\
 
-about these matters, see the files named COPYING.\n";
 
-
 
-  printf ("avram version %s\n", avm_version ());
 
-  printf (notice);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-show_libs ()
 
-
 
-     /* prints a listing of configured libraries and exits */
 
-{
 
-#include "exf.c"
 
-  list cell, result;
 
-
 
-  cell = avm_join (NULL, NULL);
 
-  avm_output (stdout, "standard output", NULL, result = avm_apply(avm_scanned_list (exf_code), cell), 0);
 
-  avm_dispose (result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-show_usage (arg)
 
-     char *arg;
 
-
 
-     /* displays information about command line options on standard
 
-        error */
 
-{
 
-  char *usage = "\n\
 
-avram %s, Applicative ViRtuAl Machine\n\n\
 
-Usage:\n\
 
-  avram [filter mode options] codefile[.avm] < inputfile\n\
 
-  avram [parameter mode options] codefile[.avm] [command line parameters]\n\
 
-  avram [general options] [codefile[.avm] command line parameters] \n\
 
-\n\
 
-general options:\n\
 
-  -V,-v, --version            display the version of avram and exit\n\
 
-  -h,    --help               print this help\n\
 
-         --emulation=VERSION  be backward compatible with an old version\n\
 
-         --open=HOST:PORT...  run concurrently on comma separated servers\n\
 
-  -e,    --external-libraries show available external library functions\n\
 
-  -f,    --force-text-input   don't infer .avm data format in input files\n\
 
-  -j,    --jail               disable the interaction combinator\n\
 
-\n\
 
-filter mode options:\n\
 
-  -r,    --raw-output         write stdout in .avm raw data file format\n\
 
-  -c,    --choice-of-output   let the code specify raw or text output\n\
 
-  -l,    --line-map           interpret code as a line oriented map\n\
 
-  -b,    --byte-transducer    interpret code as a byte oriented transducer\n\
 
-  -u,    --unparameterized    assume filter mode despite parameters\n\
 
-\n\
 
-parameter mode options:\n\
 
-  -q,    --quiet              don't inform the user when writing files\n\
 
-  -a,    --ask-to-overwrite   ask permission to overwrite existing files\n\
 
-         -.EXT                assume a suffix .EXT on input file names\n\
 
-  -d,    --default-to-stdin   read stdin if no file parameters are given\n\
 
-  -m,    --map-to-each-file   invoke separately for each file parameter\n\
 
-  -i,    --interactive        let the interpreted program run shell commands\n\
 
-         --trace              echo dialogs of the interact combinator\n\
 
-  -s,    --step               like --interactive but pausing for each command\n\
 
-  -p,    --parameterized      assume parameter mode even with no parameters\n\
 
-\n\
 
-All filter mode options except -u are mutually exclusive. Parameter mode\n\
 
-options -d and -m are mutually exclusive, -s implies -i, and -a overrides\n\
 
- -q. -j conflicts with -i, -t, and -s. Please send bug reports and\n\
 
-suggestions to [email protected]\n\n";
 
-
 
-  if (arg ? ! strstr ("--help", arg) : 0)
 
-    fprintf (stderr, "avram: unrecognized option: %s\n", arg);
 
-  fprintf (stderr, usage, VERSION);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-/*------------------------------------------- option parsing effects ---------------------------------------------- */
 
-
 
-
 
-
 
-
 
-
 
-static int
 
-emulating (option)
 
-     char *option;
 
-
 
-     /* this sets the main virtual machine emulation version to the
 
-	given option string; clients and servers should use compatible
 
-	character sets, which there's no easy way of checking */
 
-{
 
-  char *emulation;
 
-  char *message;
 
-
 
-  emulation = "-emulation";
 
-  message = option;
 
-  if (option && (*option == '-') && ((*(1 + option)) == '-'))
 
-    option++;
 
-  while (option && emulation && (*option == *emulation))
 
-    {
 
-      option++;
 
-      emulation++;
 
-    }
 
-  if (!(option && (*option == '=')))
 
-    return 0;
 
-  avm_set_version (1 + option);
 
-  return 1;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-connect_to_servers (argc, argv, verbose)
 
-     unsigned int argc;
 
-     char *argv[];
 
-     int verbose;
 
-
 
-     /* This scans for --open= options anywhere in the command line
 
-	and registers the servers given by the parameters which,
 
-	should be a comma separated list of colon separated hostnames
 
-	or addresses and port numbers. */
 
-{
 
-  int input_index;
 
-  char *option;
 
-  int port_number;
 
-  char *parameter;
 
-  char *cursor;
 
-  char *host;
 
-
 
-  input_index = 0;
 
-  while ((input_index < argc) ? (option = argv[input_index]) : NULL)
 
-    {
 
-      if ((! strcmp (option, "-open")) ? 1 : ! strcmp (option, "--open"))
 
-	option = ((++input_index < argc) ? argv[input_index] : NULL);
 
-      else if ((strstr(option,"--open=") == option) ? 0 : (strstr(option,"-open=") != option))
 
-	option = NULL;
 
-      else
 
-	{
 
-	  while (*option != '=')
 
-	    option++;
 
-	  option++;
 
-	  option = (*option ? option : (++input_index < argc) ? argv[input_index] : NULL);
 
-	}
 
-      if (!option ? 0 : !*option ? 0 : (*option != '-'))
 
-	{
 
-	  if (!(cursor = parameter = strdup (option)))
 
-	    avm_error ("memory overflow (code 15)");
 
-	  while (*cursor)
 
-	    {
 
-	      host = cursor;
 
-	      while (*cursor ? (*cursor != ':') : 0)
 
-		cursor++;
 
-	      if (!*cursor)
 
-		avm_error ("bad --open specification (code 0)");
 
-	      *cursor = 0;
 
-	      cursor++;
 
-	      port_number = 0;
 
-	      while (isdigit (*cursor))
 
-		port_number = (port_number * 10) + (*(cursor++) - '0');
 
-	      if (!*cursor ? 0 : (*cursor != ','))
 
-		avm_error ("bad --open specification (code 1)");
 
-	      if (avm_registered_server (host, port_number) ? 0 : verbose)
 
-		fprintf (stderr, "%s: unable to open server %s on port %d\n", avm_program_name (), host, port_number);
 
-	      if (*cursor)
 
-		{
 
-		  cursor++;
 
-		  if (!*cursor)
 
-		    avm_error ("bad --open specification (code 2)");
 
-		}
 
-	    }
 
-	  free (parameter);
 
-	}
 
-      input_index++;
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-/*------------------------------------------- option parsing ------------------------------------------------------ */
 
-
 
-
 
-
 
-
 
-#define VERSION_MODE 0x1
 
-#define UNPARAMETERIZED 0x2
 
-#define RAW_OUTPUT 0x4
 
-#define FORCE_TEXT_INPUT 0x8
 
-#define CHOICE_OF_OUTPUT 0x10
 
-#define LINE_MAP 0x20
 
-#define BYTE_TRANSDUCER 0x40
 
-#define QUIET 0x80
 
-#define MAP_TO_EACH_FILE 0x100
 
-#define PARAMETERIZED 0x200
 
-#define INTERACTIVE 0x400
 
-#define TRACE 0x800
 
-#define STEP 0x1000
 
-#define DEFAULT_TO_STDIN 0x2000
 
-#define ASK_TO_OVERWRITE 0x4000
 
-#define EXTERNAL_LIBRARIES 0x8000
 
-#define JAIL 0x10000
 
-#define OPEN 0x20000
 
-
 
-
 
-
 
-
 
-
 
-
 
-int
 
-tracing (argc, argv)
 
-     unsigned int argc;
 
-     char *argv[];
 
-
 
-     /* returns true if the --trace option appears anywhere on the
 
-        command line, even beyond the range that is normally parsed
 
-        for flags */
 
-{
 
-  int input_index;
 
-
 
-  input_index = 0;
 
-  while (input_index < argc)
 
-    if (! strcmp(argv[input_index++],"--trace"))
 
-      return 1;
 
-  return 0;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static int
 
-bad_usage (input_index, argc, flags, extension)
 
-     unsigned int input_index;
 
-     unsigned int argc;
 
-     int flags;
 
-     char *extension;
 
-
 
-     /* checks whether command line options are selected consistently
 
-	and returns true if they aren't */
 
-{
 
-  int result;
 
-
 
-  if ((input_index) > argc)
 
-    return 1;
 
-  if ((input_index) == argc)
 
-    return !(flags & (VERSION_MODE | EXTERNAL_LIBRARIES));
 
-  if (flags & (RAW_OUTPUT | CHOICE_OF_OUTPUT | LINE_MAP |  BYTE_TRANSDUCER | UNPARAMETERIZED))
 
-    {
 
-      result = (flags & UNPARAMETERIZED) ? 0 : ((input_index) < (argc - 1));
 
-      result = result | (flags & (ASK_TO_OVERWRITE | PARAMETERIZED | INTERACTIVE | VERSION_MODE));
 
-      result = result | (flags & (STEP | QUIET | MAP_TO_EACH_FILE | DEFAULT_TO_STDIN));
 
-      result = result | ((flags & CHOICE_OF_OUTPUT) ? (flags & (RAW_OUTPUT | LINE_MAP | BYTE_TRANSDUCER)) :  0);
 
-      result = result | ((flags & RAW_OUTPUT) ? (flags & (LINE_MAP | BYTE_TRANSDUCER)) : 0);
 
-      result = result | ((flags & LINE_MAP) ? (flags & BYTE_TRANSDUCER) : 0);
 
-      result = result | !!extension;
 
-    }
 
-  else
 
-    {
 
-      result = flags & (RAW_OUTPUT | VERSION_MODE | LINE_MAP | BYTE_TRANSDUCER | CHOICE_OF_OUTPUT);
 
-      result = result | ((flags & DEFAULT_TO_STDIN) ? (flags & MAP_TO_EACH_FILE) : 0);
 
-    }
 
-  if (result ? 0 : (flags & JAIL))
 
-    result = (flags & (INTERACTIVE | TRACE | STEP));
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static unsigned int
 
-the_flags_of (argc, argv, extension, inin)
 
-     unsigned int argc;
 
-     char *argv[];
 
-     char **extension;
 
-     unsigned int *inin;
 
-
 
-     /* This fills in the flags with the command line options, points
 
-        the extension to the -.EXT option, if any, and leaves
 
-        inin pointing to the position of the first non-flag on
 
-        the command line, which is probably the name of the virtual
 
-        code file. */
 
-{
 
-#define recognized_long ((*(1 + argv[*inin])=='-') ? ((*(2 + argv[*inin])) ? strstr (keywords, argv[*inin]) : 0) : 0)
 
-#define recognized_short ((strlen (argv[*inin]) == 2) ? strstr (keyletters, argv[*inin]) : 0)
 
-#define recognized_option (offset = (recognized_long ? 2 : (recognized_short ? 1 : 0)))
 
-#define set_if(character,flag) flags = flags | ((*(offset + argv[*inin]) == character) ? flag : 0)
 
-
 
-  char *option;
 
-  char *emulation;
 
-  unsigned int flags, offset;
 
-  char *keyletters = "-r-f-q-u-a-V-v-p-s-i-l-b-m-c-d-n-e-j";   /* must be mutually distinct, unused are gknwxyz */
 
-  char *keywords = "\
 
---raw-output--force-text-input--quiet--unparameterized\
 
---ask-to-overwrite--step--trace--map-to-each-file\
 
---default-to-stdin--external-libraries--open-connections\
 
---version--parameterized--interactive--jail\
 
---line-map--byte-transducer--choice-of-output";
 
-
 
-  *inin = 0;
 
-  flags = 0;
 
-  *extension = NULL;
 
-  while (++(*inin) >= argc ? 0 : argv[*inin] ? *(argv[*inin]) == '-' : 0)
 
-    {
 
-      if (emulating (argv[*inin]) ? 0 : recognized_option)
 
-	{
 
-	  set_if ('r', RAW_OUTPUT);
 
-	  set_if ('i', INTERACTIVE);
 
-	  set_if ('l', LINE_MAP);
 
-	  set_if ('v', VERSION_MODE);
 
-	  set_if ('V', VERSION_MODE);
 
-	  set_if ('b', BYTE_TRANSDUCER);
 
-	  set_if ('c', CHOICE_OF_OUTPUT);
 
-	  set_if ('m', MAP_TO_EACH_FILE);
 
-	  set_if ('a', ASK_TO_OVERWRITE);
 
-	  set_if ('p', PARAMETERIZED);
 
-	  set_if ('s', STEP);
 
-	  set_if ('d', DEFAULT_TO_STDIN);
 
-	  set_if ('t', TRACE);
 
-	  set_if ('f', FORCE_TEXT_INPUT);
 
-	  set_if ('u', UNPARAMETERIZED);
 
-	  set_if ('e', EXTERNAL_LIBRARIES);
 
-	  set_if ('o', OPEN);
 
-	  set_if ('j', JAIL);
 
-	  set_if ('q', QUIET);
 
-	}
 
-      else if (*(1 + argv[*inin]) == '.')
 
-	*extension = 1 + argv[*inin];
 
-      else
 
-	{
 
-	  show_usage (argv[*inin]);
 
-	  exit (strstr ("--help", argv[*inin]) ? EXIT_SUCCESS : EXIT_FAILURE);
 
-	}
 
-    }
 
-  if (!(bad_usage (*inin, argc, flags, *extension)))
 
-    return flags;
 
-  show_usage (NULL);
 
-  exit (EXIT_FAILURE);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-/*------------------------------------------- parameter extraction ------------------------------------------------ */
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static char
 
-*avminputs (env)
 
-     char *env[];
 
-
 
-     /* This returns a pointer to the AVMINPUTS environment variable
 
-        if found, which is a colon separated list of directory
 
-        names. */
 
-{
 
-  int index;
 
-  char *result;
 
-  char *variable;
 
-  char *default_paths = ".:/usr/local/lib/avm:/usr/lib/avm:/lib/avm:/opt/avm:/opt/lib/avm\
 
-:/usr/local/share/avm:/usr/share/avm:/share/avm:/opt/avm:/opt/share/avm";
 
-
 
-  index = 0;
 
-  result = NULL;
 
-  while (result ? 0 : env[index])
 
-    {
 
-      variable = env[index++];
 
-      if (strstr (variable, "AVMINPUTS=") == variable)
 
-	{
 
-	  while ((*variable) ? ((*variable) != '=') : 0)
 
-	    variable++;
 
-	  if (*variable)
 
-	    variable++;
 
-	  result = variable;
 
-	}
 
-    }
 
-  return ((result ? *result : 0) ? result : default_paths);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static FILE
 
-*code_file (arg)
 
-     char *arg;
 
-
 
-     /* tries to open a file by the given name, and also with the
 
-	default .avm suffix if there is no suffix */
 
-{
 
-  char *filename;
 
-  FILE *code;
 
-
 
-  if (code = fopen (arg, "rb"))
 
-    return code;
 
-  if(!strstr(".",arg))
 
-    avm_fatal_io_error ("can't read", arg, errno);
 
-  if (!(filename = (char *) malloc (strlen (arg) + 5)))
 
-    avm_error ("memory overflow (code 1)");
 
-  if (!(code = fopen (strcat (strcpy (filename, arg), ".avm"),"rb")))
 
-    avm_fatal_io_error ("can't read", filename, errno);
 
-  free (filename);
 
-  return code;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-parametric (flags, argv, argc, input_index, extension, paths, environs)
 
-     int flags;
 
-     char *argv[];
 
-     unsigned int argc;
 
-     char *extension;
 
-     char *paths;
 
-     list environs;
 
-
 
-     /* constructs the main program operand for execution modes other
 
-	than filtering */
 
-{
 
-  list operand;
 
-  int dts, fti;
 
-
 
-  operand = NULL;
 
-  dts = flags & DEFAULT_TO_STDIN;
 
-  fti = flags & FORCE_TEXT_INPUT;
 
-  if (!(flags & UNPARAMETERIZED))
 
-    operand = avm_default_command_line (argc, argv, input_index, extension, paths, dts, fti, NULL);
 
-  if (operand)
 
-    return avm_join (operand, environs);
 
-  if (extension)
 
-    return avm_join (avm_join (NULL, NULL), environs);
 
-  if (flags & (ASK_TO_OVERWRITE | QUIET | PARAMETERIZED | INTERACTIVE | TRACE | STEP | DEFAULT_TO_STDIN))
 
-    return avm_join (avm_join (NULL, NULL), environs);
 
-  avm_dispose (environs);
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-/*------------------------------------------- execution modes ----------------------------------------------------- */
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-mapper_mode (argc, argv, input_index, paths, flags, extension, operator, environs)
 
-     int argc;
 
-     char *argv[];
 
-     int input_index;
 
-     int flags;
 
-     char *paths;
 
-     char *extension;
 
-     list operator;
 
-     list environs;
 
-
 
-     /* loops through the input files on the command line instead of
 
-	loading them all at once */
 
-{
 
-  int dts, fti, file_ordinal;
 
-  list result, operand;
 
-
 
-  file_ordinal = 0;
 
-  operand = result = NULL;
 
-  dts = flags & DEFAULT_TO_STDIN;
 
-  fti = flags & FORCE_TEXT_INPUT;
 
-  while ((operand = avm_default_command_line (argc, argv, input_index, extension, paths, dts, fti, &file_ordinal)))
 
-    {
 
-      operand = avm_join (operand ? operand : avm_join (NULL, NULL), avm_copied (environs));
 
-      result = avm_apply (avm_copied (operator), operand);
 
-      if (flags & (INTERACTIVE | STEP))
 
-	avm_interact (result, flags & STEP, flags & ASK_TO_OVERWRITE, flags & QUIET);
 
-      else
 
-	{
 
-	  avm_output_as_directed (result, flags & ASK_TO_OVERWRITE, !(flags & QUIET));
 
-	  avm_dispose (result);
 
-	  result = NULL;
 
-	}
 
-    }
 
-  avm_dispose (operator);
 
-  avm_dispose (environs);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-parameter_mode (flags, operand, code, arg)
 
-     int flags;
 
-     list operand;
 
-     FILE *code;
 
-     char *arg;
 
-
 
-     /* executes the main program according to either parameterized or
 
-	interactive operation */
 
-{
 
-  list result;
 
-
 
-  result = avm_apply (avm_received_list (code, arg), operand);
 
-  if (flags & (INTERACTIVE | STEP))
 
-    avm_interact (result, flags & STEP, flags & ASK_TO_OVERWRITE, flags & QUIET);
 
-  else
 
-    avm_output_as_directed (result, flags & ASK_TO_OVERWRITE, ! (flags & QUIET));
 
-  avm_dispose (result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-text_mode (flags, code, arg)
 
-     int flags;
 
-     FILE *code;
 
-     char *arg;
 
-
 
-     /* executes as a filter with the input file treated as text
 
-	only */
 
-{
 
-  list result, cell;
 
-
 
-  cell = NULL;
 
-  if (flags & CHOICE_OF_OUTPUT)
 
-    result = avm_apply (avm_received_list (code, arg), avm_join (NULL, avm_load (stdin, NULL, 0)));
 
-  else
 
-    result = avm_apply (avm_received_list (code, arg), avm_load (stdin, NULL, 0));
 
-  if ((flags & CHOICE_OF_OUTPUT) ? result : NULL)
 
-    avm_output (stdout, "standard output", result->head, result->tail, 0);
 
-  else
 
-    avm_output (stdout, "standard output", (flags & RAW_OUTPUT) ? (cell = avm_join (NULL, NULL)) : NULL, result, 0);
 
-  avm_dispose (result);
 
-  avm_dispose (cell);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-binary_mode (flags, code, arg)
 
-     int flags;
 
-     FILE *code;
 
-     char *arg;
 
-
 
-     /* executes as a filter with the input file disambiguated between
 
-        text and binary format */
 
-{
 
-  list result, cell, operand;
 
-
 
-  cell = NULL;
 
-  operand = avm_preamble_and_contents (stdin, "standard input");
 
-  if (flags & CHOICE_OF_OUTPUT)
 
-    result = avm_apply (avm_received_list (code, arg), avm_copied (operand));
 
-  else  /* ignore preamble */
 
-    result = avm_apply (avm_received_list (code, arg), avm_copied (operand->tail));
 
-  avm_dispose (operand);
 
-  if ((flags & CHOICE_OF_OUTPUT) ? result : NULL)
 
-    avm_output (stdout, "standard output", result->head, result->tail, 0);
 
-  else /* don't expect preamble */
 
-    avm_output (stdout, "standard output", (flags & RAW_OUTPUT) ? (cell = avm_join (NULL, NULL)) : NULL, result, 0);
 
-  avm_dispose (result);
 
-  avm_dispose (cell);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-/*----------------------------------------------------------------------------------------------------------------- */
 
-
 
-
 
-
 
-
 
-
 
-int
 
-main (argc, argv, env)
 
-     unsigned int argc;
 
-     char *argv[];
 
-     char *env[];
 
-{
 
-#define PRO_FILENAME "profile.txt"
 
-
 
-  FILE *code;
 
-  char *extension;
 
-  list operand;
 
-  unsigned int input_index = 0;
 
-  unsigned int flags;
 
-
 
-  initialize_everything ();
 
-  avm_set_program_name (basename (argv[0]));
 
-  if ((flags = the_flags_of (argc, argv, &extension, &input_index)) & (VERSION_MODE | EXTERNAL_LIBRARIES))
 
-    {
 
-      if (flags & EXTERNAL_LIBRARIES)
 
-	show_libs ();
 
-      if (flags & VERSION_MODE)
 
-	show_version ();
 
-      reclaim_everything ();
 
-      exit (EXIT_SUCCESS);
 
-    }
 
-  avm_set_program_name (basename (argv[input_index]));
 
-  connect_to_servers (argc, argv, ! flags & QUIET);
 
-  if (flags & JAIL)
 
-    avm_disable_interaction ();
 
-  if (tracing (argc, argv))
 
-    avm_trace_interaction ();
 
-  code = code_file (argv[input_index]);
 
-  if (flags & MAP_TO_EACH_FILE)
 
-    {
 
-      operand = avm_received_list (code, argv[input_index++]);
 
-      mapper_mode (argc, argv, input_index, avminputs (env), flags, extension, operand, avm_environment (env));
 
-    }
 
-  else if (operand = parametric (flags, argv, argc, input_index + 1, extension, avminputs (env), avm_environment (env)))
 
-    parameter_mode (flags, operand, code, argv[input_index]);
 
-  else if (flags & LINE_MAP)
 
-    avm_line_map (operand = avm_received_list (code, argv[input_index]));
 
-  else if (flags & BYTE_TRANSDUCER)
 
-    avm_byte_transduce (operand = avm_received_list (code, argv[input_index]));
 
-  else if (flags & FORCE_TEXT_INPUT)
 
-    text_mode (flags, code, argv[input_index]);
 
-  else
 
-    binary_mode (flags, code, argv[input_index]);
 
-  if (fclose (code))
 
-    avm_non_fatal_io_error ("can't close", argv[(flags & MAP_TO_EACH_FILE) ? input_index : (--input_index)], errno);
 
-  avm_tally (PRO_FILENAME);
 
-  reclaim_everything ();
 
-  exit (EXIT_SUCCESS);
 
-}

+ 0 - 394
src/bes.c
View File 

@@ -1,394 +0,0 @@
 
-
 
-/* this file interfaces to gsl bessel functions
 
-
 
-   Copyright (C) 2007 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
 
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/compare.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/bes.h>
 
-#if HAVE_GSL
 
-#include <gsl/gsl_errno.h>
 
-#include <gsl/gsl_sf_bessel.h>
 
-#endif
 
-#include <math.h>
 
-#include <string.h>
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list bad_bess = NULL;
 
-static list memory_overflow = NULL;
 
-static list unrecognized_function_name = NULL;
 
-
 
-/* function names as lists of lists of character representations */
 
-static list funs = NULL;
 
-
 
-static list shared_cell = NULL;
 
-static list wild = NULL;
 
-
 
-#if HAVE_GSL
 
-
 
-typedef double (*bess)(double);
 
-typedef double (*family)(int,double);
 
-typedef double (*continuum)(double,double);
 
-typedef double (*zeroid)(unsigned int);
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-bessel(j0, j1, j2, jn, jnu, operand, fault)
 
-     bess j0,j1,j2;
 
-     family jn;
 
-     continuum jnu;
 
-     list operand;
 
-     int *fault;
 
-{
 
-  double y,*x,*nu;
 
-  list message,order;
 
-  int n;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !operand)
 
-    return avm_copied (bad_bess);
 
-  message = NULL;
 
-  x = (double *) avm_value_of_list(operand->tail,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return (message ? message : avm_copied (bad_bess));
 
-  order = operand->head;
 
-  if (!order)
 
-    y = (*j0)(*x);
 
-  else if (!(order->tail))
 
-    y = (*j1)(*x);
 
-  else if (j2 ? (order->head ? 0 : !(order->tail->tail)) : 0)
 
-    y = (*j2)(*x);
 
-  else
 
-    {
 
-      while (order->tail)
 
-	order = order->tail;
 
-      if (order->head ? (order->head->head ? 1 : !!(order->head->tail)) : 0)
 
-	{
 
-	  if (*fault = !jnu)
 
-	    return avm_copied (bad_bess);
 
-	  nu = (double *) avm_value_of_list(operand->head,&message,fault);
 
-	  if (*fault = (*fault ? 1 : !!message))
 
-	    return (message ? message : avm_copied (bad_bess));
 
-	  y = (*jnu)(*nu,*x);
 
-	}
 
-      else
 
-	{
 
-	  if (*fault = !(n = (int) avm_counter (operand->head)))
 
-	    return avm_copied (memory_overflow);
 
-	  y = (*jn)(n,*x);
 
-	}
 
-    }
 
-  return avm_list_of_value((void *) &y, sizeof(double), fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-zero(operator, operand, fault)
 
-     zeroid operator;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* the operator is either zero_J0 or zero_J1.  the operand is a
 
-	list representing a double */
 
-{
 
-  double y;
 
-  unsigned int s;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  s = (unsigned int) avm_counter (operand);
 
-  if (*fault = (s ? 0 : !!operand))
 
-    return avm_copied (memory_overflow);
 
-  y = (*operator)(s);
 
-  return avm_list_of_value((void *) &y,sizeof(double),fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-zero_Jnu(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-{
 
-  list message;
 
-  double *nu,z;
 
-  unsigned int s;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  message = NULL;
 
-  if (*fault = !operand)
 
-    return avm_copied(bad_bess);
 
-  nu = (double *) avm_value_of_list(operand->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  s = (unsigned int) avm_counter (operand->tail);
 
-  if (*fault ? 1 : (s ? 0 : !!(operand->tail)))
 
-    return avm_copied (memory_overflow);
 
-  z = gsl_sf_bessel_zero_Jnu(*nu,s);
 
-  return avm_list_of_value((void *) &z,sizeof(double),fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-lnKnu(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-{
 
-  list message;
 
-  double *nu,*x,z;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  message = NULL;
 
-  if (*fault = !operand)
 
-    return avm_copied(bad_bess);
 
-  nu = (double *) avm_value_of_list(operand->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  x = (double *) avm_value_of_list(operand->tail,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  z = gsl_sf_bessel_lnKnu(*nu,*x);
 
-  return avm_list_of_value((void *) &z,sizeof(double),fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-#endif /* HAVE_GSL */
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_have_bes_call (function_name, fault)
 
-  list function_name;
 
-  int *fault;
 
-
 
-/* this reports the availability of a function */
 
-
 
-{
 
-#if HAVE_GSL
 
-  list membership;
 
-  list comparison;
 
-  list result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_bes ();
 
-  if (*fault)
 
-    return NULL;
 
-  comparison = avm_binary_comparison (function_name, wild, fault);
 
-  if (*fault)
 
-    return comparison;
 
-  if (comparison)
 
-    {
 
-      avm_dispose(comparison);
 
-      return avm_copied(funs);
 
-    }
 
-  if (!(membership = avm_binary_membership (function_name, funs, fault)) ? 1 : *fault)
 
-    return membership;
 
-  avm_dispose(membership);
 
-  return ((*fault = !(result = avm_recoverable_join(avm_copied(function_name),NULL))) ? avm_copied(memory_overflow) : result);
 
-#endif
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_bes_call (function_name, argument, fault)
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-
 
-     /* This figures out what function to call and calls it. */
 
-{
 
-#if HAVE_GSL
 
-  list message;
 
-  int function_number;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (! initialized)
 
-    avm_initialize_bes ();
 
-  if (!(function_number = 0xff & (function_name ? function_name->characterization : 0)))
 
-    {
 
-      message = avm_position (function_name, funs, fault);
 
-      if (*fault = (*fault ? 1 : !message))
 
-	return (message ? message : avm_copied (unrecognized_function_name));
 
-      function_number = message->characterization;
 
-      function_name->characterization = function_number;
 
-      avm_dispose (message);
 
-    }
 
-  switch (function_number)
 
-    {
 
-    case 1: return bessel (&gsl_sf_bessel_J0,&gsl_sf_bessel_J1,NULL,&gsl_sf_bessel_Jn,&gsl_sf_bessel_Jnu,argument,fault);
 
-    case 2: return bessel (&gsl_sf_bessel_Y0,&gsl_sf_bessel_Y1,NULL,&gsl_sf_bessel_Yn,&gsl_sf_bessel_Ynu,argument,fault);
 
-    case 3: return bessel (&gsl_sf_bessel_I0,&gsl_sf_bessel_I1,NULL,&gsl_sf_bessel_In,&gsl_sf_bessel_Inu,argument,fault);
 
-    case 4: return bessel (&gsl_sf_bessel_K0,&gsl_sf_bessel_K1,NULL,&gsl_sf_bessel_Kn,&gsl_sf_bessel_Knu,argument,fault);
 
-    case 5: return bessel (&gsl_sf_bessel_j0,&gsl_sf_bessel_j1,&gsl_sf_bessel_j2,&gsl_sf_bessel_jl,NULL,argument,fault);
 
-    case 6: return bessel (&gsl_sf_bessel_y0,&gsl_sf_bessel_y1,&gsl_sf_bessel_y2,&gsl_sf_bessel_yl,NULL,argument,fault);
 
-    case 7: return bessel (&gsl_sf_bessel_I0_scaled,
 
-			   &gsl_sf_bessel_I1_scaled,
 
-			   NULL,
 
-			   &gsl_sf_bessel_In_scaled,
 
-			   &gsl_sf_bessel_Inu_scaled,
 
-			   argument,
 
-			   fault);
 
-    case 8: return bessel (&gsl_sf_bessel_K0_scaled,
 
-			   &gsl_sf_bessel_K1_scaled,
 
-			   NULL,
 
-			   &gsl_sf_bessel_Kn_scaled,
 
-			   &gsl_sf_bessel_Knu_scaled,
 
-			   argument,
 
-			   fault);
 
-    case 9: return bessel (&gsl_sf_bessel_i0_scaled,
 
-			   &gsl_sf_bessel_i1_scaled,
 
-			   &gsl_sf_bessel_i2_scaled,
 
-			   &gsl_sf_bessel_il_scaled,
 
-			   NULL,
 
-			   argument,
 
-			   fault);
 
-    case 10: return bessel (&gsl_sf_bessel_k0_scaled,
 
-			   &gsl_sf_bessel_k1_scaled,
 
-			   &gsl_sf_bessel_k2_scaled,
 
-			   &gsl_sf_bessel_kl_scaled,
 
-			   NULL,
 
-			   argument,
 
-			   fault);
 
-    case 11:  return zero (&gsl_sf_bessel_zero_J0, argument, fault);
 
-    case 12:  return zero (&gsl_sf_bessel_zero_J1, argument, fault);
 
-    case 13: return zero_Jnu (argument, fault);
 
-    case 14: return lnKnu (argument, fault);
 
-    }
 
-#endif /* HAVE_GSL */
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_bes ()
 
-
 
-     /* This initializes some static data structures. */
 
-{
 
-  char *funames[] = {"J","Y","I","K","j","y","Isc","Ksc","isc","ksc","zJ0","zJ1","zJnu","lnKnu",NULL};
 
-  list back;
 
-  int string_number;
 
-#if HAVE_GSL
 
-  gsl_error_handler_t *old_handler;
 
-#endif
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_listfuns ();
 
-  avm_initialize_chrcodes ();
 
-#if HAVE_GSL
 
-  old_handler = gsl_set_error_handler_off();
 
-#endif
 
-  shared_cell = avm_join (NULL, NULL);
 
-  wild = avm_strung("*");
 
-  bad_bess = avm_join (avm_strung ("bad bessel function call"), NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  unrecognized_function_name = avm_join (avm_strung ("unrecognized bessel function name"), NULL);
 
-  string_number = 0;
 
-  funs = back = NULL;
 
-  while (funames[string_number])
 
-    avm_enqueue (&funs, &back, avm_standard_strung (funames[string_number++]));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_bes ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (funs);
 
-  avm_dispose (wild);
 
-  avm_dispose (bad_bess);
 
-  avm_dispose (shared_cell);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (unrecognized_function_name);
 
-  funs = NULL;
 
-  bad_bess = NULL;
 
-  shared_cell = NULL;
 
-  memory_overflow = NULL;
 
-  unrecognized_function_name = NULL;
 
-}

+ 0 - 289
src/branches.c
View File 

@@ -1,289 +0,0 @@
 
-
 
-/* operations on pointers to lists and queues thereof
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-*/
 
-
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/branches.h>
 
-
 
-/* This constant determines how many branch queue nodes will be
 
-   statically stored in order to save the time of allocating them. */
 
-#define branch_cache_size 0xff
 
-
 
-/* local cache of branch queue nodes */
 
-static branch_queue available_branch = NULL;
 
-
 
-/* number of branch queue nodes in the cache */
 
-static int available_branches = 0;
 
-
 
-/* total number of allocated branch queue nodes */
 
-static counter extant_branches = 0;
 
-
 
-/* Non-zero means static variables have been initialized. */
 
-static int initialized = 0;
 
-
 
-
 
-
 
-void
 
-avm_recoverable_anticipate (front, back, operand, fault)
 
-     branch_queue *front;
 
-     branch_queue *back;
 
-     branch operand;
 
-     int *fault;
 
-
 
-     /* This appends an operand to the branch queue addressed by front
 
-        and back. Both of these should be initialized to NULL before
 
-        the first call, and then passed to this function again for
 
-        each subsequent call. Thanks to Norm Pleszkoch for spotting a
 
-        bug in an early version of this routine. */
 
-{
 
-  if (*fault)
 
-    {
 
-      avm_dispose_branch_queue (*front);
 
-      *front = *back = NULL;
 
-      return;
 
-    }
 
-  if (!*front)
 
-    {
 
-      if (*front = *back = available_branch)
 
-	{
 
-	  available_branch = available_branch->following;
 
-	  available_branches--;
 
-	}
 
-      else
 
-	*fault = ! (*front = *back = (branch_queue) (malloc (sizeof (**back))));
 
-    }
 
-  else if (!*back)
 
-    avm_internal_error (34);
 
-  else if (available_branch)
 
-    {
 
-      *back = (*back)->following = available_branch;
 
-      available_branch = available_branch->following;
 
-      available_branches--;
 
-    }
 
-  else
 
-    (*fault = ! (*back = (*back)->following = (branch_queue) (malloc (sizeof (**back)))));
 
-  if (*fault)
 
-    {
 
-      avm_dispose_branch_queue (*front);
 
-      *front = *back = NULL;
 
-      return;
 
-    }
 
-  extant_branches++;
 
-  (*back)->following = NULL;
 
-  (*back)->above = operand;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_anticipate (front, back, operand)
 
-     branch_queue *front;
 
-     branch_queue *back;
 
-     branch operand;
 
-
 
-     /* This is similar to the recoverable version but incorporates
 
-        error handling; this is the entry point used by avram. */
 
-
 
-{
 
-  int fault;
 
-
 
-  fault = 0;
 
-  avm_recoverable_anticipate (front, back, operand, &fault);
 
-  if (fault)
 
-    avm_error ("memory overflow (code 2)");
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_enqueue_branch (front, back, received_bit)
 
-     branch_queue *front;
 
-     branch_queue *back;
 
-     int received_bit;
 
-
 
-     /* This gets used in several places when building a tree from an
 
-        input string. Every 0 bit corresponds to an empty subtree, and
 
-        every 1 bit corresponds to a non-empty subtree. Hence,
 
-        whenever a 1 bit is read, a new cell is created and pointers
 
-        to its head and tail are enqueued for later reading. */
 
-
 
-{
 
-  branch_queue old;
 
-
 
-  if (!*front)
 
-    return;
 
-  if (*((*front)->above) = (received_bit ? avm_join (NULL, NULL) : NULL))
 
-    {
 
-      avm_anticipate (front, back, &((*((*front)->above))->head));
 
-      avm_anticipate (front, back, &((*((*front)->above))->tail));
 
-    }
 
-  *front = (old = *front)->following;
 
-  avm_dispose_branch (old);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_recoverable_enqueue_branch (front, back, received_bit, fault)
 
-     branch_queue *front;
 
-     branch_queue *back;
 
-     int received_bit;
 
-     int *fault;
 
-
 
-     /* This is similar to the above, but allows clients to do their
 
-        own error handling. */
 
-
 
-{
 
-  branch_queue old;
 
-  list new_cell;
 
-
 
-  if (*fault = (*fault ? 1 : !(*front)))
 
-    return;
 
-  new_cell = (received_bit ? avm_recoverable_join (NULL, NULL) : NULL);
 
-  if (*fault = (received_bit ? !new_cell : 0))
 
-    return;
 
-  if ((*((*front)->above) = new_cell))
 
-    {
 
-      avm_recoverable_anticipate (front, back, &((*((*front)->above))->head), fault);
 
-      if (!*fault)
 
-	avm_recoverable_anticipate (front, back, &((*((*front)->above))->tail), fault);
 
-    }
 
-  if (!*fault)
 
-    {
 
-      *front = (old = *front)->following;
 
-      avm_dispose_branch (old);
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_dispose_branch (old)
 
-     branch_queue old;
 
-
 
-     /* This frees a branch with caching. */
 
-
 
-{
 
-
 
-  if (old)
 
-    {
 
-      extant_branches--;
 
-      if (available_branches > branch_cache_size)
 
-	free (old);
 
-      else
 
-	{
 
-	  available_branches++;
 
-	  old->following = available_branch;
 
-	  available_branch = old;
 
-	}
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_dispose_branch_queue (front)
 
-     branch_queue front;
 
-
 
-     /* This frees a whole branch queue with caching; the lists that
 
-        the branches point to are not touched. */
 
-
 
-{
 
-  branch_queue old;
 
-
 
-  while (front)
 
-    {
 
-      front = (old = front)->following;
 
-      avm_dispose_branch (old);
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_branches ()
 
-
 
-     /* This is to be called before anything else; presently it
 
-        doesn't do much. */
 
-
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_branches ()
 
-
 
-     /* This detects and reports memory leaks. */
 
-
 
-{
 
-  if (initialized)
 
-    {
 
-      initialized = 0;
 
-      if (extant_branches)
 
-	avm_reclamation_failure ("branches", extant_branches);
 
-    }
 
-}

+ 0 - 789
src/chrcodes.c
View File 

@@ -1,789 +0,0 @@
 
-/* functions for converting between characters and lists
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/vman.h>
 
-#include <avm/lists.h>
 
-#include <avm/branches.h>
 
-#include <avm/chrcodes.h>
 
-
 
-
 
-/* a list representation for each character code */
 
-list _avm_representations[256];
 
-list _avm_standard_representations[256];
 
-
 
-/* spare storage used in the avm_character_representation macro */
 
-list _avm_temporary_character;
 
-
 
-/* used as a counter of bits that have been packed into a character */
 
-static int spoke = 0;
 
-
 
-/* temporary storage for a byte being unpacked */
 
-static int spool = 0;
 
-
 
-/* representation of (nil,nil) */
 
-static list shared_cell = NULL;
 
-
 
-/* error messages */
 
-static list memory_overflow = NULL;
 
-static list counter_overflow = NULL;
 
-static list invalid_text_format = NULL;
 
-static list invalid_prompt = NULL;
 
-
 
-/* Non-zero means static variables have been initialized. */
 
-static int initialized = 0;
 
-
 
-/* Non-zero indicates an invalid character representation detected by pack */
 
-static int packaging_error;
 
-
 
-/* used for quickly mapping lists packed into integers to their ascii
 
-   codes */
 
-#define maximum_package 5459
 
-static int ascii_codes[1 + maximum_package];
 
-static int standard_ascii_codes[1 + maximum_package];
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-pack (operand, package, level)
 
-     list operand;
 
-     int *package;
 
-     int level;
 
-
 
-     /* This turns a list into a bit string, assuming the bit string
 
-        is short enough to be packed into an integer.  The bits are
 
-        written according to a postfix traversal, which is different
 
-        from the way lists are encoded for file i/o. */
 
-{
 
-
 
-  if (level > 8)
 
-    packaging_error = 1;
 
-  else if (!operand)
 
-    *package <<= 1;
 
-  else
 
-    {
 
-      pack (operand->tail, package, level + 1);
 
-      pack (operand->head, package, level + 1);
 
-      *package = (*package << 1) + 1;
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-int
 
-avm_character_code (operand)
 
-     list operand;
 
-
 
-     /* This returns the character code if the operand represents a
 
-        character, -1 otherwise; The way character codes are computed
 
-        from lists is meant to be as fast as possible. First the list
 
-        is turned into a bit string by a postfix traversal, and the
 
-        bits are packed into an integer.  The integer is then used as
 
-        an index into a pre-initialized array to obtain the character
 
-        code. Once obtained, the character code is written into the
 
-        list node, so that if the same list needs to be translated to
 
-        a character code again, the previously stored value will be
 
-        retrieved instead of being computed again. */
 
-{
 
-  int package;
 
-
 
-  if (!operand)
 
-    return (-1);
 
-  if (operand->characteristic)
 
-    return (operand->characterization);
 
-  packaging_error = package = 0;
 
-  pack (operand, &package, 0);
 
-  if (packaging_error ? 1 : (package < 0 ? 1 : package > maximum_package))
 
-    return (-1);
 
-  else if ((operand->characteristic = (ascii_codes[package] >= 0)))
 
-    return (operand->characterization = ascii_codes[package]);
 
-  else
 
-    return (-1);
 
-}
 
-
 
-
 
-
 
-int
 
-avm_standard_character_code (operand)
 
-     list operand;
 
-
 
-     /* always uses the standard representation */
 
-{
 
-  int package;
 
-
 
-  if (!operand)
 
-    return (-1);
 
-  packaging_error = package = 0;
 
-  pack (operand, &package, 0);
 
-  if (packaging_error ? 1 : (package < 0 ? 1 : package > maximum_package))
 
-    return (-1);
 
-  else
 
-    return(standard_ascii_codes[package]);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_strung (string)
 
-     char *string;
 
-
 
-     /* This turns a null terminated character string into a list. */
 
-
 
-{
 
-  list front, back;
 
-
 
-  if (!initialized)
 
-    avm_initialize_chrcodes ();
 
-  front = back = NULL;
 
-  while (*string)
 
-    avm_enqueue (&front, &back, avm_character_representation (*(string++)));
 
-  return (front);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_standard_strung (string)
 
-     char *string;
 
-
 
-     /* This turns a null terminated character string into a list,
 
-	using the standard character representation regardless of the version
 
-	emulation. */
 
-{
 
-  list front, back;
 
-
 
-  if (!initialized)
 
-    avm_initialize_chrcodes ();
 
-  front = back = NULL;
 
-  while (*string)
 
-    {
 
-      /* printf("%s\n",string); */
 
-      avm_enqueue (&front, &back, avm_standard_character_representation (*(string++)));
 
-    }
 
-  return (front);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_recoverable_strung (string, fault)
 
-     char *string;
 
-     int *fault;
 
-
 
-     /* This turns a null terminated character string into a list. */
 
-
 
-{
 
-  list front, back;
 
-
 
-  if (!initialized)
 
-    avm_initialize_chrcodes ();
 
-  front = back = NULL;
 
-  while (*fault ? 0 : *string)
 
-    {
 
-      avm_recoverable_enqueue (&front,&back,avm_character_representation (*(string++)),fault);
 
-      if (! front)
 
-	string = NULL;
 
-    }
 
-  return (front);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_recoverable_standard_strung (string, fault)
 
-     char *string;
 
-     int *fault;
 
-
 
-     /* always uses the standard representation */
 
-
 
-{
 
-  list front, back;
 
-
 
-  if (!initialized)
 
-    avm_initialize_chrcodes ();
 
-  front = back = NULL;
 
-  while (*string)
 
-    {
 
-      avm_recoverable_enqueue (&front,&back,avm_standard_character_representation (*(string++)),fault);
 
-      if (! front)
 
-	string = NULL;
 
-    }
 
-  return (front);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static int
 
-scanned_bit (string)
 
-     char **string;
 
-
 
-     /* This returns the next bit in a string each time it's called;
 
-	the spool represents the current character, which isn't
 
-	advanced to the next position in the string until all its bits
 
-	are read, and the spoke keeps track of the bits remaining in
 
-	the spool. */
 
-{
 
-
 
-  if (!(spoke--))
 
-    {
 
-      if (!**string)
 
-	avm_internal_error (13);
 
-      spool = *((*string)++) - 60;
 
-      spoke = 5;
 
-    }
 
-  return ((spool >> spoke) & 1);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_scanned_list (string)
 
-     char *string;
 
-
 
-     /* This function uses the same algorithm as the one for reading
 
-        trees from files, but reads from a string in memory rather
 
-        than from a file. It's meant to be used for initializing lists
 
-        that are hard coded into the program rather than being read
 
-        from a file, such as the interpreter code in rewrite.c, since
 
-        there's no easy way to initialize them otherwise.
 
-
 
-        In an earlier version of the interpreter defined in rewrite.c,
 
-        there was a weird case where cyclic lists were created as a
 
-        result of the interpreter interpreting itself. It worked ok
 
-        but couldn't be reclaimed. The interpreter code has been
 
-        changed since then so that cyclic structures can't be created,
 
-        but just in case anybody changes it back, this function makes
 
-        a point of marking the lists it builds as internal, and the
 
-        apply function uses this information to avoid creating a
 
-        cyclic list.
 
-     */
 
-{
 
-  list result;
 
-  branch_queue old, front, back;
 
-
 
-  if (!initialized)
 
-    avm_initialize_chrcodes ();
 
-  spoke = 0;
 
-  front = back = NULL;
 
-  avm_anticipate (&front, &back, &result);
 
-  while (front)
 
-    {
 
-      if (*(front->above) = (scanned_bit (&string) ? avm_join (NULL, NULL) : NULL))
 
-	{
 
-	  (*(front->above))->internal = 1;	/* needed to prevent cyclic interpretations */
 
-	  avm_anticipate (&front, &back, &((*(front->above))->head));
 
-	  avm_anticipate (&front, &back, &((*(front->above))->tail));
 
-	}
 
-      front = (old = front)->following;
 
-      avm_dispose_branch (old);
 
-    }
 
-  return (result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_multiscanned (strings)
 
-     char **strings;
 
-
 
-     /* This does the same thing as scanned list except that it
 
-        operates on null terminated array of strings instead of on a
 
-        single string. Its purpose is for building hard coded lists at
 
-        run time. Some compilers don't allow really large string
 
-        constants so this gets around that limitation by letting them
 
-        be arrays of strings. */
 
-{
 
-  list result;
 
-  branch_queue old, front, back;
 
-  char *string;
 
-  int string_number;
 
-
 
-  if (!initialized)
 
-    avm_initialize_chrcodes ();
 
-  spoke = 0;
 
-  string = strings[string_number = 0];
 
-  front = back = NULL;
 
-  avm_anticipate (&front, &back, &result);
 
-  while (front)
 
-    {
 
-      if (*string ? NULL : strings[++string_number])
 
-	string = strings[string_number];
 
-      if (*(front->above) = (scanned_bit (&string) ? avm_join (NULL, NULL) : NULL))
 
-	{
 
-	  avm_anticipate (&front, &back, &((*(front->above))->head));
 
-	  avm_anticipate (&front, &back, &((*(front->above))->tail));
 
-	}
 
-      front = (old = front)->following;
 
-      avm_dispose_branch (old);
 
-    }
 
-  return (result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-char *
 
-avm_unstrung (string, message, fault)
 
-
 
-     /* inverse of the strung function */
 
-
 
-     list string;
 
-     list *message;
 
-     int *fault;
 
-{
 
-  char *result;
 
-  counter total_length;
 
-  int temporary;
 
-  char *next_character_position;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  *message = NULL;
 
-  result = NULL;
 
-  total_length = avm_recoverable_length (string);
 
-  if (string ? (*fault = !total_length) : 0)
 
-    *message = avm_copied (counter_overflow);
 
-  else if (*fault = !(++total_length))
 
-    *message = avm_copied (counter_overflow);
 
-  else if (*fault = !(result = (char *) malloc (total_length)))
 
-    *message = avm_copied (memory_overflow);
 
-  if (*fault)
 
-    return NULL;
 
-  next_character_position = result;
 
-  while (string ? !*fault : 0)
 
-    {
 
-      if (!total_length--)
 
-	avm_internal_error (105);
 
-      temporary = avm_character_code (string->head);
 
-      if (*fault = (temporary <= 0))
 
-	*message = avm_copied (invalid_text_format);
 
-      else
 
-	*next_character_position++ = temporary;
 
-      string = string->tail;
 
-    }
 
-  if (*fault)
 
-    {
 
-      free (result);
 
-      return NULL;
 
-    }
 
-  if (!total_length)
 
-    avm_internal_error (44);
 
-  (*next_character_position) = '\0';
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-char *
 
-avm_standard_unstrung (string, message, fault)
 
-     list string;
 
-     list *message;
 
-     int *fault;
 
-
 
-     /* always uses the standard representation */
 
-{
 
-  char *result;
 
-  counter total_length;
 
-  int temporary;
 
-  char *next_character_position;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  *message = NULL;
 
-  result = NULL;
 
-  total_length = avm_recoverable_length (string);
 
-  if (string ? (*fault = !total_length) : 0)
 
-    *message = avm_copied (counter_overflow);
 
-  else if (*fault = !(++total_length))
 
-    *message = avm_copied (counter_overflow);
 
-  else if (*fault = !(result = (char *) malloc (total_length)))
 
-    *message = avm_copied (memory_overflow);
 
-  if (*fault)
 
-    return NULL;
 
-  next_character_position = result;
 
-  while (string ? !*fault : 0)
 
-    {
 
-      if (!total_length--)
 
-	avm_internal_error (71);
 
-      temporary = avm_standard_character_code (string->head);
 
-      if (*fault = (temporary <= 0))
 
-	*message = avm_copied (invalid_text_format);
 
-      else
 
-	*next_character_position++ = temporary;
 
-      string = string->tail;
 
-    }
 
-  if (*fault)
 
-    {
 
-      free (result);
 
-      return NULL;
 
-    }
 
-  if (!total_length)
 
-    avm_internal_error (40);
 
-  (*next_character_position) = '\0';
 
-  return result;
 
-}
 
-
 
-
 
-
 
-char *
 
-avm_prompt (prompt_strings)
 
-
 
-     /* This takes a list of character strings represented as lists
 
-        and returns a string of characters with 13 10 used as a
 
-        separator. */
 
-
 
-     list prompt_strings;
 
-{
 
-  list line;
 
-  counter total_length;
 
-  char *result;
 
-  char *next_character_position;
 
-  int temporary;
 
-
 
-  total_length = avm_length (prompt_strings);
 
-  if (!total_length)
 
-    return (NULL);
 
-  total_length = (total_length - 1) << 1;
 
-  if (total_length < 0)
 
-    avm_error ("counter overflow (code 5)");
 
-  total_length = total_length + avm_area (prompt_strings);
 
-  if (total_length < 0)
 
-    avm_error ("counter overflow (code 6)");
 
-  total_length++;
 
-  if (!total_length)
 
-    avm_error ("counter overflow (code 7)");
 
-  if (!(result = (char *) malloc (total_length)))
 
-    avm_error ("memory overflow (code 4)");
 
-  next_character_position = result;
 
-  while (prompt_strings)
 
-    {
 
-      line = prompt_strings->head;
 
-      while (line)
 
-	{
 
-	  if (!total_length--)
 
-	    avm_internal_error (14);
 
-          temporary = avm_character_code (line->head);
 
-          *next_character_position = temporary;
 
-	  if (temporary < 0)
 
-	    avm_error ("invalid text format (code 2)");
 
-	  else if (!(*(next_character_position++)))
 
-	    avm_error ("null character in prompt");
 
-	  line = line->tail;
 
-	}
 
-      if (prompt_strings->tail)
 
-	{
 
-	  if (total_length < 2)
 
-	    avm_internal_error (15);
 
-	  (*(next_character_position++)) = 13;
 
-	  (*(next_character_position++)) = 10;
 
-	  total_length = total_length - 2;
 
-	}
 
-      else
 
-	{
 
-	  if (!total_length--)
 
-	    avm_internal_error (16);
 
-	  (*next_character_position) = '\0';
 
-	}
 
-      prompt_strings = prompt_strings->tail;
 
-    }
 
-  return (result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-char *
 
-avm_recoverable_prompt (prompt_strings,message,fault)
 
-
 
-     list prompt_strings;
 
-     list *message;
 
-     int *fault;
 
-{
 
-  list line;
 
-  counter total_length;
 
-  char *result;
 
-  char *next_character_position;
 
-  int temporary;
 
-
 
-  *message = NULL;
 
-  if (*fault)
 
-    return NULL;
 
-  total_length = avm_length (prompt_strings);
 
-  if (!total_length)
 
-    return NULL;
 
-  total_length = (total_length - 1) << 1;
 
-  if (*fault = (total_length < 0))
 
-    {
 
-      *message = avm_copied (counter_overflow);
 
-      return NULL;
 
-    }
 
-  total_length = total_length + avm_area (prompt_strings);
 
-  if (*fault = (total_length < 0))
 
-    {
 
-      *message = avm_copied (counter_overflow);
 
-      return NULL;
 
-    }
 
-  total_length++;
 
-  if (*fault = (!total_length))
 
-    {
 
-      *message = avm_copied (counter_overflow);
 
-      return (NULL);
 
-    }
 
-  if (*fault = (!(result = (char *) malloc (total_length))))
 
-    {
 
-      *message = avm_copied (memory_overflow);
 
-      return (NULL);
 
-    }
 
-  next_character_position = result;
 
-  while (*fault ? 0 : !!prompt_strings)
 
-    {
 
-      line = prompt_strings->head;
 
-      while (*fault ? 0 : !!line)
 
-	{
 
-	  if (!total_length--)
 
-	    avm_internal_error (45);
 
-          temporary = avm_standard_character_code (line->head);
 
-          *next_character_position = temporary;
 
-	  if (*fault = (temporary < 0))
 
-	    {
 
-	      *message = avm_copied (invalid_prompt);
 
-	      free (result);
 
-	      return (NULL);
 
-	    }
 
-	  else if (*fault = !(*(next_character_position++)))
 
-	    {
 
-	      *message = avm_copied (invalid_prompt);
 
-	      free (result);
 
-	      return (NULL);
 
-	    }
 
-	  line = line->tail;
 
-	}
 
-      if (prompt_strings->tail)
 
-	{
 
-	  if (total_length < 2)
 
-	    avm_internal_error (46);
 
-	  (*(next_character_position++)) = 13;
 
-	  (*(next_character_position++)) = 10;
 
-	  total_length = total_length - 2;
 
-	}
 
-      else
 
-	{
 
-	  if (!total_length--)
 
-	    avm_internal_error (47);
 
-	  (*next_character_position) = '\0';
 
-	}
 
-      prompt_strings = prompt_strings->tail;
 
-    }
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-unpacker (package)
 
-     unsigned int *package;
 
-
 
-     /* This is used for building the array of lists used as a lookup
 
-	table by the avm_character_representation macro. */
 
-
 
-{
 
-  list left, right;
 
-
 
-  if (!(*package & 1))
 
-    {
 
-      *package >>= 1;
 
-      return (NULL);
 
-    }
 
-  *package >>= 1;
 
-  left = unpacker (package);
 
-  return ((!!(right = unpacker (package)) ? 1 : !!left) ? avm_join (left, right) : avm_copied (shared_cell));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_chrcodes ()
 
-
 
-     /* This initializes local data structures and is a good example
 
-	of backward compatibility management. */
 
-{
 
-  unsigned int package, ascii_code;
 
-
 
-  char *old_character_set = "\
 
-04d50135053504b504750275004d014d054d04cd02cd01cd012d052d032d04ad\
 
-046d026d011d051d031d009d049d029d019d045d025d043d023d013d00130053\
 
-0153055304d302d30ad306d301d311d309d305d303d301330533153313330b33\
 
-073300b304b314b30cb302b312b30ab306b301b311b309b305b303b300730473\
 
-14730c73027312730a7306730173117309730573037300f310f308f304f302f3\
 
-01f3004b014b054b154b0d4b034b134b0b4b074b00cb04cb14cb0ccb02cb12cb\
 
-0acb06cb01cb11cb09cb05cb03cb012b052b152b0d2b032b132b0b2b072b04ab\
 
-14ab0cab12ab11ab046b146b0c6b126b066b116b10eb011b051b151b0d1b031b\
 
-131b0b1b071b049b149b0c9b129b069b019b119b045b145b0c5b125b115b10db\
 
-043b143b0c3b123b113b10bb107b00470147054715470d47034713470b470747\
 
-00c704c714c70cc702c712c70ac706c701c711c709c705c703c7012705271527\
 
-0d27032713270b27072704a714a70ca712a706a701a711a70067046714670c67\
 
-12670667116710e70117051715170d17031713170b170717049714970c971297\
 
-1197045714570c571257115710d7043714370c371237113710b71077010f050f\
 
-150f0d0f030f130f0b0f070f048f148f0c8f128f044f144f0c4f124f114f10cf\
 
-042f142f0c2f122f112f10af106f041f141f0c1f121f111f031f109f105f103f";
 
-
 
-  char *character_set = "\
 
-04d50135053504b50475027504f5004d014d054d154d134d0b4d074d04cd14cd\
 
-02cd12cd0acd11cd09cd012d052d152d0d2d032d132d0b2d072d04ad14ad0cad\
 
-12ad11ad09ad046d146d026d126d0a6d116d096d10ed08ed04ed011d051d151d\
 
-131d0b1d009d049d149d0c9d029d129d0a9d119d099d059d045d145d025d125d\
 
-0a5d115d095d10dd08dd043d143d023d123d0a3d113d093d10bd08bd107d087d\
 
-001300530153055315530b53075304d302d312d30ad306d301d311d309d305d3\
 
-03d301330533153313330b3300b304b314b30cb302b312b30ab311b309b305b3\
 
-04731473027312730a731173097310f308f301f3004b054b154b034b134b0b4b\
 
-04cb14cb02cb12cb0acb11cb09cb012b052b152b0d2b132b0b2b04ab14ab0cab\
 
-12ab11ab046b126b116b10eb011b051b151b0d1b131b0b1b049b149b129b119b\
 
-045b145b0c5b125b115b10db043b123b113b10bb107b00470147054715470d47\
 
-034713470b47074704c714c702c712c70ac711c709c70127052715270d270b27\
 
-04a714a712a711a7046714671267116710e70117051715170d1713170b170497\
 
-149712971197045714570c571257115710d7043714370c371237113710b71077\
 
-010f050f150f0d0f030f130f0b0f070f048f148f128f118f044f144f124f114f\
 
-10cf042f142f0c2f122f112f10af106f041f141f0c1f121f111f109f105f103f";
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_branches ();
 
-  shared_cell = avm_join (NULL, NULL);
 
-  for (package = 0; package <= maximum_package; package++)
 
-    ascii_codes[package] = -1;
 
-  if (avm_prior_to_version ("0.1.0"))
 
-    {
 
-      for (ascii_code = 0; ascii_code <= 255; ascii_code++)
 
-	{
 
-	  sscanf (&(old_character_set[ascii_code << 2]), "%4x", &package);
 
-	  ascii_codes[package] = ascii_code;
 
-	  _avm_representations[ascii_code] = unpacker (&package);
 
-	  _avm_representations[ascii_code]->characteristic = 1;
 
-	  _avm_representations[ascii_code]->characterization = ascii_code;
 
-	}
 
-    }
 
-  else
 
-    {
 
-      for (ascii_code = 0; ascii_code <= 255; ascii_code++)
 
-	{
 
-	  sscanf (&(character_set[ascii_code << 2]), "%4x", &package);
 
-	  ascii_codes[package] = ascii_code;
 
-	  _avm_representations[ascii_code] = unpacker (&package);
 
-	  _avm_representations[ascii_code]->characteristic = 1;
 
-	  _avm_representations[ascii_code]->characterization = ascii_code;
 
-	}
 
-    }
 
-  for (ascii_code = 0; ascii_code <= 255; ascii_code++)
 
-    {
 
-      sscanf (&(character_set[ascii_code << 2]), "%4x", &package);
 
-      standard_ascii_codes[package] = ascii_code;
 
-      _avm_standard_representations[ascii_code] = unpacker (&package);
 
-      _avm_standard_representations[ascii_code]->characteristic = 1;
 
-      _avm_standard_representations[ascii_code]->characterization = ascii_code;
 
-    }
 
-  invalid_prompt = avm_join (avm_strung ("invalid prompt"), NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  counter_overflow = avm_join (avm_strung ("counter overflow"), NULL);
 
-  invalid_text_format = avm_join (avm_strung ("invalid text format"), NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_chrcodes ()
 
-
 
-     /* This uninitializes local storage so that memory leaks can be
 
-	detected. */
 
-
 
-{
 
-
 
-  int ascii_code;
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (shared_cell);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (invalid_prompt);
 
-  avm_dispose (counter_overflow);
 
-  avm_dispose (invalid_text_format);
 
-  counter_overflow = NULL;
 
-  memory_overflow = NULL;
 
-  invalid_text_format = NULL;
 
-  invalid_prompt = NULL;
 
-  shared_cell = NULL;
 
-  for (ascii_code = 0; ascii_code < 256; ascii_code++)
 
-    {
 
-      avm_dispose (_avm_representations[ascii_code]);
 
-      avm_dispose (_avm_standard_representations[ascii_code]);
 
-    }
 
-}

+ 0 - 520
src/cmdline.c
View File 

@@ -1,520 +0,0 @@
 
-
 
-/* functions for command line parsing and environment variables
 
-
 
-   Copyright (C) 2006,2010 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.  
-
 
-*/
 
-
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/branches.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/rawio.h>
 
-#include <avm/formin.h>
 
-#include <avm/formout.h>
 
-#include <avm/fnames.h>
 
-#include <avm/cmdline.h>
 
-#include <time.h>
 
-#if HAVE_ARGZ_H
 
-#include <argz.h>
 
-#endif
 
-
 
-#ifndef HAVE_MEMMOVE
 
-extern void 
-*memmove(char *dest, const char *source, unsigned length)
 
-#endif
 
-
 
-/* Non-zero means static variables have been initialized. */
 
-static int initialized = 0;
 
-
 
-/* Non-zero means standard input has been read and stored already. */
 
-static int stdin_cached = 0;
 
-
 
-/* represents (nil,nil) */
 
-static list shared_cell = NULL;
 
-
 
-/* stores a list representation of the standard input file */
 
-static list stdin_cache = NULL;
 
-
 
-/* Non-zero means the user has already been warned that search paths
 
-   aren't supported. */
 
-static int warned = 0;
 
-
 
-
 
-
 
-
 
-static void
 
-match_file (argv, source, filename, extension, search_paths, search_paths_length)
 
-     char *argv;
 
-     FILE **source;
 
-     char **filename;
 
-     char *extension;
 
-     char *search_paths;
 
-     size_t search_paths_length;
 
-
 
-     /* This finds the full file name using search paths and default
 
-        extensions, and opens it as source. */
 
-{
 
-  char *search_path;
 
-  char *entry;
 
-  int absolute, relative, extensible;
 
-  size_t count;
 
-
 
-  absolute = 0;
 
-  relative = 0;
 
-  *source = NULL;
 
-  *filename = NULL;
 
-  entry = argv;
 
-  while (entry ? strstr (entry, avm_path_separator_string) : 0)
 
-    entry++;
 
-  while (entry ? ((*entry) == '.') : 0)
 
-    entry++;
 
-  extensible = (entry ? (!strstr (entry, ".")) : 0);
 
-  entry = NULL;
 
-#if HAVE_ARGZ_H
 
-  while ((*filename)?0:(absolute?0:(entry=(search_paths?argz_next(search_paths,search_paths_length,entry):(entry?NULL:".")))))
 
-    {
 
-#else /* not HAVE_ARGZ_H */
 
-  while ((*filename) ? 0 : (absolute ? 0 : (entry = (entry ? NULL : "."))))
 
-    {
 
-#endif /* HAVE_ARGZ_H */
 
-      if (!(search_path = (char *) malloc (strlen (argv) + strlen (entry) + strlen (avm_path_separator_string) + 1)))
 
-	avm_error ("memory overflow (code 14)");
 
-      else if (relative)
 
-	strcat (strcat (strcpy (search_path, entry), avm_path_separator_string), argv);
 
-      else
 
-	{
 
-	  absolute = strstr (argv, avm_current_directory_prefix) == argv;
 
-	  absolute = (absolute ? 1 : (strstr (argv, avm_parent_directory_prefix) == argv));
 
-	  if (absolute = (absolute ? 1 : (strstr (argv, avm_root_directory_prefix) == argv)))
 
-	    strcpy (search_path, argv);
 
-	  else
 
-	    {
 
-	      relative = 1;
 
-	      strcat (strcat(strcpy (search_path, entry), avm_path_separator_string), argv);
 
-	    }
 
-	}
 
-      if (*source = fopen (search_path, "rb"))
 
-	{
 
-	  if (!(*filename = (char *) malloc (strlen (search_path) + 5)))
 
-	    avm_error ("memory overflow (code 5)");
 
-	  else
 
-	    strcpy (*filename, search_path);
 
-	}
 
-      else if (extensible ? (extension ? !((*filename) = (char *) malloc(strlen(search_path)+1+strlen(extension))) : 0) : 0)
 
-	avm_error ("memory overflow (code 6)");
 
-      else if (extensible ? (extension ? !(*source = fopen(strcat(strcpy(*filename,search_path),extension),"rb")) : 1) : 0)
 
-	{
 
-	  if (*filename)
 
-	    {
 
-	      free (*filename);
 
-	      *filename = NULL;
 
-	    }
 
-	  if (!(*filename = (char *) malloc (strlen (search_path) + 5)))
 
-	    avm_error ("memory overflow (code 7)");
 
-	  if (!(*source = fopen (strcat (strcpy (*filename, search_path), ".avm"),"rb")))
 
-	    {
 
-	      free (*filename);
 
-	      if (!(*filename = (char *) malloc (strlen (search_path) + 5)))
 
-		avm_error ("memory overflow (code 8)");
 
-	      if (!(*source = fopen (strcat (strcpy (*filename, search_path), ".fun"),"rb")))
 
-		{
 
-		  free (*filename);
 
-		  *filename = NULL;
 
-		}
 
-	    }
 
-	}
 
-      free (search_path);
 
-    }
 
-  if (!*source)
 
-      avm_fatal_io_error ("can't read", argv, errno);
 
-  if (strstr (*filename, avm_current_directory_prefix) == *filename)
 
-    {
 
-      count = strlen (*filename) - strlen (avm_current_directory_prefix) + 1;
 
-      memmove (*filename, (*filename) + strlen (avm_current_directory_prefix), count);
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-cached_stdin ()
 
-
 
-  /* This returns a copy of standard input represented as a list. The
 
-     first time it's called, it reads from standard input, but
 
-     subsequently it returns a cached copy. */
 
-{
 
-  char buffer[26];
 
-  time_t the_time;
 
-  char *now;
 
-  list front_character, back_character;
 
-
 
-  if (!stdin_cached)
 
-    {
 
-      the_time = time (NULL);
 
-#if HAVE_CTIME_R
 
-      ctime_r (&the_time, buffer);
 
-      now = buffer;
 
-#else /* not HAVE_CTIME_R */
 
-      now = ctime (&the_time);
 
-#endif /* HAVE_CTIME_R */
 
-      front_character = back_character = NULL;
 
-      while (*now ? (*now != '\n') : 0)
 
-	avm_enqueue (&front_character, &back_character, avm_character_representation (*(now++)));
 
-      stdin_cache = avm_join (avm_join (front_character, NULL), avm_preamble_and_contents (stdin, NULL));
 
-      stdin_cached = 1;
 
-    }
 
-  return avm_copied (stdin_cache);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_default_command_line (argc, argv, index, extension, paths, default_to_stdin_mode, force_text_input_mode, file_ordinal)
 
-     int argc;
 
-     char *argv[];
 
-     int index;
 
-     char *extension;
 
-     char *paths;		/* a colon separated list of directory names */
 
-     int default_to_stdin_mode;
 
-     int force_text_input_mode;
 
-     int *file_ordinal;
 
-
 
-     /* This function returns a list of the files and options given in
 
-        the command line starting from the argument indicated by the
 
-        index. By default, command lines are interpreted subject to
 
-        the following conventions.
 
-
 
-        1) An argument is treated as a keyword iff it meets these three conditions.
 
-          a) It starts with a dash.
 
-          b) It doesn't contain an equals sign.
 
-          c) It doesn't consist solely of a dash.
 
-
 
-        2) An argument is treated as a parameter list iff it meets these four conditions.
 
-          a) It doesn't begin with a dash.
 
-          b) It either begins with an equals sign or doesn't contain one.
 
-          c) It immediately follows an argument beginning with a dash and not
 
-             containing an equals sign.
 
-          d) At least one of the following is true.
 
-            1) It doesn't contain a period, asterisk, tilde, or slash.
 
-            2) It contains a comma.
 
-            3) It can be interpreted as a C style floating point number.
 
-
 
-        3) An argument is treated as an input file name iff it meets these four conditions.
 
-          a) It doesn't begin with a dash.
 
-          b) It doesn't contain an equals sign.
 
-          c) It doesn't contain a comma.
 
-          d) At least one of the following is true.
 
-            1) It contains a period, asterisk, tilde, or slash.
 
-            2) It doesn't immediately follow an argument beginning with a
 
-               dash and not containing an equals sign.
 
-
 
-        4) If an argument contains an equals sign but doesn't begin with one,
 
-           the part on the left of the equals sign is treated as a keyword and
 
-           the part on the right is treated as a parameter list.
 
-
 
-        5) An argument consisting solely of a dash is taken to represent the
 
-           standard input file.
 
-
 
-        6) An argument not fitting any of the above classifications is an
 
-           error.
 
-
 
-        Options are represented as ((position,longform),(keyword,parameters)),
 
-        and files are represented as ((date,path),(preamble,contents)).
 
-
 
-        If the file_ordinal parameter is non-null, then all file parameters in
 
-        the command line are ignored except for that of the given ordinal and
 
-        standard input. If there is no such file, then a NULL value is
 
-        returned for the whole command line.  Otherwise, the ordinal is
 
-        incremented. */
 
-
 
-#define fileish(s) ((sscanf(s,"%e",&temporary_double)==1)?0:\
 
-  (strchr(s,'.')?1:strchr(s,avm_path_separator_character)?\
 
-  1:strchr(s,'*')?1:*(s)=='~'?strcmp(argv[index],"~"):0))
 
-
 
-{
 
-  double temporary_double;
 
-  char *search_paths;		/* a null separated list of directory names */
 
-  FILE *source;
 
-  char *filename;
 
-  char *keyword;
 
-  char *parameter;
 
-  counter position;
 
-  int file_counter;
 
-  int parameters_expected;
 
-  list longform;
 
-  size_t search_paths_length;
 
-  list front_file, back_file, front_option, back_option, front_parameter,
 
-    back_parameter, front_character, back_character, temporary, file_buffer;
 
-
 
-  if (!initialized)
 
-    avm_initialize_cmdline ();
 
-  search_paths = NULL;
 
-  search_paths_length = 0;
 
-#if HAVE_ARGZ_H
 
-  if (paths ? argz_add_sep (&search_paths, &search_paths_length, paths, ':') : 0)
 
-    avm_error ("memory overflow (code 13)");
 
-#else /* not HAVE_ARGZ_H */
 
-  if (paths ? !warned : 0)
 
-    {
 
-      warned = 1;
 
-      avm_warning ("warning: search paths not supported");
 
-    }
 
-#endif /* HAVE_ARGZ_H */
 
-  position = parameters_expected = file_counter = 0;
 
-  front_file = back_file = front_option = back_option = NULL;
 
-  while (index < argc)
 
-    {
 
-      /*printf("argv[%d] = %s\n",index,argv[index]);*/
 
-      if (!(argv[index]))
 
-	avm_internal_error (17);
 
-      else if (!strcmp (argv[index], "-"))
 
-	{
 
-	  parameters_expected = 0;
 
-	  avm_enqueue (&front_file, &back_file, cached_stdin ());
 
-	  position++;
 
-	}
 
-      else if (strchr (argv[index], '=') ? (*(argv[index]) != '=') : 0)
 
-	{
 
-	  parameters_expected = 0;
 
-	  keyword = (((*(argv[index])) == '-') ? (1 + argv[index]) : argv[index]);
 
-	  front_character = back_character = longform = NULL;
 
-	  if ((*keyword) == '-')
 
-	    {
 
-	      keyword++;
 
-	      longform = avm_copied (shared_cell);
 
-	    }
 
-	  while ((*keyword) != '=')
 
-	    avm_enqueue (&front_character, &back_character,avm_character_representation (*(keyword++)));
 
-	  temporary = front_character;
 
-	  parameter = ++keyword;
 
-	  front_parameter = back_parameter = front_character = back_character = NULL;
 
-	  while (*parameter)
 
-	    {
 
-	      if ((*parameter) != ',')
 
-		avm_enqueue (&front_character, &back_character,avm_character_representation (*(parameter++)));
 
-	      else
 
-		{
 
-		  avm_enqueue (&front_parameter, &back_parameter,front_character);
 
-		  front_character = back_character = NULL;
 
-		  parameter++;
 
-		}
 
-	    }
 
-	  if (front_character)
 
-	    avm_enqueue (&front_parameter, &back_parameter,front_character);
 
-	  temporary = avm_join (avm_join (avm_natural (position++), longform),avm_join (temporary, front_parameter));
 
-	  avm_enqueue (&front_option, &back_option, temporary);
 
-	}
 
-      else if (*(argv[index]) == '-')
 
-	{
 
-	  parameters_expected = 1;
 
-	  keyword = argv[index] + 1;
 
-	  front_character = back_character = longform = NULL;
 
-	  if ((*keyword) == '-')
 
-	    {
 
-	      keyword++;
 
-	      longform = avm_copied (shared_cell);
 
-	    }
 
-	  while (*keyword)
 
-	    avm_enqueue (&front_character, &back_character,avm_character_representation (*(keyword++)));
 
-	  temporary = avm_join (avm_join (avm_natural (position++), longform),avm_join (front_character, NULL));
 
-	  avm_enqueue (&front_option, &back_option, temporary);
 
-	}
 
-      else if (parameters_expected)
 
-	{
 
-	  parameters_expected = 0;
 
-	  if (*(argv[index]) == '=' ? 1 : (strchr (argv[index], ',') ? 1 : !fileish (argv[index]) ))
 
-	    {
 
-	      parameter = (((*(argv[index])) == '=') ? (1 + argv[index]) : argv[index]);
 
-	      front_parameter = back_parameter = front_character = back_character = NULL;
 
-	      while (*parameter)
 
-		if ((*parameter) != ',')
 
-		  avm_enqueue (&front_character, &back_character,avm_character_representation (*(parameter++)));
 
-		else
 
-		  {
 
-		    avm_enqueue (&front_parameter, &back_parameter, front_character);
 
-		    front_character = back_character = NULL;
 
-		    parameter++;
 
-		  }
 
-	      avm_enqueue (&front_parameter, &back_parameter, front_character);
 
-	      back_option->head->tail->tail = front_parameter;
 
-	    }
 
-	  else 
-	    {
 
-	      if (file_ordinal ? (file_counter++ == *file_ordinal) : 1)
 
-		{
 
-		  match_file (argv[index], &source, &filename, extension,search_paths, search_paths_length);
 
-		  temporary = avm_join (avm_date_representation (filename),avm_path_representation (filename));
 
-		  if (force_text_input_mode)
 
-		    file_buffer = avm_join (NULL,avm_load (source, filename,0));
 
-		  else
 
-		    file_buffer = avm_preamble_and_contents (source,filename);
 
-		  avm_enqueue (&front_file, &back_file,avm_join (temporary, file_buffer));
 
-		  free (filename);
 
-		  position++;
 
-		}
 
-	    }
 
-	}
 
-      else if (file_ordinal ? (file_counter++ == *file_ordinal) : 1)
 
-	{
 
-	  parameters_expected = 0;
 
-	  match_file (argv[index], &source, &filename, extension,search_paths, search_paths_length);
 
-	  temporary = avm_join (avm_date_representation (filename),avm_path_representation (filename));
 
-	  if (force_text_input_mode)
 
-	    file_buffer = avm_join (NULL,avm_load (source, filename,0));
 
-	  else
 
-	    file_buffer = avm_preamble_and_contents (source,filename);
 
-	  avm_enqueue (&front_file, &back_file,avm_join (temporary, file_buffer));
 
-	  free (filename);
 
-	  position++;
 
-	}
 
-      index++;
 
-    }
 
-  if (front_file ? 0 : (default_to_stdin_mode ? !file_ordinal : 0))
 
-    {
 
-      avm_enqueue (&front_file, &back_file, cached_stdin ());
 
-      stdin_cached = 0;
 
-      avm_dispose (stdin_cache);
 
-      stdin_cache = NULL;
 
-    }
 
-#if HAVE_ARGZ_H
 
-  if (search_paths)
 
-    free (search_paths);
 
-#endif /* HAVE_ARGZ_H */
 
-  if (file_ordinal)
 
-    {
 
-      if (front_file ? (stdin_cached ? (!!(front_file->tail)) : 1) : 0)
 
-	{
 
-	  (*file_ordinal)++;
 
-	  return (avm_join (front_file, front_option));
 
-	}
 
-      else
 
-	{
 
-	  avm_dispose (front_option);
 
-	  avm_dispose (front_file);
 
-	  return (NULL);
 
-	}
 
-    }
 
-  else
 
-    {
 
-      if (stdin_cached)
 
-	{
 
-	  stdin_cached = 0;
 
-	  avm_dispose (stdin_cache);
 
-	  stdin_cache = NULL;
 
-	}
 
-      if (front_file)
 
-	return avm_join (front_file, front_option);
 
-      return (front_option ? avm_join (front_file, front_option) : NULL);
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_environment (env)
 
-     char *env[];
 
-
 
-     /* This returns a list of pairs (identifier,setting) given a
 
-        pointer to a null terminated array of pointers to null
 
-        terminated strings. */
 
-{
 
-  int index;
 
-  char *variable;
 
-  list temporary, front_character, back_character, front_variable, back_variable;
 
-
 
-  if (!initialized)
 
-    avm_internal_error (18);
 
-  index = 0;
 
-  front_variable = back_variable = NULL;
 
-  while (env[index])
 
-    {
 
-      front_character = back_character = NULL;
 
-      variable = env[index++];
 
-      while ((*variable) ? ((*variable) != '=') : 0)
 
-	avm_enqueue (&front_character, &back_character,avm_character_representation (*(variable++)));
 
-      temporary = front_character;
 
-      front_character = back_character = NULL;
 
-      if (*variable)
 
-	variable++;
 
-      while (*variable)
 
-	avm_enqueue (&front_character, &back_character,avm_character_representation (*(variable++)));
 
-      avm_enqueue (&front_variable, &back_variable,avm_join (temporary, front_character));
 
-    }
 
-  return front_variable;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_cmdline ()
 
-     /* This initializes some local data structures. */
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_branches ();
 
-  avm_initialize_chrcodes ();
 
-  avm_initialize_fnames ();
 
-  avm_initialize_formout ();
 
-  avm_initialize_formin ();
 
-  stdin_cache = NULL;
 
-  stdin_cached = 0;
 
-  shared_cell = avm_join (NULL, NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_cmdline ()
 
-     /* This frees up some local data structures, including the cached
 
-        copy of standard input represented as a list. */
 
-{
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  warned = 0;
 
-  avm_dispose (shared_cell);
 
-  shared_cell = NULL;
 
-  if (stdin_cached)
 
-    {
 
-      stdin_cached = 0;
 
-      avm_dispose (stdin_cache);
 
-      stdin_cache = NULL;
 
-    }
 
-}

+ 0 - 77
src/com.fun
View File 

@@ -1,77 +0,0 @@
 
-
 
-#import std
 
-
 
-#comment -[
 
-This file contains compatible replacements for most of the core virtual
 
-machine combinators defined in cor.fun, expressed only in terms of
 
-constant, conditional, compose, couple, field, and recur. This
 
-information may be useful for abstract interpretation. The source
 
-is distributed with both the fun compiler and the avram virtual
 
-machine emulator but the compiler is needed to compile it.
 
-
 
-Copyright (c) 2005 Dennis Furey]-
 
-
 
-#optimize+
 
-
 
-successor  = ~&aahPNfatPRCNNXatPCQNNXNCq
 
-sum        = ~&al^?\~&ar ~&ar?\~&al ~&alh?(~&arh?(successor+ ~&NNXfabt2RC,~&NNXfabt2RC),~&arh?(~&NNXfabt2RC,~&Nfabt2RC))
 
-replace    = ~&ar^?\~&falNNXXPR ~&alll? ~&allr?~~/(~&falbr3falbl2rXPRXR,~&falllPrXPrlPXPRarr2X) (~&arl2fallrPrXPrrPXPRX,~&alr)
 
-
 
-#library+  # those expressed in terms of the refer combinator will require further rewriting but will still terminate
 
-
 
-profile    = ~&l
 
-guard      = ~&l
 
-note       = ~&l
 
-refer      = //~&R
 
-iterate    = ^?^/-+~&a;,~&l+- ~&\~&a+ ^R/~&f+ ~&a;+ ~&r
 
-reduce     = ~&?^\!+~&r ~&h++ iterate/~&t+ ~&aitB^?\~&a+ ^\~&fatt2R+ ~&ahthPX;+ ~&l
 
-sort       = ~&iNCS;+ reduce\0+ ~&al^?\~&ar+ ~&ar?\~&al+ ~&abh;; \/? ~&/~&alh2faltPrXPRC ~&arh2falrtPXPRC
 
-transfer   = +^\-+//~&,~&iNH+- ~&l&&+ cat^/~&lr+ ~&llPrX;+ ~&rrrPlfPrlPlaritB3XRTB^:+ ~&alrihBPX;; ^/~&
 
-map        = ~&a^&+ ^\~&fatPR+ ~&ah;
 
-filter     = ~&a^&+ ?\(~&ahPfatPRC,~&fatPR)+ ~&ah;
 
-fan        = ~&lrNCC;+ ~&hthPX++ map
 
-compare    = ~&alParPfabl2Rfabr2RBBarZPq
 
-reverse    = ~&NiXarPfarhPlCrtPXPRaql
 
-distribute = ~&arPalrhPXPfalrtPXPRCNq
 
-weight     = ~&a^& successor+ sum+ ~&W
 
-member     = ~&ar^& !|~&falrtPXPR compare+ ~&alrhPX
 
-cat        = ~&alPalh2faltPrXPRCarPq
 
-transpose  = ~&ah^& :^(map~&h+ ~&a,^R/~&f map~&t+ ~&a)
 
-assign     = replace++ ^\~&+ ^^/!+~&l ~&r
 
-mapcur     = (map ~&R)++ distribute++ ~
 
-recur      = ~&R++ ~
 
-
 
-#library-
 
-
 
-u = %+ !+ ~&iNC+ 'unrecognized combinator (code '--+ --')'+ ~&h+ %nP
 
-i = %+ !+ ~&iNC+ 'irreducible combinator (code '--+ --')'+ ~&h+ %nP
 
-
 
-#comment-
 
-
 
-#output * file$[
 
-   stamp: &!,
 
-   path: ~&iNC+ --'.c'+ ~&n,
 
-   contents: ~&m; -+
 
-      //-- ~&NiC --<''> <
 
-         '/* This is the virtual machine code expressed as a c formatted character',
 
-         '   constant for a function that takes a virtual machine program to an equivalent',
 
-         '   program by translating the top level combinator into more primitive',
 
-         '   combinators if possible. */'>,
 
-      --<''>+ ^lrNCT(~&y; * --'\',~&z)+ ~&a^& ^JalPfarPRC/~&f ~&a; ^(take/79,skip/79); ->~&lyPlzPrCX ~&l&& ~&lz==`\,
 
-      'char *interpreter_code = "'--+ --'";'+ `\?=(~&iiNCC,~&iNC)*=+ ~&xttx+ ~&tt+ ~=` *~+ ~&L+ %xP+-]
 
-
 
-#library+
 
-
 
-rewrite = # used as the interpreter code in apply.c, in the virtual machine emulator source code
 
-
 
-~&l?\(~&r?/i0 compare!) ~&r?(
 
-   ~&ll?/(~&lr?/i1 i2) ~&lr?/i3 ~&r; ~&l?\(~&r?\cat! ~&r; ~&l?(~&r?/iterate filter+ ~&l,~&r?/transfer+~&r reverse!)) ~&r?(
 
-      ~&ll?(
 
-         ~&lr?(&?=r/i4 u0,&?=r/sort+~&ll -&~&ll==&,~&lrZ,~&rrZ,~&rl,~&rllZ&-?/i5 u1),
 
-         ~&lr?/(&?=r/fan+~&lr u2) ~&r; ~&l?/(~&r?/i6 mapcur+ ~&l) ~&r?(
 
-            ~&r; ~&l?(~&r?/u3 ~&l; ~&l?/profile i7,~&r?\weight! ~&r; ~&l?/note u4),
 
-            transpose!)),
 
-      ~&l; ~&l?/reduce ~&r?/map+~&r member!),
 
-   ~&l; ~&l?\i8 ~&r?/i9 ~&l; ~&l?(
 
-      ~&r?\refer+~&l guard(replace,<'invalid deconstruction'>?=\~& <'invalid assignment'>!)++ ^\~&+ ^^/!+~&l ~&r,
 
-      ~&r?/recur+~&r distribute!))

+ 0 - 318
src/compare.c
View File 

@@ -1,318 +0,0 @@
 
-
 
-/* this file contains routines for something like lazy comparison
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/branches.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/compare.h>
 
-
 
-struct decision_node
 
-{
 
-  branch left_operand, right_operand;
 
-  struct decision_node *consequence;
 
-  struct decision_node *successor;
 
-};
 
-
 
-typedef struct decision_node *decision;
 
-
 
-#define decision_cache_size 0xff
 
-
 
-/* represents (nil,nil) */
 
-static list shared_cell;
 
-
 
-/* error messages represented as lists of lists of character representations */
 
-static list memory_overflow;
 
-static list invalid_comparison;
 
-
 
-/* non-zero means static variables have been initialized */
 
-static int initialized = 0;
 
-
 
-/* a cache of decision nodes */
 
-static decision available_decision = NULL;
 
-
 
-/* the number of decision nodes in the cache */
 
-static int available_decisions = 0;
 
-
 
-/* the total number of allocated decisions (excluding the cache) */
 
-static counter extant_decisions = 0;
 
-
 
-
 
-
 
-
 
-static int
 
-considered (left_operand, right_operand, consequence, consideration)
 
-     branch left_operand;
 
-     branch right_operand;
 
-     decision consequence;
 
-     decision *consideration;
 
-
 
-     /* This creates a new decision node and pushes it onto a stack
 
-        addressed by consideration. */
 
-
 
-{
 
-  int success;
 
-  decision result;
 
-
 
-  extant_decisions++;
 
-  if (success = !!(result = available_decision))
 
-    {
 
-      available_decision = available_decision->successor;
 
-      available_decisions--;
 
-    }
 
-  else
 
-    success = !!(result = (decision) malloc (sizeof (*result)));
 
-  if (success)
 
-    {
 
-      result->left_operand = left_operand;
 
-      result->right_operand = right_operand;
 
-      result->consequence = consequence;
 
-      result->successor = *consideration;
 
-      *consideration = result;
 
-    }
 
-  return (success);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-conclude (old_comparison)
 
-     decision old_comparison;
 
-
 
-     /* This frees up a decision node, possibly caching it for later
 
-	use. */
 
-
 
-{
 
-
 
-  extant_decisions--;
 
-  if (available_decisions > decision_cache_size)
 
-    free (old_comparison);
 
-  else
 
-    {
 
-      old_comparison->successor = available_decision;
 
-      available_decision = old_comparison;
 
-      available_decisions++;
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_comparison (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* This algorithm is meant to perform comparison of lists as
 
-        quickly, efficiently, and reliably as possible. It works by
 
-        making a decision node. A decision node points to a couple of
 
-        lists whose equality needs to be determined. If the equality
 
-        can not be immediately inferred by pointer comparison or
 
-        comparison of the characterization fields, then two more
 
-        decision nodes are created, one for the pair of heads and one
 
-        for the pair of tails. These decision nodes are pushed into a
 
-        stack of decision nodes addressed by the successor field of
 
-        the one in question. The pair of tails is pushed first, and
 
-        then the heads. The one with the pair of tails has a
 
-        consequence field pointing back to the decision node in
 
-        question, but the one with the pair of heads has a NULL
 
-        consequence field. If the pair of tails is found subsequently
 
-        to be equal, that will imply that the whole lists in the
 
-        decision node in question are equal, because the heads will
 
-        have been already compared by the time the tails are compared
 
-        and the algorithm would have terminated if a difference were
 
-        detected. Therefore, whenever equality is detected (either by
 
-        pointer equality or equality of characterization fields), the
 
-        trail of consequence fields is followed until the a NULL
 
-        pointer is reached. For each decision node visited by way of
 
-        the consequence field when equality is detected, the less
 
-        shared list of the pair is disposed of, and made to point to
 
-        the more shared one. This operation not only saves memory but
 
-        will make the comparison faster if these same operands are
 
-        compared again. */
 
-
 
-{
 
-  int inequality_detected;
 
-  decision consideration, comparisand, irrelevance, implicant;
 
-
 
-
 
-#define current_tails &((*(consideration->left_operand))->tail),&((*(consideration->right_operand))->tail)
 
-#define current_heads &((*(consideration->left_operand))->head),&((*(consideration->right_operand))->head)
 
-#define unequal_characters(left,right) (left)->characterization!=(right)->characterization
 
-#define more_shared(left,right) (left)->sharers>(right)->sharers?1:(left)->sharers<(right)->sharers?0:left<right
 
-  /*
 
-#define preferable(left,right) left?((left)->characteristic?(\
 
-(right)->characteristic?(more_shared(left,right)):1):\
 
-(right)->characteristic?0:more_shared(left,right)):1
 
-  */
 
-#define preferable(left,right) left?(((left)->characteristic ? 1 : !!((left)->value))?( \
 
-((right)->characteristic ? 1 : !!((right)->value))?(more_shared(left,right)):1): \
 
-((right)->characteristic ? 1 : !!((right)->value))?0:more_shared(left,right)):1
 
-
 
-
 
-#define infer_equalities(predicate)					\
 
-  {									\
 
-    consideration = (comparisand = consideration)->successor;		\
 
-    while ((implicant = comparisand)->consequence)			\
 
-      {									\
 
-	comparisand = implicant->consequence;				\
 
-	if (predicate(*(comparisand->left_operand), *(comparisand->right_operand))) \
 
-	  {								\
 
-	    if (!((*(comparisand->right_operand))->discontiguous))	\
 
-	      {								\
 
-		avm_dispose (*(comparisand->right_operand));		\
 
-		*(comparisand->right_operand) = avm_copied (*(comparisand->left_operand)); \
 
-	      }								\
 
-	  }								\
 
-	else if (!((*(comparisand->left_operand))->discontiguous))	\
 
-	  {								\
 
-	    avm_dispose (*(comparisand->left_operand));			\
 
-	    *(comparisand->left_operand) = avm_copied (*(comparisand->right_operand)); \
 
-	  }								\
 
-	conclude (implicant);						\
 
-      }									\
 
-    conclude (comparisand);						\
 
-  }
 
-
 
-
 
-  if (!initialized)
 
-    avm_initialize_compare ();
 
-  consideration = NULL;
 
-  inequality_detected = 0;
 
-  if (*fault = !operand)
 
-    return (avm_copied (invalid_comparison));
 
-  if (*fault = !considered (&(operand->head), &(operand->tail), NULL,&consideration))
 
-    return (avm_copied (memory_overflow));
 
-  do
 
-    {
 
-      if (*(consideration->left_operand) == *(consideration->right_operand))
 
-	infer_equalities(preferable)
 
-      else if (!(inequality_detected = !(*(consideration->left_operand) ? *(consideration->right_operand) : 0)))
 
-	{
 
-	  if (((*(consideration->left_operand))->characteristic ? (*(consideration->right_operand))->characteristic : 0))
 
-	    {
 
-	      if(!(inequality_detected=unequal_characters(*(consideration->left_operand),*(consideration->right_operand))))
 
-		infer_equalities(more_shared)
 
-	    }
 
-	  else if (!(*fault = !considered (current_tails, consideration,&(consideration->successor))))
 
-	    {
 
-	      *fault = !considered (current_heads, NULL,&(consideration->successor));
 
-	      consideration = consideration->successor;
 
-	    }
 
-	}
 
-    }
 
-  while (inequality_detected ? 0 : *fault ? 0 : !!consideration);
 
-  while ((irrelevance = consideration))
 
-    {
 
-      consideration = irrelevance->successor;
 
-      while ((implicant = irrelevance))
 
-	{
 
-	  irrelevance = implicant->consequence;
 
-	  conclude (implicant);
 
-	}
 
-    }
 
-  return (inequality_detected ? NULL : *fault ? avm_copied (memory_overflow) : avm_copied (shared_cell));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_binary_comparison (left_operand, right_operand, fault)
 
-     list left_operand;
 
-     list right_operand;
 
-     int *fault;
 
-{
 
-  list operand;
 
-  list result;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !(operand = avm_recoverable_join(avm_copied(left_operand),avm_copied(right_operand))))
 
-    return avm_copied (memory_overflow);
 
-  result = avm_comparison (operand, fault);
 
-  avm_dispose (operand);
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_compare ()
 
-
 
-     /* This initializes some local data structures. */
 
-
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_branches ();
 
-  avm_initialize_chrcodes ();
 
-  shared_cell = avm_join (NULL, NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  invalid_comparison = avm_join (avm_strung ("invalid comparison"), NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_compare ()
 
-
 
-     /* This frees some local data structures and reports memory leaks. */
 
-
 
-{
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (shared_cell);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (invalid_comparison);
 
-  shared_cell = NULL;
 
-  memory_overflow = NULL;
 
-  invalid_comparison = NULL;
 
-  if (extant_decisions)
 
-    avm_reclamation_failure ("decisions", extant_decisions);
 
-}
 
-
 
-
 
-

+ 0 - 520
src/complexlib.c
View File 

@@ -1,520 +0,0 @@
 
-
 
-/* this file incorporates functions of complex numbers
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.  
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/compare.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/complexlib.h>
 
-#if HAVE_FENV
 
-#include <fenv.h>
 
-#endif
 
-#if HAVE_COMPLEX
 
-#include <complex.h>
 
-#endif
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list wild = NULL;
 
-static list empty_pair = NULL;
 
-static list memory_overflow = NULL;
 
-static list unrecognized_function_name = NULL;
 
-
 
-/* function names as lists of lists of character representations */
 
-static list funs = NULL;
 
-
 
-#if HAVE_FENV
 
-#if HAVE_COMPLEX
 
-
 
-typedef complex (*complex_binary_operator)(complex,complex);
 
-typedef complex (*complex_unary_operator)(complex);
 
-typedef double (*real_unary_operator)(complex);
 
-
 
-
 
-
 
-
 
-
 
-list
 
-complex_creation(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-{
 
-  list message;
 
-  double *re,*im,z[2]; /* assuming a complex is represented as two contiguous doubles, real first */
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  message = NULL;
 
-  if (*fault = !operand)
 
-    return avm_copied (empty_pair);
 
-  re = (double *) avm_value_of_list(operand->head,&message,fault);
 
-  if (*fault)
 
-    return message;
 
-  avm_dispose(message);
 
-  message = NULL;
 
-  im = (double *) avm_value_of_list(operand->tail,&message,fault);
 
-  if (*fault)
 
-    return message;
 
-  avm_dispose(message);
 
-  z[0] = *re;
 
-  z[1] = *im;
 
-  return avm_list_of_value((void *) z,sizeof(double) * 2,fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-complex_binary_evaluation(operator, operand, fault)
 
-     complex_binary_operator operator;
 
-     list operand;
 
-     int *fault;
 
-{
 
-  list message;
 
-  complex *x,*y,z;
 
-  double v[2],w[2];
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  message = NULL;
 
-  if (*fault = !operand)
 
-    return avm_copied(empty_pair);
 
-  x = (complex *) avm_value_of_list(operand->head,&message,fault);
 
-  if (*fault)
 
-    return message;
 
-  avm_dispose(message);
 
-  message = NULL;
 
-  y = (complex *) avm_value_of_list(operand->tail,&message,fault);
 
-  if (*fault)
 
-    return message;
 
-  avm_dispose(message);
 
-  feclearexcept (FE_ALL_EXCEPT);
 
-  if (avm_length(operand->head) == sizeof(complex))
 
-    {
 
-      if (avm_length(operand->tail) == sizeof(complex))
 
-	z = (*operator)(*x,*y);
 
-      else
 
-	{
 
-	  w[0] = (double) *y;
 
-	  w[1] = 0.0;
 
-	  z = (*operator)(*x,(complex) *w);
 
-	}
 
-    }
 
-  else
 
-    {
 
-      v[0] = (double) *x;
 
-      v[1] = 0.0;
 
-      if (avm_length(operand->tail) == sizeof(complex))
 
-	z = (*operator)((complex) *v,*y);
 
-      else
 
-	{
 
-	  w[0] = (double) *y;
 
-	  w[1] = 0.0;
 
-	  z = (*operator)((complex) *v,(complex) *w);
 
-	}
 
-    }
 
-  return avm_list_of_value((void *) &z,sizeof(complex),fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-complex_unary_evaluation(operator, operand, fault)
 
-     complex_unary_operator operator;
 
-     list operand;
 
-     int *fault;
 
-{
 
-  list message;
 
-  complex *x,y;
 
-  double z[2];
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  message = NULL;
 
-  x = (complex *) avm_value_of_list(operand,&message,fault);
 
-  if (*fault)
 
-    return message;
 
-  avm_dispose(message);
 
-  feclearexcept (FE_ALL_EXCEPT);
 
-  if (avm_length (operand) == sizeof(complex))
 
-    y = (*operator)(*x);
 
-  else
 
-    {
 
-      z[0] = (double) *x;
 
-      z[1] = 0.0;
 
-      y = (*operator)((complex) *z);
 
-    }
 
-  return avm_list_of_value((void *) &y,sizeof(complex),fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-real_unary_evaluation(operator, operand, fault)
 
-     real_unary_operator operator;
 
-     list operand;
 
-     int *fault;
 
-{
 
-  list message;
 
-  complex *x;
 
-  double y,z[2];
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  message = NULL;
 
-  x = (complex *) avm_value_of_list(operand,&message,fault);
 
-  if (*fault)
 
-    return message;
 
-  avm_dispose(message);
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  if (avm_length (operand) == sizeof(complex))
 
-    y = (*operator)(*x);
 
-  else
 
-    {
 
-      z[0] = (double) *x;
 
-      z[1] = 0.0;
 
-      y = (*operator)((complex) *z);
 
-    }
 
-  return avm_list_of_value((void *) &y,sizeof(double),fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static complex
 
-sum (l,r)
 
-     complex l;
 
-     complex r;
 
-
 
-{
 
-  complex x;
 
-
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  x = l + r;
 
-  return x;
 
-}
 
-
 
-
 
-
 
-static complex
 
-difference (l,r)
 
-     complex l;
 
-     complex r;
 
-
 
-{
 
-  complex x;
 
-
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  x = l - r;
 
-  return x;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-static complex
 
-inverse_difference (l,r)
 
-     complex l;
 
-     complex r;
 
-
 
-{
 
-  complex x;
 
-
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  x = r - l;
 
-  return x;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-static complex
 
-product (l,r)
 
-     complex l;
 
-     complex r;
 
-
 
-{
 
-  complex x;
 
-
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  x = l * r;
 
-  return x;
 
-}
 
-
 
-
 
-
 
-static complex
 
-quotient (l,r)
 
-     complex l;
 
-     complex r;
 
-
 
-{
 
-  complex x;
 
-
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  x = l / r;
 
-  return x;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-static complex
 
-inverse_quotient (l,r)
 
-     complex l;
 
-     complex r;
 
-
 
-{
 
-  complex x;
 
-
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  x = r / l;
 
-  return x;
 
-}
 
-
 
-
 
-
 
-
 
-#endif /* HAVE_COMPLEX */
 
-#endif /* HAVE_FENV */
 
-
 
-
 
-
 
-
 
-list
 
-avm_have_complex_call (function_name, fault)
 
-     list function_name;
 
-     int *fault;
 
-
 
-/* this reports the availability of a function */
 
-
 
-{
 
-#if HAVE_FENV
 
-#if HAVE_COMPLEX
 
-  list membership;
 
-  list comparison;
 
-  list result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_complex ();
 
-  if (*fault)
 
-    return NULL;
 
-  comparison = avm_binary_comparison (function_name, wild, fault);
 
-  if (*fault)
 
-    return comparison;
 
-  if (comparison)
 
-    {
 
-      avm_dispose(comparison);
 
-      return avm_copied(funs);
 
-    }
 
-  if (!(membership = avm_binary_membership (function_name, funs, fault)) ? 1 : *fault)
 
-    return membership;
 
-  avm_dispose(membership);
 
-  return ((*fault = !(result = avm_recoverable_join(avm_copied(function_name),NULL))) ? avm_copied(memory_overflow) : result);
 
-#endif
 
-#endif
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_complex_call (function_name, argument, fault)
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-
 
-     /* This figures out what function to call and calls it. */
 
-{
 
-#if HAVE_FENV
 
-#if HAVE_COMPLEX
 
-  list message;
 
-  int function_number;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (! initialized)
 
-    avm_initialize_complex ();
 
-  if (!(function_number = 0xff & (function_name ? function_name->characterization : 0)))
 
-    {
 
-      message = avm_position (function_name, funs, fault);
 
-      if (*fault)
 
-	return message;
 
-      if (*fault = !message)
 
-	return avm_copied (unrecognized_function_name);
 
-      function_number = message->characterization;
 
-      function_name->characterization = function_number;
 
-      avm_dispose (message);
 
-    }
 
-  switch (function_number)
 
-    {
 
-    case 1: return complex_creation (argument, fault);
 
-    case 2: return real_unary_evaluation ((real_unary_operator) &creal, argument, fault);
 
-    case 3: return real_unary_evaluation ((real_unary_operator) &cimag, argument, fault);
 
-    case 4: return real_unary_evaluation ((real_unary_operator) &carg, argument, fault);
 
-    case 5: return real_unary_evaluation ((real_unary_operator) &cabs, argument, fault);
 
-    case 6: return complex_unary_evaluation ((complex_unary_operator) &csin, argument, fault);	
-    case 7: return complex_unary_evaluation ((complex_unary_operator) &ccos, argument, fault);
 
-    case 8: return complex_unary_evaluation ((complex_unary_operator) &ctan, argument, fault);
 
-    case 9: return complex_unary_evaluation ((complex_unary_operator) &cexp, argument, fault);
 
-    case 10: return complex_unary_evaluation ((complex_unary_operator) &clog, argument, fault);
 
-    case 11: return complex_unary_evaluation ((complex_unary_operator) &conj, argument, fault);
 
-    case 12: return complex_unary_evaluation ((complex_unary_operator) &csqrt, argument, fault);
 
-    case 13: return complex_unary_evaluation ((complex_unary_operator) &csinh, argument, fault);
 
-    case 14: return complex_unary_evaluation ((complex_unary_operator) &ccosh, argument, fault);
 
-    case 15: return complex_unary_evaluation ((complex_unary_operator) &ctanh, argument, fault);
 
-    case 16: return complex_unary_evaluation ((complex_unary_operator) &casinh, argument, fault);
 
-    case 17: return complex_unary_evaluation ((complex_unary_operator) &cacosh, argument, fault);
 
-    case 18: return complex_unary_evaluation ((complex_unary_operator) &catanh, argument, fault);
 
-    case 19: return complex_unary_evaluation ((complex_unary_operator) &casin, argument, fault);
 
-    case 20: return complex_unary_evaluation ((complex_unary_operator) &cacos, argument, fault);
 
-    case 21: return complex_unary_evaluation ((complex_unary_operator) &catan, argument, fault);
 
-    case 22: return complex_binary_evaluation ((complex_binary_operator) &cpow, argument, fault);
 
-    case 23: return complex_binary_evaluation ((complex_binary_operator) &sum, argument, fault);
 
-    case 24: return complex_binary_evaluation ((complex_binary_operator) &difference, argument, fault);
 
-    case 25: return complex_binary_evaluation ((complex_binary_operator) &product, argument, fault);
 
-    case 26: return complex_binary_evaluation ((complex_binary_operator) &quotient, argument, fault);
 
-    case 27: return complex_binary_evaluation ((complex_binary_operator) &inverse_quotient, argument, fault);
 
-    case 28: return complex_binary_evaluation ((complex_binary_operator) &inverse_difference, argument, fault);
 
-    }
 
-#endif /* HAVE_COMPLEX */
 
-#endif /* HAVE_FENV */
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_complex ()
 
-
 
-     /* This initializes some static data structures. */
 
-{
 
-  list back;
 
-  int string_number;
 
-  char *funames[] = {
 
-    "create",
 
-    "creal",
 
-    "cimag",
 
-    "carg",
 
-    "cabs",
 
-    "csin",
 
-    "ccos",
 
-    "ctan",
 
-    "cexp",
 
-    "clog",
 
-    "conj",
 
-    "csqrt",
 
-    "csinh",
 
-    "ccosh",
 
-    "ctanh",
 
-    "casinh",
 
-    "cacosh",
 
-    "catanh",
 
-
 
-    "casin",
 
-    "cacos",
 
-    "catan",
 
-
 
-    "cpow",
 
-    "add",
 
-    "sub",
 
-    "mul",
 
-    "div",
 
-    "vid",
 
-    "bus",
 
-    NULL};            /* add more function names here up to a total of 255 */
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_listfuns ();
 
-  avm_initialize_chrcodes ();
 
-  wild = avm_strung("*");
 
-  empty_pair = avm_join (avm_strung ("empty pair"), NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  unrecognized_function_name = avm_join (avm_strung ("unrecognized complex function name"), NULL);
 
-  string_number = 0;
 
-  funs = back = NULL;
 
-  while (funames[string_number])
 
-    avm_enqueue (&funs, &back, avm_standard_strung (funames[string_number++]));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_complex ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (funs);
 
-  avm_dispose (wild);
 
-  avm_dispose (empty_pair);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (unrecognized_function_name);
 
-  funs = NULL;
 
-  empty_pair = NULL;
 
-  memory_overflow = NULL;
 
-  unrecognized_function_name = NULL;
 
-}

+ 0 - 245
src/decons.c
View File 

@@ -1,245 +0,0 @@
 
-
 
-/* this file contains functions supporting list deconstruction
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/branches.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/decons.h>
 
-
 
-
 
-/* A stack of these is used to avoid recursion. Each item on the stack
 
-   has the pointer, the operand, and the address where the result will
 
-   be put after it is computed. The address will be in another item
 
-   somwhere below it in the stack. */
 
-
 
-  struct point_node
 
-  {
 
-    list pointer;
 
-    list operand;
 
-    branch target;
 
-    struct point_node *dependents;
 
-  };
 
-
 
-typedef struct point_node *point;
 
-
 
-
 
-static list memory_overflow;	/* error messages */
 
-static list invalid_deconstruction;
 
-
 
-/* non-zero means static variables have been initialized */
 
-static int initialized = 0;
 
-
 
-/* a cache of unused point nodes */
 
-static point available_point = NULL;
 
-
 
-/* the number of point_nodes in the cache */
 
-static int available_points = 0;
 
-
 
-/* the maximum number of point nodes allowed in the cache */
 
-# define point_cache_size 0xf
 
-
 
-/* the total number of allocated point nodes excluding the cache */
 
-static counter extant_points = 0;
 
-
 
-
 
-
 
-
 
-static int
 
-given (pointer, operand, target, points)
 
-     list pointer;
 
-     list operand;
 
-     branch target;
 
-     point *points;
 
-
 
-     /* This pushes a point onto the stack. */
 
-{
 
-  int success;
 
-  point result;
 
-
 
-  if (success = !!(result = available_point))
 
-    {
 
-      available_point = available_point->dependents;
 
-      available_points--;
 
-    }
 
-  else
 
-    success = !!(result = (point) (malloc (sizeof (*result))));
 
-  if (success)
 
-    {
 
-      extant_points++;
 
-      result->pointer = pointer;
 
-      result->operand = operand;
 
-      result->target = target;
 
-      result->dependents = *points;
 
-      *points = result;
 
-    }
 
-  return success;
 
-}
 
-
 
-
 
-
 
-
 
-static int
 
-taken (pointer, operand, target, points)
 
-     list *pointer;
 
-     list *operand;
 
-     branch *target;
 
-     point *points;
 
-
 
-     /* This pops a point from the stack. */
 
-{
 
-  point old_point;
 
-
 
-  if (!*points)
 
-    return 0;
 
-  extant_points--;
 
-  *pointer = (*points)->pointer;
 
-  *operand = (*points)->operand;
 
-  *target = (*points)->target;
 
-  *points = (old_point = *points)->dependents;
 
-  if (available_points > point_cache_size)
 
-    free (old_point);
 
-  else
 
-    {
 
-      old_point->dependents = available_point;
 
-      available_point = old_point;
 
-      available_points++;
 
-    }
 
-  return 1;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_deconstruction (pointer, operand, fault)
 
-     list pointer;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* The pointer and operand are first pushed onto the stack.
 
-        While the stack is non-empty, the top item is examined and the
 
-        following operations performed. If the top pointer is a single
 
-        cell, the operand is copied to the target. If the top pointer
 
-        has an empty head, the tails of the pointer and the operand
 
-        are pushed. If the top pointer has an empty tail, both heads
 
-        are pushed. If the pointer has both a non-empty head and an
 
-        non-empty tail, each of them is pushed with a copy of the
 
-        operand. In the first two cases, the same target can be used
 
-        for the newly pushed item, but in the last, a new cell has to
 
-        be created and the addresses of its head and tail used. */
 
-
 
-{
 
-  int done;
 
-  list result;
 
-  int overflow;
 
-  branch target;
 
-  point points;
 
-
 
-  points = NULL;
 
-  result = NULL;
 
-  target = &result;
 
-  *fault = done = overflow = 0;
 
-  if (!pointer)
 
-    avm_internal_error (19);
 
-  do
 
-    {
 
-      while ((!(pointer->head) ^ !(pointer->tail)) ? !(*fault = !operand) : 0)
 
-	{
 
-	  if (pointer->head)
 
-	    {
 
-	      operand = operand->head;
 
-	      pointer = pointer->head;
 
-	    }
 
-	  else
 
-	    {
 
-	      operand = operand->tail;
 
-	      pointer = pointer->tail;
 
-	    }
 
-	}
 
-      if (*fault ? 0 : (pointer->head ? 0 : !(pointer->tail)))
 
-	{
 
-	  *target = avm_copied (operand);
 
-	  done = !taken (&pointer, &operand, &target, &points);
 
-	}
 
-      else if (!*fault)
 
-	{
 
-	  *target = avm_recoverable_join (NULL,NULL);
 
-	  if (!(overflow = !(*target ? given (pointer->head,operand,&((*target)->head),&points) : 0)))
 
-	    {
 
-	      target = &((*target)->tail);
 
-	      pointer = pointer->tail;
 
-	    }
 
-	}
 
-    }
 
-  while (done ? 0 : overflow ? 0 : !*fault);
 
-  while (taken (&pointer, &operand, &target, &points));
 
-  if (*fault)
 
-    {
 
-      avm_dispose (result);
 
-      return avm_copied (invalid_deconstruction);
 
-    }
 
-  if (*fault = overflow)
 
-    {
 
-      avm_dispose (result);
 
-      return avm_copied (memory_overflow);
 
-    }
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_decons ()
 
-     /* This initializes some static data. */
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_branches ();
 
-  avm_initialize_chrcodes ();
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  invalid_deconstruction =
 
-    avm_join (avm_strung ("invalid deconstruction"), NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_decons ()
 
-     /* This frees some static data and reports memory leaks. */
 
-{
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (invalid_deconstruction);
 
-  memory_overflow = NULL;
 
-  invalid_deconstruction = NULL;
 
-  if (extant_points)
 
-    avm_reclamation_failure ("points", extant_points);
 
-}

+ 0 - 161
src/error.c
View File 

@@ -1,161 +0,0 @@
 
-
 
-/* functions for reporting errors and maybe exiting
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-
 
-extern char *xstrerror ();
 
-
 
-/* the name of the program that is to appear at the beginning of error
 
-   messages */
 
-static char *program_name = NULL;
 
-
 
-
 
-#define default_program_name (program_name?program_name:"avram")
 
-
 
-
 
-void
 
-avm_set_program_name (path)
 
-     char *path;
 
-
 
-     /* This sets the program name to be used in error messages of the
 
-	form program-name: message; if none is set, avram is used by
 
-	default. */
 
-
 
-{
 
-  if (program_name)
 
-    free (program_name);
 
-  if (!(program_name = (char *) malloc (strlen (path) + 1)))
 
-    avm_error ("memory overflow (code 3)");
 
-  strcpy (program_name, path);
 
-}
 
-
 
-
 
-
 
-
 
-char *
 
-avm_program_name ()
 
-
 
-     /* This returns the address of the program name used in error
 
-	messages. */
 
-
 
-{
 
-  return default_program_name;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_internal_error (code)
 
-     int code;
 
-
 
-     /* This reports an internal error with the given code and
 
-	exits. */
 
-
 
-{
 
-  fprintf (stderr, "%s: virtual machine internal error (code %d)\n",default_program_name, code);
 
-  exit (EXIT_FAILURE);
 
-}
 
-
 
-
 
-
 
-
 
-void
 
-avm_warning (message)
 
-     char *message;
 
-
 
-     /* This prints the messae but doesn't exit. */
 
-
 
-{
 
-  fprintf (stderr, "%s: %s\n", default_program_name, message);
 
-}
 
-
 
-
 
-
 
-
 
-void
 
-avm_error (message)
 
-     char *message;
 
-
 
-     /* This prints the message and exits. */
 
-
 
-{
 
-  avm_warning (message);
 
-  exit (EXIT_FAILURE);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_reclamation_failure (entity, count)
 
-     char *entity;
 
-     counter count;
 
-
 
-     /* This non-fatally reports unreclaimed storage; entity is the
 
-	type of storage and count is the number of units. */
 
-
 
-{
 
-  fprintf (stderr, "%s: %d unreclaimed %s\n", default_program_name, (int) count, entity);
 
-}
 
-
 
-
 
-
 
-
 
-void
 
-avm_non_fatal_io_error (message, filename, reason)
 
-     char *message;
 
-     char *filename;
 
-     int reason;
 
-
 
-     /* This reports an i/o error associated with the file name for
 
-	the given reason, but doesn't exit. */
 
-
 
-{
 
-  if (reason)
 
-    {
 
-#if HAVE_STRERROR
 
-      fprintf (stderr, "%s: %s %s; %s\n", default_program_name, message,filename, xstrerror (reason));
 
-#else
 
-      fprintf (stderr, "%s: %s %s\n", default_program_name, message,filename);
 
-#endif
 
-    }
 
-  else
 
-    fprintf (stderr, "%s: %s %s\n", default_program_name, message,filename);
 
-}
 
-
 
-
 
-
 
-
 
-void
 
-avm_fatal_io_error (message, filename, reason)
 
-     char *message;
 
-     char *filename;
 
-     int reason;
 
-
 
-     /* This reports an i/o error and exits. */
 
-{
 
-  avm_non_fatal_io_error (message, filename, reason);
 
-  exit (EXIT_FAILURE);
 
-}

+ 0 - 27
src/exf.c
View File 

@@ -1,27 +0,0 @@
 
-
 
-/* a quick virtual machine program to list the available library functions;
 
-   source code is in exfsrc.fun */
 
-
 
-char *exf_code = "sqxCaCfxpnFY{VDSySAyUVO\\?r{lTNA{ne{qTgCuYxD>Si{Q]c{Sm[x<AtKE\
 
-WuX[`uRkeramlSzPUq\\qiLp][NRBnlQZPe{HqXOjYJE=[eDq_WpyxF[x^emN]myG=^SqaKwmpAyJ?c\
 
-zV>SjPQpSPR>m[MPczzOrgdQ<E[^==[ByQYjk@pbyNcuBxoAJyObgu{^TauBzzjy[lyy\\<][V?cuB{\
 
-KDkiLSjIOpNe[q\\hS@Wsc^gxXe{jXktFEyZd<a`WQYqFKHNvm{BtjoQ=LSSXnUBjQfJXzxxd>S`WkE\
 
-gDfWQPGtMawni^IXsXbB[@WxbJfBVtt<<MQQsGSGAaKDn<A`WNXjk<?rrBUFp@h\\gUK@?`MiOSGNOq\
 
-IQQ]RAKiFj\\@M\\dNLBIJGjwUVWHuFK@LA@gYaOsSypnpWIo@@DeQRGeuKH[QD@\\^?@ZjaDSAlJWx\
 
-mNveHiO]aQ=oJj[\\DcMy_JxtJxvh[Z`]GAPPWY[C_xnW?pbdT>PTuDu@qlXWkPN@^YQepcsa^QJFh?\
 
-g]\\sc{SCi?E\\K=QX@qQcSM[NoHujoliHpg^cutD_qsJvfiFbOtA{N?QPFUcg\\BiHNB[j^Xj@aYuo\
 
-G]]_=Z{<jpJfQNQEHnJ[_nKGGnkH]QFd<@wPxbzFTbfv<<{qGEnSMDOrZFAtDQIQjHnNwFcz>\\y@g^\
 
-Gx_LOn=QnX\\KS>{ttsF`yMT>]ZQquuJFZFOwWqnDHbSh{pqAZvgHezD][^KaRzF>J=ZJ[rIqaMP\\<\
 
-Uz\\=YQQoWknHAtcj^siUSg\\J[vBpaYvyUsKL<@t=Z@FQLqaQprh{jpGbbSI{\\NfdS`jGYQQvSyBM\
 
-VezMTqUTqZqkOn@_LOaLwYXuQ>nv_X>G{bIIQQquePKqR\\>][S\\wjrqSQ>oDGVFOwiQKQIXuQ`IDa\
 
-Yh{pnutHRFoYjs]eV^>DSt`SqKQAEiOOQ[]Vdu{XQYtQt<NJz?iLSPf\\=YRBJ{IYRyJqPoho^>ZqQX\
 
->XOue<TnutYYKRVBJVJVCyQKNM[QgXIgN<QKGr{NdzStAsZJpd_iNpJdsrGdfsWKRJj{GfVwfU@=Y[x\
 
-NKmGSQLePAs<c@vYNOemU@{?rdx\\NnvEJu?b\\Ko<d{HZt^of>?P]OPePwkWgzJF{_yMelWKPei]rI\
 
-B_[T_wpP?wpPlaBcTN>@iNQNPS{@`qIQPqIQO^YfOSEtz<`{?rhyI?HyI?ELeHf@qxjp>GJdD?Vn{_V\
 
-n{qF\\<t{LXvXBoqM]opqM]opn<CjjCWOer@aPnWdaPnWdzyOfnabSV`qfUn{BecGxYGq?xniYf`ndX\
 
-XndxcCHfKDvHtgS=pgIQF\\?hfdINwFf?PklHb[ZR=Nv<?xT=PgxT=Pdx_Hc{SCbqDx`\\\\KEDDIN>\
 
-IQUqpSnr?PgiNkPdGOIFte{EQPdOPdN>>gNe`z=[S\\D>><z<VpmDU{cobOHjBBHA{kpODqEHnJ[kOg\
 
-\\D\\QNf<=JyPvhB\\<Kxtd{HzFAtnWS=ohf[hn[ZR{Dp@tDc{SC_qlkzAQUqpSkPR<dSgOIFte{JFZ\
 
-FOfiFbOtAtnUZo{\\BiHNB[hnct^AxntTTlS\\_\\S_cyNOH_ct=cv<AlQNf<=JHAtcv<<{_cz]zFAt\
 
-<@t=Jnez{gx_LOfAtKS>{vezyMT>]ZI=KJFZFO^{tnUZoz<dShnct^AteJ>J=ZJ[h{\\B[d<S>DS_=Z\
 
-EtuzJ[vB\\=X<=J<LckwdV]Z<@f[dp@tG{\\FAteJozD]ZJ[d<S>[dT=D";

+ 0 - 29
src/exfsrc.fun
View File 

@@ -1,29 +0,0 @@
 
-
 
-(# This file contains the source code for the virtual machine program
 
-in exf.c. It needs the fun compiler to be compiled, which is
 
-distributed separately, but an already compiled version of exf.c
 
-generated by this code is distributed with the avram source. #)
 
-
 
-#import std
 
-#import nat
 
-#import def  # from the fun compiler source tree, for the word_wrap function
 
-
 
-#output * file$[
 
-   stamp: &!,
 
-   path: ~&iNC+ --'.c'+ ~&n,
 
-   contents: ~&m; -+
 
-      //-- ~&NiC --<''> <
 
-         '/* a quick virtual machine program to list the available library functions;',
 
-         '   source code is in exfsrc.fun */'>,
 
-      --<''>+ ^lrNCT(~&y; * --'\',~&z)+ ~&a^& ^JalPfarPRC/~&f ~&a; ^(take/79,skip/79); ->~&lyPlzPrCX ~&l&& ~&lz==`\,
 
-      'char *exf_code = "'--+ --'";'+ `\?=(~&iiNCC,~&iNC)*=+ ~&xttx+ ~&tt+ ~=` *~+ ~&L+ %xP+-]
 
-
 
-#optimize+
 
-
 
-exf =
 
-
 
-have('*','*'); :/''+ --<'',''>+ ~&?\<'no library functions found'>! |=&l; -<&hl; -+
 
-   (*= ^HlrTS\~&lNCrX zipp+ ` !*+ ~&l)^T(
 
-      ~&rhthPNCC; \/~&plrNCXS ~&H\'functions' ^lrNCC/~& `-!*,
 
-      ^p/~&rtt ^H\~&l *+ -<&;+ word_wrap+ difference/79+ length+ ~&rh),
 
-   ^/~&rSS ~&hlPS;  --' '*+ take/*40+ ~&rSS+ zipp` ^*D(leql$^,~&)+ (~&H\'library' ^lrNCC/~& `-!*)--+-

+ 0 - 946
src/exmodes.c
View File 

@@ -1,946 +0,0 @@
 
-
 
-/* execution of interactive applications and filter mode transducers
 
-
 
-   Copyright (C) 2003,2007 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/error.h>
 
-#include <avm/apply.h>
 
-#include <avm/formin.h>
 
-#include <avm/formout.h>
 
-#include <avm/rawio.h>
 
-#include <avm/exmodes.h>
 
-
 
-#ifndef HAVE_MEMMOVE
 
-extern void 
-*memmove(char *dest, const char *source, unsigned length)
 
-#endif
 
-
 
-/* points to a stack of pids */
 
-typedef struct exp_pid_node *exp_pid_stack;
 
-
 
-/* a stack of these is needed for re-entrancy */
 
-struct exp_pid_node
 
-{
 
-  int pid;
 
-  char *name;
 
-  exp_pid_stack other_pids;
 
-};
 
-
 
-/* the stack of pids whose top is referenced globally by the avm_popen and avm_pclose functions */
 
-static exp_pid_stack top = NULL;
 
-
 
-/* Non-zero means static variables have been initialized. */
 
-static int initialized = 0;
 
-
 
-/* set to true if evaluation of avm_recoverable_interact is prohibited */
 
-static int jailed = 0;
 
-
 
-/* set to true if the avm_recoverable_interact function should show debugging output */
 
-static int tracing = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list misformatted_interaction = NULL;
 
-static list failed_interaction = NULL;
 
-static list failed_interaction1 = NULL;
 
-static list failed_interaction2 = NULL;
 
-static list failed_interaction3 = NULL;
 
-static list failed_interaction4 = NULL;
 
-static list failed_interaction5 = NULL;
 
-static list failed_interaction6 = NULL;
 
-static list invalid_interaction = NULL;
 
-static list empty_command_line = NULL;
 
-static list memory_overflow = NULL;
 
-static list unable_to_open = NULL;
 
-static list unable_to_close = NULL;
 
-static list interaction_disabled = NULL;
 
-
 
-#if HAVE_EXPECT
 
-extern FILE *exp_popen ();
 
-extern int exp_pid;
 
-#endif
 
-
 
-#ifndef HAVE_MEMMOVE
 
-extern void *
 
-memmove PARAMS((char *dest, const char *source, unsigned length));
 
-#endif
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_disable_interaction () 
-
 
-{
 
-  jailed = 1;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_trace_interaction ()
 
-
 
-{
 
-  tracing = 1;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-avm_popen (pipe, output_string, tracing, stepping, fault)
 
-     FILE **pipe;
 
-     list output_string;
 
-     int tracing;
 
-     int stepping;
 
-     int *fault;
 
-
 
-     /* creates a process with exp_popen and makes a note of its pid */
 
-{
 
-#if HAVE_EXPECT
 
-  list line;
 
-  char *child;
 
-  list message;
 
-  exp_pid_stack next_top;
 
-
 
-  if (*pipe)
 
-    return NULL;
 
-  if (*fault = !(next_top = (exp_pid_stack) malloc (sizeof(*next_top))))
 
-    return avm_copied (memory_overflow);
 
-  memset (next_top, 0, sizeof(*next_top));
 
-  next_top->other_pids = top;
 
-  line = avm_recoverable_join (avm_copied (output_string), NULL);
 
-  if (*fault = !line)
 
-    {
 
-      free (next_top);
 
-      return avm_copied (memory_overflow);
 
-    }
 
-  message = NULL;
 
-  child = avm_recoverable_prompt (line, &message, fault);
 
-  avm_dispose (line);
 
-  if (*fault)
 
-    {
 
-      if (child)
 
-	free (child);
 
-      free (next_top);
 
-      return message;
 
-    }
 
-  if (child ? !strlen(child) : 1)
 
-    {
 
-      if (child)
 
-	free (child);
 
-      free (next_top);
 
-      if (tracing ? 1 : stepping)
 
-	printf("not opening empty command\n");
 
-      return NULL;
 
-    }
 
-  if (tracing)
 
-    printf("opening %s\n",child);
 
-  if (stepping)
 
-    printf ("%s\n",child);
 
-  if (*fault = !(*pipe = exp_popen (child)))
 
-    {
 
-      if (tracing ? 1 : stepping)
 
-#if HAVE_STRERROR
 
-	printf("can't open %s; %s\n", child, xstrerror (errno));
 
-#else
 
-        printf("can't open %s\n",child);
 
-#endif
 
-      free (next_top);
 
-      free (child);
 
-    }
 
-  else
 
-    {
 
-      top = next_top;
 
-      top->name = child;
 
-      top->pid = exp_pid;
 
-    }
 
-  return (*fault ? ((errno == ENOMEM) ? avm_copied (memory_overflow) : avm_copied (failed_interaction1)) : NULL);
 
-#endif
 
-  *fault = 1;
 
-  return avm_copied (failed_interaction2);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-avm_pclose (pipe, tracing, stepping, fault)
 
-     FILE **pipe;
 
-     int tracing;
 
-     int stepping;
 
-     int *fault;
 
-
 
-     /* closes the most recently opened process and waits on its pid */
 
-{
 
-#if HAVE_EXPECT
 
-  exp_pid_stack previous_top;
 
-  list message;
 
-
 
-  message = NULL;
 
-  if (!*pipe)
 
-    return message;
 
-  if (!(fclose (*pipe)))
 
-    {
 
-      if (tracing)
 
-	printf ("closing %s\n",top->name);
 
-      wait (top->pid);
 
-    }
 
-  else
 
-    {
 
-      *fault = 1;
 
-      message = avm_copied (unable_to_close);
 
-      if (tracing)
 
-	printf ("not closing %s\n",top->name);
 
-    }
 
-  *pipe = NULL;
 
-  previous_top = top;
 
-  top = top->other_pids;
 
-  free (previous_top->name);
 
-  free (previous_top);
 
-  return message;
 
-#endif
 
-  *fault = 1;
 
-  return avm_copied (unable_to_close);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-piped_out (pipe, output_strings, tracing, stepping, fault)
 
-     list output_strings;
 
-     FILE **pipe;
 
-     int tracing;
 
-     int stepping;
 
-     int *fault;
 
-
 
-     /* this sends strings out the pipe, opening if necessary with
 
-	avm_popen and the first string */
 
-{
 
-  list line,message;
 
-  int datum;
 
-
 
-  message = NULL;
 
-#if HAVE_EXPECT
 
-  while (*fault ? 0 : (output_strings ? !*pipe : 0))
 
-    {
 
-      message = avm_popen (pipe, output_strings->head, tracing, stepping, fault);
 
-      output_strings = output_strings->tail;
 
-    }
 
-  if (*fault)
 
-    return message;
 
-  if (!*pipe)
 
-    return NULL;
 
-  while (output_strings)
 
-    {
 
-      line = output_strings->head;
 
-      while (line)
 
-	{
 
-	  if (*fault = ((datum = avm_standard_character_code (line->head)) < 0))
 
-	    return avm_copied (misformatted_interaction);
 
-	  else if (*fault = (putc (datum, *pipe) != datum))
 
-	    {
 
-	      avm_dispose (avm_pclose (pipe, tracing, stepping, fault));
 
-	      return avm_copied (failed_interaction3);
 
-	    }
 
-	  if (tracing)
 
-	    printf("<- %c %u\n",datum,datum);
 
-	  line = line->tail;
 
-	}
 
-      output_strings = output_strings->tail;
 
-      if (output_strings)
 
-	{
 
-	  if (*fault = (putc (10,*pipe) != 10))
 
-	    {
 
-	      avm_dispose (avm_pclose (pipe, tracing, stepping, fault));
 
-	      return avm_copied (failed_interaction4);
 
-	    }
 
-	  if (tracing)
 
-	    printf("<-   10\n");
 
- 	}
 
-    }
 
-#endif
 
-  return message;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-line_up(front_column, back_column, front_line, back_line, datum, delayed_cr, fault)
 
-     list *front_column;
 
-     list *back_column;
 
-     list *front_line;
 
-     list *back_line;
 
-     int datum;
 
-     int *delayed_cr;
 
-     int *fault;
 
-
 
-     /* thia enqueues a datum representing a single character into a
 
-	list of lists of strings, interpreting line breaks and
 
-	suppressing terminating carriage returns */
 
-{
 
-  if (*fault)
 
-    return NULL;
 
-  if (datum == 10)
 
-    {
 
-      avm_recoverable_enqueue (front_line, back_line, *front_column, fault);
 
-      *front_column = *back_column = NULL;
 
-    }
 
-  else if (!(datum == 13 ? 1 : datum == EOF))
 
-    {
 
-      if (*delayed_cr)
 
-	avm_recoverable_enqueue (front_column, back_column, avm_standard_character_representation (13), fault);
 
-      if (!*fault)
 
-	avm_recoverable_enqueue (front_column, back_column, avm_standard_character_representation (datum), fault);
 
-    }
 
-  *delayed_cr = (datum == 13);
 
-  if (*fault)
 
-    {
 
-      avm_dispose (*front_line);
 
-      avm_dispose (*front_column);
 
-      *front_line = *back_line = NULL;
 
-      *front_column = *back_column = NULL;
 
-      return avm_copied (memory_overflow);
 
-    }
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-match (pipe, pattern, tracing, stepping, fault)
 
-     FILE **pipe;
 
-     char *pattern;
 
-     int tracing;
 
-     int stepping;
 
-     int *fault;
 
-
 
-     /* this collects strings from the pipe until the pattern is
 
-	matched */
 
-{
 
-  list message,front_column,back_column,front_line,back_line;
 
-  char *shift_register;
 
-  char *shift_register_port;
 
-  int pattern_length,datum;
 
-  int delayed_cr;
 
-
 
-  message = NULL;
 
-  front_line = back_line = NULL;
 
-  front_column = back_column = NULL;
 
-#if HAVE_EXPECT
 
-  if (*fault = !(shift_register = strdup (pattern)))
 
-    return avm_copied (memory_overflow);
 
-  pattern_length = strlen (pattern);
 
-  shift_register_port = shift_register;
 
-  while (*shift_register_port)
 
-    *(shift_register_port++) = '\0';
 
-  shift_register_port--;
 
-  delayed_cr = 0;
 
-  while (*fault ? 0 : (*pipe ? (strcmp (pattern, shift_register) ? ((datum = getc (*pipe)) != EOF) : 0) : 0))
 
-    {
 
-      if (tracing)
 
-	printf("-> %c %u\n",datum < 32 ? ' ' : (datum > 126 ? ' ' : datum),datum);
 
-      if (stepping)
 
-	printf ("%c",datum);
 
-      memmove (shift_register, shift_register + 1, pattern_length);
 
-      *shift_register_port = datum;
 
-      message = line_up (&front_column, &back_column, &front_line, &back_line, datum, &delayed_cr, fault);
 
-    }
 
-  free (shift_register);
 
-  if (*fault)
 
-    avm_dispose (avm_pclose (pipe, tracing, stepping, fault));
 
-  else if (datum == EOF)
 
-    message = avm_pclose (pipe, tracing, stepping, fault);
 
-  if (*fault)
 
-    {
 
-      avm_dispose (front_line);
 
-      avm_dispose (front_column);
 
-      return message;
 
-    }
 
-  if (front_column)
 
-    avm_recoverable_enqueue (&front_line, &back_line, front_column, fault);
 
-  if (*fault)
 
-    return avm_copied (memory_overflow);
 
-#endif
 
-  return front_line;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-piped_in (pipe, prompt_strings, tracing, stepping, fault)
 
-     FILE **pipe;
 
-     list prompt_strings;
 
-     int tracing;
 
-     int stepping;
 
-     int *fault;
 
-
 
-     /* this collects strings from the pipe until the pattern encoded
 
-	by the prompt is matched */
 
-{
 
-  char *pattern;
 
-  char *pattern_port;
 
-  list message;
 
-
 
-  message = NULL;
 
-#if HAVE_EXPECT
 
-  pattern = avm_recoverable_prompt (prompt_strings, &message, fault);
 
-  if (*fault)
 
-    return (message);
 
-  if (*fault = !pattern)
 
-    return avm_copied (failed_interaction5);
 
-  if (tracing)
 
-    {
 
-      printf("waiting for ");
 
-      pattern_port = pattern;
 
-      while (*pattern_port)
 
-        if (*(pattern_port) == 4)
 
-	  printf("EOF ",*(pattern_port++));
 
-	else
 
-	  printf("%u ",*(pattern_port++));
 
-      if (!*pattern)
 
-	printf("nothing");
 
-      printf("\n");
 
-    }
 
-  message = match (pipe, pattern, tracing, stepping, fault);
 
-  if (tracing)
 
-    {
 
-      if (!*pipe)
 
-	printf ("received EOF\n");
 
-      else if (!*fault)
 
-	printf("matched\n");
 
-    }
 
-  free (pattern);
 
-#endif
 
-  return message;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-dripped_in (pipe, tracing, stepping, fault)
 
-     FILE **pipe;
 
-     int tracing;
 
-     int stepping;
 
-     int *fault;
 
-
 
-     /* this reads a single character from the pipe */
 
-{
 
-  int datum;
 
-  list message;
 
-
 
-  message = NULL;
 
-  if (*fault)
 
-    return message;
 
-#if HAVE_EXPECT
 
-  datum = getc (*pipe);
 
-  if (tracing)
 
-    printf("-> %c %u\n",datum < 32 ? ' ' : (datum > 126 ? ' ' : datum),datum);
 
-  if (stepping)
 
-    printf("%c",datum);
 
-  if (datum == EOF)
 
-    {
 
-      if (tracing)
 
-	printf ("received EOF\n");
 
-      message = avm_pclose (pipe, tracing, stepping, fault);
 
-    }
 
-  if (!*fault)
 
-    return avm_standard_character_representation (datum);
 
-#endif
 
-  return message;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-step (pipe, interactor, interaction, step_mode, ask_to_overwrite_mode, quiet_mode, fault)
 
-     FILE **pipe;
 
-     list interactor;
 
-     list *interaction;
 
-     int step_mode;
 
-     int ask_to_overwrite_mode;
 
-     int quiet_mode;
 
-     int *fault;
 
-
 
-     /* this function performs one step of interaction between a
 
-	program invoked with the --interactive command line option and
 
-	the shell */
 
-{
 
-  list configuration,message;
 
-
 
-  if (*fault = (*fault ? 1 : !*interaction))
 
-    return;
 
-  if (!((*interaction)->tail))
 
-    {
 
-      avm_output_as_directed ((*interaction)->head, ask_to_overwrite_mode, !quiet_mode);
 
-      configuration = avm_copied (*interaction);
 
-    }
 
-  else
 
-    {
 
-      message = NULL;
 
-      avm_dispose (piped_out (pipe, (*interaction)->tail->head, 0, step_mode, fault));
 
-      if (*fault ? NULL : (*interaction)->tail->tail)
 
-	message = piped_in (pipe, (*interaction)->tail->tail, 0, step_mode, fault);
 
-      else if (!*fault)
 
-	message = dripped_in (pipe, 0, step_mode, fault);
 
-      if (*fault)
 
-	{
 
-	  avm_dispose (message);
 
-	  avm_dispose (*interaction);
 
-	  *interaction = NULL;
 
-	  return;
 
-	}
 
-      if (*fault = !(configuration = avm_recoverable_join (avm_copied((*interaction)->head), message)))
 
-	{
 
-	  avm_dispose (avm_pclose (pipe, 0, step_mode, fault));
 
-	  avm_dispose (*interaction);
 
-	  *interaction = NULL;
 
-	  return;
 
-	}
 
-    }
 
-  avm_dispose (*interaction);
 
-  *interaction = avm_recoverable_apply (avm_copied (interactor), configuration, fault);
 
-  if (*fault)
 
-    avm_dispose (avm_pclose (pipe, 0, step_mode, fault));
 
-  return;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_interact (interactor, step_mode, ask_to_overwrite_mode, quiet_mode)
 
-     list interactor;
 
-     int step_mode;
 
-     int ask_to_overwrite_mode;
 
-     int quiet_mode;
 
-
 
-/* This function executes programs invoked with the --interact command
 
-   line option.  The interactor function is initially applied to NULL
 
-   and is expected to return one of four possible results.
 
-
 
-1) a NULL result
 
-2) a result of the form (file list,NULL)
 
-3) a result of the form (state,(output strings,NULL))
 
-4) a result of the form (state,(output strings,prompt strings))
 
-
 
-Depending on the result returned, one of four possible things happens.
 
-
 
-1) If it returns NULL, nothing more is done and the program
 
-   terminates.
 
-2) If it returns (file list,NULL), the file list is output using
 
-   avm_output_as_directed, the interactor is applied to (file list,NULL),
 
-   and the cycle continues.
 
-3) If it returns (state,(output strings,NULL)), then the output
 
-   strings are sent down a pipe, a single character c is read from the
 
-   pipe, the interactor is applied to (state,c), and the cycle continues.
 
-4) If it returns (state,(output strings,prompt strings)), then the
 
-   output strings are sent down a pipe, input strings are received from
 
-   the pipe until a squence of input strings matching the prompt strings
 
-   is detected, the interactor is applied to (state,input strings) and
 
-   the cycle continues.
 
-
 
-In the third and fourth cases, above, where output has to be sent down
 
-a pipe, the pipe is opened with exp_popen if it hasn't been opened
 
-already on a previous cycle. The argument to exp_popen in such cases
 
-is the first string in the list of output strings, and only the rest
 
-of the strings get sent down the pipe.
 
-
 
-If an EOF is read from the pipe at any time, the pipe is closed. If a
 
-pipe is closed due to EOF in the third case, the interactor is applied
 
-to (state,NULL) rather than to (state,c). If a pipe is closed due to
 
-EOF in the fourth case, the interactor is applied to the output
 
-strings truncated at the EOF regardless of the prompt strings. If the
 
-interactor returns more output strings after the pipe has been closed,
 
-a new pipe is opened using exp_popen with the first output string, as
 
-before, and the rest of the output strings are sent down the pipe.
 
-
 
-Empty lists of output strings are handled as follows. If a pipe needs
 
-to be opened for reading but can't be opened because the list of
 
-output strings is empty (and hence indicates no argument to
 
-exp_popen), the pipe is not opened and the effect is the same as if
 
-EOF had been read from it. If a pipe is already opened and the list of
 
-output strings is empty, nothing is written to it but reading proceeds
 
-normally.
 
-
 
-An empty list of prompt strings is not interpreted as such because the
 
-NULL value is taken to imply character oriented interaction per case
 
-3. There is a danger of deadlock if the author of the interactor
 
-misunderstands the use of an empty list of prompt strings to mean that
 
-the interactor will be invoked again immediately without waiting for
 
-input from the pipe.  This effect can be achieved instead by the use
 
-of a list of prompt strings containing only the empty string.
 
-
 
-The expect library puts a carriage return at the end of every line
 
-that is read from the pipe in addition to separating the lines with
 
-line feeds. The carriage returns are stripped in the case of line
 
-oriented interaction (case 4) but retained in the case of character
 
-oriented interaction (case 3). The prompt strings returned by the
 
-interactor should not include trailing carriage returns for the sake
 
-of matching the input read from the pipe, because they are
 
-automatically added by the prompt function, above. Embedded carriage
 
-returns (as opposed to trailing) are not stripped.
 
-
 
-If the author of the interactor function wishes to execute a
 
-non-interactive command (e.g., ls or pwd) and read all output from it
 
-without further interaction, the interactor should use a list of
 
-prompt strings containing only the single string containing only the
 
-single character ascii 4 (for EOF) or any other character that is
 
-certain not to occur in the output of the command. */
 
-
 
-{
 
-  FILE *pipe;
 
-  list interaction,configuration,message;
 
-  int fault;
 
-
 
-#if HAVE_EXPECT
 
-  pipe = NULL;
 
-  fault = 0;
 
-  if (!initialized)
 
-    avm_initialize_exmodes ();
 
-  if (!interactor)
 
-    avm_error ("invalid interaction");
 
-  if (jailed)
 
-    avm_error ("interaction disabled");
 
-  interaction = avm_apply (avm_copied (interactor), NULL);
 
-  while (fault ? 0 : interaction)
 
-    {
 
-      step (&pipe, interactor, &interaction, step_mode, ask_to_overwrite_mode, quiet_mode, &fault);
 
-      if (fault ? 0 : step_mode)
 
-	{
 
-	  fflush (stdout);
 
-	  getchar ();
 
-	}
 
-    }
 
-  avm_dispose (avm_pclose (&pipe, 0, step_mode, &fault));
 
-  if (fault)
 
-    avm_error ("failed interaction (code 0)");
 
-  return;
 
-#endif /* HAVE_EXPECT */
 
-    avm_error ("I need avram linked with libexpect.");
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-transition (pipe, interactor, interaction, transcript_front, transcript_back, tracing, fault)
 
-     FILE **pipe;
 
-     list interactor;
 
-     list *interaction;
 
-     list *transcript_front;
 
-     list *transcript_back;
 
-     int tracing;
 
-     int *fault;
 
-
 
-     /* This function performs one step of interaction between a
 
-	transducer and an external application. Interactor is the
 
-	state transition function, interaction is the current
 
-	configuration, and transcript front and back are a queue of
 
-	text in both directions. */
 
-{
 
-  list message;
 
-  list configuration;
 
-
 
-  *fault = (*fault ? 1 : !((*interaction) ? (*interaction)->tail : NULL));
 
-  message = (*fault ? NULL : piped_out (pipe, (*interaction)->tail->head, tracing, 0, fault));
 
-  if (*fault ? NULL : (*interaction)->tail->tail)
 
-    message = piped_in (pipe, (*interaction)->tail->tail, tracing, 0, fault);
 
-  else if (!*fault)
 
-    message = dripped_in (pipe, tracing, 0, fault);
 
-  if (*fault)
 
-    return (message ? message : avm_copied (invalid_interaction));
 
-  avm_recoverable_enqueue (transcript_front, transcript_back, avm_copied ((*interaction)->tail->head), fault);
 
-  if (!*fault)
 
-    avm_recoverable_enqueue (transcript_front, transcript_back, avm_copied (message), fault);
 
-  if (*fault)
 
-    {
 
-      avm_dispose (*interaction);
 
-      *interaction = NULL;
 
-      avm_dispose (message);
 
-      return avm_copied (memory_overflow);
 
-    }
 
-  configuration = avm_recoverable_join (avm_copied ((*interaction)->head), message);
 
-  avm_dispose (*interaction);
 
-  message = *interaction = NULL;
 
-  if (*fault = !configuration)
 
-    return avm_copied (memory_overflow);
 
-  *interaction = avm_recoverable_apply (avm_copied (interactor), configuration, fault);
 
-  if (*fault)
 
-    {
 
-      message = *interaction;
 
-      *interaction = NULL;
 
-    }
 
-  return message;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_recoverable_interact (interactor, fault)
 
-     list interactor;
 
-     int *fault;
 
-
 
-     /* This function implements the interact combinator. It is
 
-	similar to avm_interact but always closes the pipe and
 
-	performs no file i/o, and will return an error rather than
 
-	exiting.  Otherwise it returns a transcript of the
 
-	interaction as a list of lists of strings represented as
 
-	lists of character encodings. */
 
-{
 
-  FILE *pipe;
 
-  list interaction,transcript_front,transcript_back,configuration,message;
 
-
 
-#if HAVE_EXPECT
 
-  pipe = NULL;
 
-  transcript_front = transcript_back = NULL;
 
-  if (!initialized)
 
-    avm_initialize_exmodes ();
 
-  if (*fault = (*fault ? 1 : !interactor))
 
-    return avm_copied (invalid_interaction);
 
-  if (*fault = jailed)
 
-    return avm_copied (interaction_disabled);
 
-  interaction = avm_recoverable_apply (avm_copied (interactor), NULL, fault);
 
-  if (*fault)
 
-    return interaction;
 
-  while (*fault ? NULL : interaction)
 
-    message = transition (&pipe, interactor, &interaction, &transcript_front, &transcript_back, tracing, fault);
 
-  avm_dispose (interaction);
 
-  if (*fault)
 
-    {
 
-      avm_dispose (avm_pclose (&pipe, tracing, 0, fault));
 
-      avm_dispose (transcript_front);
 
-      return message;
 
-    }
 
-  message = avm_pclose (&pipe, tracing, 0, fault);
 
-  if (*fault)
 
-    {
 
-      avm_dispose (transcript_front);
 
-      return message;
 
-    }
 
-  return transcript_front;
 
-#endif /* HAVE_EXPECT */
 
-  *fault = 1;
 
-  return avm_copied (failed_interaction6);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_line_map (operator)
 
-     list operator;
 
-
 
-     /* applies a function to each line of standard input and sends
 
-        the result to standard output, which should be a character
 
-        string */
 
-{
 
-  int datum;
 
-  list front, back, result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_exmodes ();
 
-  if ((datum = getc (stdin)) != EOF)
 
-    {
 
-      front = back = NULL;
 
-      while (datum != '\n' ? datum != EOF : 0)
 
-	{
 
-	  avm_enqueue (&front, &back, avm_character_representation (datum));
 
-	  datum = getc (stdin);
 
-	}
 
-      avm_put_bytes (result = avm_apply (avm_copied (operator), front));
 
-      avm_dispose (result);
 
-      while (datum == '\n')
 
-	{
 
-	  if (putc ('\n', stdout) != '\n')
 
-	    avm_fatal_io_error ("can't write to", "standard output", errno);
 
-	  front = back = NULL;
 
-	  while ((datum = getc (stdin)) != '\n' ? datum != EOF : 0)
 
-	    avm_enqueue (&front, &back, avm_character_representation (datum));
 
-	  avm_put_bytes (result = avm_apply (avm_copied (operator), front));
 
-	  avm_dispose (result);
 
-	}
 
-    }
 
-  avm_dispose (operator);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_byte_transduce (operator)
 
-     list operator;
 
-
 
-     /* This uses a function as a transducer, taking each byte of standard
 
-        input as input, and treating each output as a character string
 
-        to go to standard output. */
 
-{
 
-  int datum;
 
-  int end_of_file = 0;
 
-  int ioerror = 0;
 
-  list state_and_output, state, operand;
 
-
 
-  if (!initialized)
 
-    avm_initialize_exmodes ();
 
-  state_and_output = avm_apply (avm_copied (operator), NULL);
 
-  while (state_and_output ? !ioerror : 0)
 
-    {
 
-      avm_put_bytes (state_and_output->tail);
 
-      state = avm_copied (state_and_output->head);
 
-      avm_dispose (state_and_output);
 
-      end_of_file = end_of_file ? 1 : ((datum = getc (stdin)) == EOF);
 
-      operand = avm_join (state, end_of_file ? NULL : avm_character_representation (datum));
 
-      state_and_output = avm_apply (avm_copied (operator), operand);
 
-    }
 
-  avm_dispose (operator);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_exmodes ()
 
-     /* This initializes static data structures. */
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_formin ();
 
-  avm_initialize_formout ();
 
-  avm_initialize_rawio ();
 
-  avm_initialize_apply ();
 
-  misformatted_interaction = avm_join (avm_strung ("misformatted interaction"), NULL);
 
-  interaction_disabled = avm_join (avm_strung ("interaction disabled"), NULL);
 
-  invalid_interaction = avm_join (avm_strung ("invalid interaction"), NULL);
 
-  empty_command_line = avm_join (avm_strung ("empty command line"), NULL);
 
-  failed_interaction = avm_join (avm_strung ("failed interaction"), NULL);
 
-  failed_interaction1 = avm_join (avm_strung ("failed interaction (code 1)"), NULL);
 
-  failed_interaction2 = avm_join (avm_strung ("failed interaction (code 2)"), NULL);
 
-  failed_interaction3 = avm_join (avm_strung ("failed interaction (code 3)"), NULL);
 
-  failed_interaction4 = avm_join (avm_strung ("failed interaction (code 4)"), NULL);
 
-  failed_interaction5 = avm_join (avm_strung ("failed interaction (code 5)"), NULL);
 
-  failed_interaction6 = avm_join (avm_strung ("I need avram linked with libexpect."), NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  unable_to_close = avm_join (avm_strung ("unable to close"), NULL);
 
-  unable_to_open = avm_join (avm_strung ("unable to open"), NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_exmodes ()
 
-
 
-{
 
-  if (!initialized)
 
-    return;
 
-  avm_dispose (interaction_disabled);
 
-  avm_dispose (misformatted_interaction);
 
-  avm_dispose (invalid_interaction);
 
-  avm_dispose (empty_command_line);
 
-  avm_dispose (failed_interaction1);
 
-  avm_dispose (failed_interaction2);
 
-  avm_dispose (failed_interaction3);
 
-  avm_dispose (failed_interaction4);
 
-  avm_dispose (failed_interaction5);
 
-  avm_dispose (failed_interaction6);
 
-  avm_dispose (failed_interaction);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (unable_to_open);
 
-  avm_dispose (unable_to_close);
 
-  misformatted_interaction = NULL;
 
-  interaction_disabled = NULL;
 
-  invalid_interaction = NULL;
 
-  empty_command_line = NULL;
 
-  failed_interaction = NULL;
 
-  memory_overflow = NULL;
 
-  unable_to_close = NULL;
 
-  unable_to_open = NULL;
 
-  initialized = 0;
 
-}

+ 0 - 705
src/farms.c
View File 

@@ -1,705 +0,0 @@
 
-
 
-/* concrete representation of pending remote concurrent computations
 
-
 
-   Copyright (C) 2010 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-*/
 
-
 
-#define _GNU_SOURCE
 
-
 
-#include <netdb.h>
 
-#include <stdint.h>
 
-#include <fcntl.h>
 
-#include <errno.h>
 
-#include <poll.h>
 
-#include <netinet/in.h>
 
-#include <sys/time.h>
 
-#include <sys/socket.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/apply.h>
 
-#include <avm/branches.h>
 
-#include <avm/compare.h>
 
-#include <avm/rawio.h>
 
-#include <avm/jobs.h>
 
-#include <avm/farms.h>
 
-#include <avm/servlist.h>
 
-#include <avm/lists.h>
 
-#include <avm/listfuns.h>
 
-
 
-/* the maximum number of farm nodes stored in the following list */
 
-#define CACHE_SIZE 0xff
 
-
 
-/* a list of recycled farm nodes available without using malloc */
 
-static farm available_farm = NULL;
 
-
 
-/* the number of farm nodes in the above list */
 
-static int available_farms;
 
-
 
-/* Non-zero means static variables have been initialized. */
 
-static int initialized = 0;
 
-
 
-/* the number of allocated and not reclaimed structs */
 
-static counter extant_farms = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list memory_overflow = NULL;
 
-static list cache_miss = NULL;
 
-static list reset = NULL;
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_abnormally_terminate (maggie)
 
-     farm *maggie;
 
-
 
-     /* this gets rid of a farm, and tries to stop the remotely
 
-	running jobs but doesn't care if it's unsuccessful */
 
-{
 
-  farm old;
 
-  int sent;
 
-  char *msg = AVM_MSG_RESET;
 
-
 
-  if (*maggie ? (*maggie)->prev : NULL)
 
-    (*maggie)->prev->next = NULL;
 
-  while (*maggie)
 
-    {
 
-      *maggie = (old = *maggie)->next;
 
-      avm_dispose (old->operand);
 
-      if (old->runner ? (old->runner->connected) : 0)
 
-	sent = send(old->runner->status_fd, msg, 1 + strlen (msg), MSG_NOSIGNAL);
 
-      avm_release_server (&(old->runner));
 
-      if (available_farms < CACHE_SIZE)
 
-	{
 
-	  old->next = available_farm;
 
-	  available_farm = old;
 
-	  available_farms++;
 
-	}
 
-      else
 
-	{
 
-	  extant_farms--;
 
-	  free (old);
 
-	}
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_plant(maggie, top, fault)
 
-     farm *maggie;
 
-     job top;
 
-     int *fault;
 
-
 
-     /* This plants one tree in the farm, using the list of its
 
-	prerequisites' roots as the operand, and deletes the
 
-	prerequisites from the tree. In case of a fault, the farm is
 
-	cleared and the prerequisites are still deleted, but the rest
 
-	of the tree is left. */
 
-{
 
-  list front, back;
 
-  farm new_farm;
 
-  job descendent;
 
-
 
-  if (!top)
 
-    return;
 
-  front = back = NULL;
 
-  descendent = top->prerequisites;
 
-  while (*fault ? NULL : descendent)
 
-    {
 
-      avm_recoverable_enqueue (&front, &back, avm_copied (descendent->root), fault);
 
-      descendent = descendent->corequisites;
 
-    }
 
-  avm_free_job (&(top->prerequisites));
 
-  if (*fault)
 
-    return;
 
-  if (available_farm)
 
-    {
 
-      new_farm = available_farm;
 
-      available_farm = available_farm->next;
 
-      available_farms--;
 
-    }
 
-  else
 
-    {
 
-      if (*fault = !(new_farm = (farm) malloc (sizeof (*new_farm))))
 
-	{
 
-	  avm_abnormally_terminate (maggie);
 
-	  avm_dispose (front);
 
-	  return;
 
-	}
 
-      extant_farms++;
 
-    }
 
-  memset (new_farm, 0, sizeof (*new_farm));
 
-  new_farm->site = top;
 
-  new_farm->operand = front;
 
-  if (!*maggie)
 
-    new_farm->prev = new_farm->next = new_farm;
 
-  else
 
-    {
 
-      new_farm->next = *maggie;
 
-      new_farm->prev = (*maggie)->prev;
 
-      (*maggie)->prev = new_farm;
 
-      if (new_farm->prev)
 
-	new_farm->prev->next = new_farm;
 
-    }
 
-  *maggie = new_farm;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-propagate(maggie, new_root, fault)
 
-     farm *maggie;
 
-     list new_root;
 
-     int *fault;
 
-
 
-     /* returns a result to the job addressed by the first item of the
 
-        farm, clears it and checks whether the dependent job exists and
 
-        is enabled, in which case it is planted */
 
-{
 
-  farm old;
 
-  job top;
 
-
 
-  if (*fault)
 
-    return;
 
-  if (!(maggie ? ((old = *maggie) ? old->site : NULL) : NULL))
 
-    avm_internal_error (110);
 
-  if (*maggie == (*maggie)->next)
 
-    *maggie = NULL;
 
-  else
 
-    {
 
-      *maggie = (*maggie)->next;
 
-      if (*maggie)                      /* should always be true for a circularly linked list */
 
-	(*maggie)->prev = old->prev;
 
-      if (old->prev)
 
-	old->prev->next = *maggie;
 
-    }
 
-  avm_dispose (old->operand);
 
-  avm_dispose (old->site->root);
 
-  old->site->root = new_root;
 
-  old->site->running = 0;
 
-  top = (!old->site->dependent ? NULL : --(old->site->dependent->dependence) ? old->site->dependent : NULL);
 
-  if (available_farms < CACHE_SIZE)
 
-    {
 
-      old->next = available_farm;
 
-      available_farm = old;
 
-      available_farms++;
 
-    }
 
-  else
 
-    {
 
-      extant_farms--;
 
-      free (old);
 
-    }
 
-  avm_plant(maggie, top, fault);
 
- }
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-farmed_out (maggie, server, fault)
 
-     farm *maggie;
 
-     server_list server;
 
-     int *fault;
 
-
 
-     /* assigns a job to a remote server */
 
-{
 
-  list equality, package;
 
-  job site;
 
-  int timeout, closed;
 
-
 
-  if (*fault = (*fault ? 1 : !(*maggie) ? 1 : !(site = (*maggie)->site) ? 1 : !server))
 
-    {
 
-      avm_release_server (&server);
 
-      return NULL;
 
-    }
 
-  equality = avm_binary_comparison (site->root, server->cache, fault);
 
-  if (*fault)
 
-    return equality;
 
-  (*maggie)->cache_hit = ! ! equality;
 
-  package = avm_recoverable_join (equality ? NULL : avm_copied (site->root), avm_copied ((*maggie)->operand));
 
-  avm_dispose (equality);
 
-  if (*fault = !package)
 
-    return NULL;
 
-  closed = timeout = 0;
 
-  avm_recoverable_send_list (server->data_fd, package, &(server->expected_crc), &timeout, &closed, fault);
 
-  avm_dispose (package);
 
-  avm_dispose (server->cache);
 
-  server->cache = NULL;
 
-  if (*fault ? 1 : timeout)
 
-    {
 
-      close (server->data_fd);
 
-      close (server->status_fd);
 
-      if (timeout ? closed : 0)
 
-	server->opened = server->connected = 0;
 
-      avm_release_server (&server);
 
-      return NULL;
 
-    }
 
-  server->cache = avm_copied (site->root);
 
-  site->running = 1;
 
-  avm_watch_server (server);
 
-  (*maggie)->runner = server;
 
-  (*maggie) = (*maggie)->next;
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static int
 
-matching_crc (runner, fault)
 
-     server_list *runner;
 
-     int *fault;
 
-
 
-     /* If a crc is read from the runner matching the expected one, a
 
-        true result is returned and the runner is set to null, but the
 
-        server associated with it is left open and connected in
 
-        preparation for reading the data, after which it should be
 
-        released by the caller.
 
-
 
-        If no crc is readable because the port isn't really ready
 
-	(even though it would have been polled before this function
 
-	was called), then the function returns false but doesn't
 
-	release the runner, because this could happen if the data were
 
-	subsequently removed by the kernel despite a positive polling
 
-	result due to a transmission error.
 
-
 
-        If the crc is unreadable because the connection was closed, by
 
-	the server, the runner is flushed, closed, and released, and a
 
-	false result is returned.
 
-
 
-        If the crc is readable but incorrect, the runner is released
 
-        and flushed but not closed, and a false result is returned. */
 
-{
 
-  char echoed_crc[128];
 
-  int received;
 
-
 
-  if (*fault ? 1 : !*runner)
 
-    avm_internal_error (122);
 
-  memset (echoed_crc, 0, sizeof echoed_crc);
 
-  received = recv ((*runner)->data_fd, echoed_crc, 1 + strlen ((*runner)->expected_crc), MSG_NOSIGNAL | MSG_DONTWAIT);
 
-  if (*fault = ((received == -1) ? (errno == ENOMEM) : 0))
 
-    {
 
-      avm_release_server (runner);
 
-      return 0;
 
-    }
 
-  if ((received == -1) ? ((errno == EAGAIN) ? 1 : (errno == EWOULDBLOCK)) : 0)
 
-    return 0;
 
-  if ((received != -1) ? 0 : (errno == EINVAL) ? 1 : (errno == EFAULT) ? 1 : (errno == EBADF) ? 1 : (errno == ENOTSOCK))
 
-    avm_internal_error (117);
 
-  if (strcmp (echoed_crc, (*runner)->expected_crc) == 0)
 
-    {
 
-      *runner = NULL;
 
-      return 1;
 
-    }
 
-  if ((received == -1) ? ((errno == ECONNREFUSED) ? 1 : (errno == ENOTCONN)) : 0)
 
-    {
 
-      close ((*runner)->data_fd);
 
-      close ((*runner)->status_fd);
 
-      (*runner)->opened = (*runner)->connected = 0;
 
-    }
 
-  avm_release_server (runner);
 
-  return 0;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-farmed_in (maggie, fault)
 
-     farm *maggie;
 
-     int *fault;
 
-
 
-     /* This gets a result back from a remote server, which should be
 
-        be the null terminated crc followed by a non-empty list
 
-        representing a pair (data,exception) of type %xbX in Ursala
 
-        notation. The crc is read first and then the list is read by
 
-        avm_recoverable_received_list. If the right side is non-empty,
 
-        the left is a diagnostic message. If the package sent to the
 
-        server had an empty left side (and therefore a true cache_hit
 
-        field in the farm, so as to call the server's cached function)
 
-        and the diagnostic message of "cache miss" is returned, a
 
-        retry is enabled rather than raising an exception locally.
 
-        The return value of this function is used only for diagnostic
 
-        messages, with valid results being propagated up the job
 
-        tree. */
 
-{
 
-  int timeout, closed, remote_fault;
 
-  list result, old_result, equality;
 
-  server_list old_runner;
 
-  char *ignored_crc;
 
-
 
-  if (*fault ? 1 : (!*maggie) ? 1 : !(old_runner = (*maggie)->runner) ? 1 : !((*maggie)->site))
 
-    avm_internal_error (121);
 
-  if (! matching_crc (&((*maggie)->runner), fault))
 
-    {
 
-      (*maggie)->site->running = ! ! (*maggie)->runner;
 
-      return NULL;
 
-    }
 
-  (*maggie)->site->running = closed = timeout = 0;
 
-  result = avm_recoverable_received_list (old_runner->data_fd, &ignored_crc, &timeout, &closed, fault);
 
-  free (ignored_crc);
 
-  if (timeout ? closed : 0)
 
-    {
 
-      close (old_runner->data_fd);
 
-      close (old_runner->status_fd);
 
-      old_runner->opened = old_runner->connected = 0;
 
-    }
 
-  avm_release_server (&old_runner);
 
-  if (*fault ? 1 : !result ? 1 : timeout ? 1 : closed)
 
-    return result;
 
-  result = avm_copied ((old_result = result)->head);
 
-  remote_fault = !!(old_result->tail);
 
-  avm_dispose (old_result);
 
-  if (!remote_fault)
 
-    {
 
-      propagate (maggie, result, fault);
 
-      return NULL;
 
-    }
 
-  equality = ((*maggie)->cache_hit ? NULL : avm_binary_comparison (result, cache_miss, fault));
 
-  if (*fault)
 
-    {
 
-      avm_dispose (result);
 
-      return equality;
 
-    }
 
-  if (*fault = !equality)
 
-    return result;
 
-  avm_dispose (equality);
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static farm
 
-dependent_list (maggie)
 
-     farm maggie;
 
-
 
-     /* returns a singly linked list of the next generation of
 
-	dependent jobs of the given farm */
 
-{
 
-  farm front_dependent, back_dependent, bottom, new_farm;
 
-  job dependent;
 
-
 
-  if (!(maggie ? maggie->prev : NULL))
 
-    return NULL;
 
-  front_dependent = back_dependent = NULL;
 
-  (bottom = maggie)->prev->next = NULL;
 
-  while (bottom)
 
-    if (!(bottom->site) ? 1 : !(bottom->site->dependent) ? 1 : bottom->site->dependent->deficit)
 
-      bottom = bottom->next;                                                              /* skip those already visited */
 
-    else
 
-      {
 
-	if (available_farms)
 
-	  {
 
-	    new_farm = available_farm;
 
-	    available_farm = available_farm->next;
 
-	    available_farms--;
 
-	  }
 
-	else if (new_farm = (farm) malloc (sizeof *new_farm))
 
-	  extant_farms++;
 
-	else
 
-	  new_farm = bottom = NULL;
 
-	if (new_farm)
 
-	  {
 
-	    memset (new_farm, 0, sizeof *new_farm);
 
-	    back_dependent = (back_dependent ? (back_dependent->next = new_farm) : (front_dependent = new_farm));
 
-	    back_dependent->site = bottom->site->dependent;
 
-	    back_dependent->site->deficit = 1;                                           /* mark this dependent visited */
 
-	    bottom = bottom->next;
 
-	  }
 
-      }
 
-  bottom = front_dependent;
 
-  while (bottom)                                                                                     /* clear the marks */
 
-    {
 
-      if (bottom->site)
 
-	bottom->site->deficit = 0;
 
-      bottom = bottom->next;
 
-    }
 
-  maggie->prev->next = maggie;
 
-  return front_dependent;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static farm
 
-rebalanced (parents)
 
-     farm parents;
 
-
 
-     /* This gets called as the last alternative to going to sleep
 
-        when all the jobs in the farm are running, in case there might
 
-        be a chance to make better use of some idle servers by
 
-        reorganizing the tree of jobs. The parameter should be a list
 
-        of the dependent jobs of the running jobs represented as a
 
-        singly linked acyclic farm pointing to them. The result
 
-        returned is a singly linked farm pointing to the subset of
 
-        given farm whose sites are now ready to be planted as a result
 
-        of having their running prerequisites exchanged for finished
 
-        prerequistes of other jobs in the list. This transformation is
 
-        valid only when the function being computed by the jobs is
 
-        commutative, as indicated by the balanceable parameter to the
 
-        harvest function. */
 
-{
 
-  job finished_front, finished_back, running_front, running_back, back;
 
-  farm result_front, result_back, parent;
 
-
 
-  if (!((parent = parents) ? parents->next : NULL))
 
-    {
 
-      avm_abnormally_terminate (&parents);
 
-      return NULL;
 
-    }
 
-  finished_front = finished_back = running_front = running_back = NULL;
 
-  while (parent ? parent->site : NULL)                                    /* flatten and bipartition the prerequisites */
 
-    {
 
-      while (parent->site->prerequisites)
 
-	{
 
-	  parent->site->prerequisites->dependent = NULL;
 
-	  if (parent->site->prerequisites->running ? 1 : ! ! parent->site->prerequisites->prerequisites)
 
-	    {
 
-	      avm_queue_job (&running_front, &running_back, &(parent->site->prerequisites), NULL);
 
-	      (parent->site->dependence)--;
 
-	    }
 
-	  else
 
-	    avm_queue_job (&finished_front, &finished_back, &(parent->site->prerequisites), NULL);
 
-	  parent->site->deficit++;
 
-	}
 
-      if (parent->site->dependence)           /* unfinished prerequisites should have agreed with the dependence field */
 
-	avm_internal_error (124);
 
-      parent = parent->next;
 
-    }
 
-  parent = parents;
 
-  while (parent ? parent->site : NULL)                     /* re-attach prerequisites using up the finished list first */
 
-    {
 
-      back = NULL;
 
-      while (parent->site->deficit)
 
-	{
 
-	  if (finished_front)         /* stick it under the parent but don't bump the dependence because it's finished */
 
-	    {
 
-	      finished_front->dependent = parent->site;
 
-	      avm_queue_job (&(parent->site->prerequisites), &back, &finished_front, NULL);
 
-	    }
 
-	  else if (!(running_front))              /* there should be at least as many prerequisites as we started with */
 
-	    avm_internal_error (125);
 
-	  else
 
-	    avm_queue_job (&(parent->site->prerequisites), &back, &running_front, parent->site);
 
-	  parent->site->deficit--;
 
-	}
 
-      parent = parent->next;
 
-    }
 
-  if (running_front ? running_back : NULL)                     /* there should have been no more than we started with */
 
-    avm_internal_error (126);
 
-  result_front = result_back = NULL;
 
-  while (!parents ? 0 : !(parents->site) ? 0 : !(parents->site->dependence))   /* those with no running prerequisites */
 
-    {
 
-      result_back = (result_back ? (result_back->next = parents) : (result_front = parents));
 
-      parents = parents->next;
 
-      result_back->next = NULL;
 
-    }
 
-  avm_abnormally_terminate (&parents);             /* not really terminated since they aren't running yet, just freed */
 
-  return result_front;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_harvest (maggie, balanceable, fault)
 
-     farm maggie;
 
-     flag balanceable;
 
-     int *fault;
 
-
 
-     /* This sends out each item from the farm to a remote machine,
 
-	unless it's the last one or a constant funciton, which is
 
-	evaluated locally. Any time a job in the farm is finished, new
 
-	jobs inferred from its dependents might be started. If this
 
-	function is called with a list of farm nodes initialized to
 
-	point to the leaf nodes in a job tree, then by the time it's
 
-	finished, the whole tree will be evaluated up to the root. */
 
-{
 
-  list value;
 
-  job site;
 
-  int progress;                  /* set in the event of a propagation or status check */
 
-  int longest_running_job;       /* the first remote job started since the most recent progress event */
 
-  server_list server;
 
-  farm collection, old;
 
-
 
-  site = NULL;
 
-  longest_running_job = 0;
 
-  while (*fault ? 0 : !maggie ? 0 : (*fault = !(site = maggie->site)) ? 0 : ! _avm_reset)
 
-    {
 
-      if (maggie->runner)
 
-	{
 
-	  if (progress = avm_readable (&(maggie->runner), fault))
 
-	    value = farmed_in (&maggie, fault);
 
-	  else
 
-	    progress = avm_unresponsive (&(maggie->runner), WAIT, &value, fault);
 
-	}
 
-      else if (progress = !(site->root))
 
-	propagate (&maggie, avm_copied (maggie->operand), fault);
 
-      else if (progress = !(maggie->operand))
 
-	propagate (&maggie, avm_copied (site->root), fault);
 
-      else if (progress = (site->root->head ? 0 : !(site->root->tail)))
 
-	propagate (&maggie, value = (list) avm_flattened (maggie->operand, fault), fault);
 
-      else if (progress = (site->root->tail ? 0 : !(site->root->head->head)))
 
-	propagate (&maggie, avm_copied (site->root->head->tail), fault);
 
-      else if (site->dependent ? (server = avm_acquired_server (RETRY, fault)) : NULL)
 
-	{
 
-	  longest_running_job = (longest_running_job ? longest_running_job : (int) maggie);
 
-	  value = farmed_out (&maggie, server, fault);
 
-	}
 
-      else if (progress = !*fault)
 
-	{
 
-	  value = avm_recoverable_apply (avm_copied (site->root), avm_copied (maggie->operand), fault);
 
-	  if (!*fault)
 
-	    propagate (&maggie, value, fault);
 
-	}
 
-      if (*fault ? 0 : ((longest_running_job = (progress ? 0 : longest_running_job)) == (int) maggie))
 
-	{
 
-	  if (!(old = collection = (balanceable ? rebalanced (dependent_list (maggie)) : NULL)))
 
-	    avm_wait_for_event (WAIT);
 
-	  else
 
-	    while (*fault ? 0 : collection)
 
-	      {
 
-		avm_plant (&maggie, collection->site, fault);
 
-		collection = collection->next;
 
-	      }
 
-	  avm_abnormally_terminate (&old);
 
-	}
 
-      value = (*fault ? value : NULL);
 
-    }
 
-  if ((*fault = (*fault ? 1 : _avm_reset)) ? site : NULL)
 
-    {
 
-      while (site->dependent)
 
-	site = site->dependent;
 
-      avm_dispose (site->root);
 
-      site->root = (value ? value : _avm_reset ? avm_copied (reset) : avm_copied (memory_overflow));
 
-    }
 
-  avm_abnormally_terminate (&maggie);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_farms ()
 
-
 
-     /* This initializes static data structures. */
 
-{
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_branches ();
 
-  avm_initialize_apply ();
 
-  avm_initialize_compare ();
 
-  reset = avm_join (avm_strung ("reset"), NULL);
 
-  cache_miss = avm_join (avm_strung ("cache miss"), NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_farms ()
 
-
 
-{
 
-  server_list old,servers;
 
-
 
-  if (!initialized)
 
-    return;
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (cache_miss);
 
-  avm_dispose (reset);
 
-  memory_overflow = NULL;
 
-  cache_miss = NULL;
 
-  reset = NULL;
 
-  initialized = 0;
 
-  if (extant_farms)
 
-    avm_reclamation_failure ("farms", extant_farms);
 
-}

+ 0 - 390
src/fftw.c
View File 

@@ -1,390 +0,0 @@
 
-
 
-/* this file interfaces to some fourier transform functions from fftw
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/compare.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/matcon.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/fftw.h>
 
-#include <math.h>
 
-
 
-#if HAVE_FFTW
 
-#include <fftw3.h>
 
-#endif
 
-
 
-#define RE 0
 
-#define IM 1
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list fftw_error = NULL;
 
-static list bad_fftw_spec = NULL;
 
-static list memory_overflow = NULL;
 
-static list unrecognized_function_name = NULL;
 
-
 
-/* function names as lists of lists of character representations */
 
-static list wild = NULL;
 
-static list funs = NULL;
 
-
 
-#if HAVE_FFTW
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-dft_1d (forward, operand, fault)
 
-     int forward;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* one dimensional fft from complex to complex data, takes a list
 
-	of complex numbers with the direction specified by the forward
 
-	parameter i.e., forward=0 means the inverse transform */
 
-{
 
-  fftw_complex *in;
 
-  fftw_plan p;
 
-  int n,i;
 
-  list result;
 
-  double scale;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  scale = 1.0 / sqrt(n = (int) avm_length(operand));
 
-  in = (fftw_complex *) avm_vector_of_list(operand,sizeof(fftw_complex),&result,fault);
 
-  p = (*fault ? NULL : fftw_plan_dft_1d(n,in,in,forward ? FFTW_FORWARD : FFTW_BACKWARD,FFTW_ESTIMATE));
 
-  if (!(*fault = (*fault ? 1 : !(in ? !!p : 0))))
 
-    fftw_execute(p);
 
-  if (p)
 
-    fftw_destroy_plan(p);
 
-  if (!*fault)
 
-    for (i = 0; i < n; i++)
 
-      {
 
-	in[i][RE] = scale * in[i][RE];
 
-	in[i][IM] = scale * in[i][IM];
 
-      }
 
-  result = (*fault ? result : avm_list_of_vector((void *) in,n,sizeof(fftw_complex),fault));
 
-  if (in)
 
-    free (in);
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-dft_2d (forward, operand, fault)
 
-     int forward;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* two dimensional fft from complex to complex data, takes a list
 
-	of lists of complex numbers with the direction specified by
 
-	the forward parameter; i.e., forward=0 means the inverse
 
-	transform */
 
-{
 
-  fftw_complex *in;
 
-  fftw_plan p;
 
-  int nx,ny,i;
 
-  list result;
 
-  double scale;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  if (*fault = !(operand ? operand->head : NULL))
 
-    return avm_copied(bad_fftw_spec);
 
-  ny = (int) avm_length(operand);
 
-  nx = (int) avm_length(operand->head);
 
-  scale = 1.0 / sqrt(nx * ny);
 
-  in = (fftw_complex *) avm_matrix_of_list(0,0,0,0,operand,sizeof(fftw_complex),&result,fault);
 
-  p = (*fault ? NULL : fftw_plan_dft_2d(nx,ny,in,in,forward ? FFTW_FORWARD : FFTW_BACKWARD,FFTW_ESTIMATE));
 
-  if (!(*fault = (*fault ? 1 : !(in ? !!p : 0))))
 
-    fftw_execute(p);
 
-  if (p)
 
-    fftw_destroy_plan(p);
 
-  if (!*fault)
 
-    for (i = 0; i < (nx * ny); i++)
 
-      {
 
-	in[i][RE] = scale * in[i][RE];
 
-	in[i][IM] = scale * in[i][IM];
 
-      }
 
-  result = (*fault ? result : avm_list_of_matrix((void *) in,nx,ny,sizeof(fftw_complex),fault));
 
-  if (in)
 
-    free (in);
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-dht_1d (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* one dimensional Hartley transform, which is its own inverse;
 
-	takes a list of reals to a list of reals */
 
-{
 
-  double *in;
 
-  fftw_plan p;
 
-  int n,i;
 
-  list result;
 
-  double scale;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  scale = 1.0 / sqrt(n = (int) avm_length(operand));
 
-  in = (double *) avm_vector_of_list(operand,sizeof(double),&result,fault);
 
-  p = (*fault ? NULL : fftw_plan_r2r_1d(n,in,in,FFTW_DHT,FFTW_ESTIMATE));
 
-  if (!(*fault = (*fault ? 1 : !(in ? !!p : 0))))
 
-    fftw_execute(p);
 
-  if (p)
 
-    fftw_destroy_plan(p);
 
-  if (!*fault)
 
-    for (i = 0; i < n; i++)
 
-      in[i] = scale * in[i];
 
-  result = (*fault ? result : avm_list_of_vector((void *) in,n,sizeof(double),fault));
 
-  if (in)
 
-    free (in);
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-dht_2d (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* 2 dimensional Hartley transform, which is its own inverse;
 
-	takes a list of lists of reals to a list of lists of reals*/
 
-{
 
-  double *in;
 
-  fftw_plan p;
 
-  int nx,ny,i;
 
-  list result;
 
-  double scale;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  if (*fault = !(operand ? operand->head : NULL))
 
-    return avm_copied(bad_fftw_spec);
 
-  ny = (int) avm_length(operand);
 
-  nx = (int) avm_length(operand->head);
 
-  scale = 1.0 / sqrt(nx * ny);
 
-  in = (double *) avm_matrix_of_list(0,0,0,0,operand,sizeof(double),&result,fault);
 
-  p = (*fault ? NULL : fftw_plan_r2r_2d(nx,ny,in,in,FFTW_DHT,FFTW_DHT,FFTW_ESTIMATE));
 
-  if (!(*fault = (*fault ? 1 : !(in ? !!p : 0))))
 
-    fftw_execute(p);
 
-  if (p)
 
-    fftw_destroy_plan(p);
 
-  if (!*fault)
 
-    for (i = 0; i < (nx * ny); i++)
 
-      in[i] = scale * in[i];
 
-  result = (*fault ? result : avm_list_of_matrix((void *) in,nx,ny,sizeof(double),fault));
 
-  if (in)
 
-    free (in);
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-#endif
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_have_fftw_call (function_name, fault)
 
-     list function_name;
 
-     int *fault;
 
-
 
-/* this reports the availability of a function */
 
-
 
-{
 
-#if HAVE_FFTW
 
-  list membership;
 
-  list comparison;
 
-  list result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_fftw ();
 
-  if (*fault)
 
-    return NULL;
 
-  comparison = avm_binary_comparison (function_name, wild, fault);
 
-  if (*fault)
 
-    return comparison;
 
-  if (comparison)
 
-    {
 
-      avm_dispose(comparison);
 
-      return avm_copied(funs);
 
-    }
 
-  if (!(membership = avm_binary_membership (function_name, funs, fault)) ? 1 : *fault)
 
-    return membership;
 
-  avm_dispose(membership);
 
-  return ((*fault = !(result = avm_recoverable_join(avm_copied(function_name),NULL))) ? avm_copied(memory_overflow) : result);
 
-#endif
 
-  return (NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_fftw_call (function_name, argument, fault)
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-{
 
-#if HAVE_FFTW
 
-  list message;
 
-  int function_number;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (! initialized)
 
-    avm_initialize_fftw ();
 
-  if (!(function_number = 0xff & (function_name ? function_name->characterization : 0)))
 
-    {
 
-      message = avm_position (function_name, funs, fault);
 
-      if (*fault)
 
-	return (message);
 
-      if (*fault = !message)
 
-	return(avm_copied (unrecognized_function_name));
 
-      function_number = message->characterization;
 
-      function_name->characterization = function_number;
 
-      avm_dispose (message);
 
-    }
 
-  switch (function_number)
 
-    {
 
-    case 1: return dft_1d (1, argument, fault);
 
-    case 2: return dft_1d (0, argument, fault);
 
-    case 3: return dft_2d (1, argument, fault);
 
-    case 4: return dft_2d (0, argument, fault);
 
-    case 5: return dht_1d (argument, fault);
 
-    case 6: return dht_2d (argument, fault);
 
-    }
 
-#endif /* HAVE_FFTW */
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_fftw ()
 
-
 
-     /* This initializes some static data structures. */
 
-{
 
-  char *funames[] = {
 
-    "u_fw_dft",
 
-    "u_bw_dft",
 
-    "b_fw_dft",
 
-    "b_bw_dft",
 
-    "u_dht",
 
-    "b_dht",
 
-    NULL};            /* add more function names here up to a total of 255 */
 
-  list back;
 
-  int string_number;
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_matcon ();
 
-  avm_initialize_chrcodes ();
 
-  wild = avm_strung("*");
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  fftw_error = avm_join (avm_strung ("fftw error"), NULL);
 
-  bad_fftw_spec = avm_join (avm_strung ("bad fftw specification"), NULL);
 
-  unrecognized_function_name = avm_join (avm_strung ("unrecognized fftw function name"), NULL);
 
-  string_number = 0;
 
-  funs = back = NULL;
 
-  while (funames[string_number])
 
-    avm_enqueue (&funs, &back, avm_standard_strung (funames[string_number++]));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_fftw ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (funs);
 
-  avm_dispose (wild);
 
-  avm_dispose (fftw_error);
 
-  avm_dispose (bad_fftw_spec);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (unrecognized_function_name);
 
-  funs = NULL;
 
-  wild = NULL;
 
-  fftw_error = NULL;
 
-  memory_overflow = NULL;
 
-  unrecognized_function_name = NULL;
 
-}

+ 0 - 216
src/fnames.c
View File 

@@ -1,216 +0,0 @@
 
-
 
-/* conversion between path names as character strings and as lists
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.  
-*/
 
-
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/branches.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/fnames.h>
 
-#include <time.h>
 
-
 
-/* File names aren't expected to be longer than 256 characters, so an
 
-   error is reported if they are. If you need them longer, by all
 
-   means change this. There's no memory cost in doing so. */
 
-#define plausible_filename_length 0xff
 
-
 
-
 
-/* a list representation of the string "unknown date", which is
 
-   returned when avm_date_representation is at a loss */
 
-static list unknown_date;
 
-
 
-/* non-zero implies static variables are initialized */
 
-static int initialized;
 
-
 
-
 
-
 
-list
 
-avm_path_representation (path)
 
-     char *path;
 
-
 
-     /* This maps a path stored in a character string to the
 
-        equivalent representation in a list. Each item in the list is
 
-        a single component of the path, represented as a list of
 
-        character representations. The file name is first and the
 
-        parent directory names come next. The root directory is
 
-        represented by an empty component. Standard input and standard
 
-        output are represented by empty lists. */
 
-
 
-{
 
-  list front, back, result;
 
-
 
-  if(!path)
 
-    return NULL;
 
-  result = front = back = NULL;
 
-  while (*path)
 
-    {
 
-      if (*path != avm_path_separator_character)
 
-	avm_enqueue (&front, &back, avm_character_representation (*path));
 
-      else if(*(path+1))
 
-	{
 
-	  result = avm_join (front, result);
 
-	  front = back = NULL;
 
-	}
 
-      path++;
 
-    }
 
-  return avm_join (front, result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_date_representation (path)
 
-     char *path;
 
-
 
-     /* This returns the time stamp as a list. */
 
-
 
-{
 
-  list front, back;
 
-  char *temporary;
 
-  struct stat buffer;
 
-  char time_buffer[26];
 
-
 
-  if (path ? stat (path, &buffer) : 1)
 
-    return (avm_copied (unknown_date));
 
-  else
 
-    {
 
-      front = back = NULL;
 
-#if HAVE_CTIME_R
 
-      ctime_r (&buffer.st_mtime, time_buffer);
 
-      temporary = time_buffer;
 
-#else /* not HAVE_CTIME_R */
 
-      temporary = ctime (&buffer.st_mtime);
 
-#endif /* HAVE_CTIME_R */
 
-      while (temporary && (*temporary) && (*temporary != '\n'))
 
-	{
 
-	  avm_enqueue (&front, &back, avm_character_representation (*temporary));
 
-	  temporary++;
 
-	}
 
-      return front;
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-char *
 
-avm_path_name (path)
 
-     list path;
 
-
 
-     /* This is the inverse of avm_path_representation. */
 
-
 
-{
 
-  list name;
 
-  int erroneous;
 
-  int datum;
 
-  char *result;
 
-  char *temporary;
 
-  counter cumulative_length, total_length, name_length, new_length;
 
-
 
-  total_length = (name_length = avm_area (path)) + avm_length (path);
 
-  if (total_length < name_length)
 
-    avm_error ("counter overflow (code 3)");
 
-  if (total_length == 0)
 
-    return (NULL);
 
-  if (total_length == 1 ? 1 : total_length > plausible_filename_length)
 
-    avm_error ("invalid file name (code 1)");
 
-  if (!(temporary = (char *) malloc (total_length)) ? 1 : !(result = (char *) malloc (total_length)))
 
-    avm_error ("memory overflow (code 10)");
 
-  *result = 0;
 
-  cumulative_length = 1;
 
-  while (path)
 
-    {
 
-      name_length = 0;
 
-      name = path->head;
 
-      while (name)
 
-	{
 
-	  if ((datum = avm_character_code (name->head)) < 0)
 
-	    avm_error ("invalid file name (code 2)");
 
-	  else if ((datum<32) | (datum>126) | (datum=='/') | (datum=='\\'))
 
-	    avm_error ("bad character in file name");
 
-	  else if (name_length >= total_length - 1)
 
-	    avm_internal_error (21);
 
-	  else if (!(temporary[name_length++] = datum))
 
-	    avm_error ("null character in file name");
 
-	  name = name->tail;
 
-	}
 
-      temporary[name_length] = 0;
 
-      if (*result)
 
-	{
 
-	  if ((++name_length) == total_length)
 
-	    avm_internal_error (22);
 
-	  strcat (temporary, "/");
 
-	}
 
-      erroneous = (new_length = cumulative_length + name_length) < cumulative_length;
 
-      erroneous = erroneous ? 1 : ((cumulative_length = new_length) > total_length);
 
-      if (erroneous)
 
-	avm_internal_error (23);
 
-      strcat (temporary, result);
 
-      strcpy (result, temporary);
 
-      path = path->tail;
 
-    }
 
-  free (temporary);
 
-  if ((*result) == 0)
 
-    avm_error ("invalid file name (code 3)");
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_fnames ()
 
-
 
-     /* This initializes some static data structures. */
 
-
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_branches ();
 
-  avm_initialize_chrcodes ();
 
-  unknown_date = avm_strung ("unknown date");
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_fnames ()
 
-
 
-     /* This frees some static data structures to help detect memory
 
-	leaks. */
 
-{
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (unknown_date);
 
-  unknown_date = NULL;
 
-}

+ 0 - 260
src/formin.c
View File 

@@ -1,260 +0,0 @@
 
-
 
-/* functions reading text and data files into lists
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.  
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/branches.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/rawio.h>
 
-#include <avm/formin.h>
 
-
 
-/* represents (nil,nil) */
 
-static list shared_cell = NULL;
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* the character code for a line break */
 
-static int line_break = 10;
 
-
 
-
 
-
 
-static list
 
-initial_comments (line)
 
-     list line;
 
-
 
-     /* This takes a list of character strings represented as lists
 
-        and returns the comments, if any, which will be the maximum
 
-        prefix of the list of strings in which each item either begins
 
-        with a hash or follows one that ends with a backslash. 
-
 
-        Some sneaky hacks are used here. Character comparisons are
 
-        done by comparing pointers to members of the array
 
-        avm_representations, which is declared in chrcodes.h. Direct
 
-        use of this array is an undocument feature of the library, but
 
-        it is used here to avoid the need for disposing of
 
-        it. Furthermore, pointer equality is not generally a valid
 
-        test for comparison, but in this case the list is assumed to
 
-        be recently created using calls to
 
-        avm_character_representation, so it should be all right. */
 
-
 
-{
 
-  list column, front_line, back_line, front_column, back_column;
 
-  int continued;
 
-
 
-  continued = 0;
 
-  front_line = back_line = NULL;
 
-  while (line)
 
-    {
 
-      column = line->head;
 
-      line = line->tail;
 
-      front_column = back_column = NULL;
 
-      if (continued)
 
-	{
 
-	  continued = 0;
 
-	  while (column)
 
-	    {
 
-	      continued = (column->head == _avm_representations['\\']);
 
-	      avm_enqueue (&front_column, &back_column,avm_copied (column->head));
 
-	      column = column->tail;
 
-	    }
 
-	  avm_enqueue (&front_line, &back_line, front_column);
 
-	}
 
-      else if (column ? (column->head == _avm_representations['#']) : 0)
 
-	{
 
-	  column = column->tail;
 
-	  while (column)
 
-	    {
 
-	      continued = (column->head == _avm_representations['\\']);
 
-	      avm_enqueue (&front_column, &back_column, avm_copied (column->head));
 
-	      column = column->tail;
 
-	    }
 
-	  avm_enqueue (&front_line, &back_line, front_column);
 
-	}
 
-      else
 
-	line = NULL;
 
-    }
 
-  return (front_line);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_preamble_and_contents (source, filename)
 
-     FILE *source;
 
-     char *filename;
 
-
 
-     /* This function is used for file input when it has to guess
 
-	whether the file is in raw or text format. */
 
-{
 
-  int spool, datum, last_character_on_previous_line, textual, spoke, previously_in_comment, in_comment;
 
-  list raw_data, front_line, back_line, front_column, back_column, preamble, contents;
 
-  branch_queue front_branch, back_branch;
 
-
 
-  if (!initialized)
 
-    avm_initialize_formin ();
 
-  front_branch = back_branch = NULL;
 
-  front_line = back_line = raw_data = NULL;
 
-  avm_anticipate (&front_branch, &back_branch, &raw_data);
 
-  textual = in_comment = last_character_on_previous_line = 0;
 
-  if ((spool = datum = getc (source)) != EOF)
 
-    {
 
-      front_column = back_column = NULL;
 
-      in_comment = (datum == '#');
 
-      while (datum != line_break ? datum != EOF : 0)
 
-	{
 
-	  if (in_comment ? 0 : (textual ? 0 : !(textual=(front_branch ? (spool<60 ? 1 : (spool=spool-60) & 0xffc0) : 1))))
 
-	    {
 
-	      spoke = 6;
 
-	      while (spoke)
 
-		avm_enqueue_branch (&front_branch, &back_branch,(spool >> (--spoke)) & 1);
 
-	    }
 
-	  avm_enqueue (&front_column, &back_column,avm_character_representation (datum));
 
-	  last_character_on_previous_line = datum;
 
-	  spool = datum = getc (source);
 
-	}
 
-      avm_enqueue (&front_line, &back_line, front_column);
 
-      while (datum == line_break)
 
-	{
 
-	  front_column = back_column = NULL;
 
-	  in_comment = ((previously_in_comment = in_comment) ? (last_character_on_previous_line == '\\') : 0);
 
-	  last_character_on_previous_line = 0;
 
-	  while ((spool = datum = getc (source)) != line_break ? datum != EOF : 0)
 
-	    {
 
-	      in_comment = (in_comment ? 1 : (front_column ? 0 : (previously_in_comment ? (datum == '#') : 0)));
 
-	      if (in_comment ? 0 : (textual ? 0 : !(textual=(front_branch ? (spool< 60 ? 1 : (spool=spool-60) & 0xffc0):1))))
 
-		{
 
-		  spoke = 6;
 
-		  while (spoke)
 
-		    avm_enqueue_branch (&front_branch, &back_branch, (spool >> (--spoke)) & 1);
 
-		}
 
-	      avm_enqueue (&front_column, &back_column, avm_character_representation (datum));
 
-	      last_character_on_previous_line = datum;
 
-	    }
 
-	  avm_enqueue (&front_line, &back_line, front_column);
 
-	}
 
-    }
 
-  if (front_branch ? 1 : textual)
 
-    {
 
-      preamble = NULL;
 
-      avm_dispose (raw_data);
 
-      contents = front_line;
 
-    }
 
-  else
 
-    {
 
-      if (!(preamble = initial_comments (front_line)))
 
-	preamble = avm_copied (shared_cell);
 
-      avm_dispose (front_line);
 
-      contents = raw_data;
 
-    }
 
-  avm_dispose_branch_queue (front_branch);
 
-  if (filename)
 
-    {
 
-      if (fclose (source))
 
-	avm_non_fatal_io_error ("can't close", filename, errno);
 
-    }
 
-  return (avm_join (preamble, contents));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_load (source, filename, raw)
 
-     FILE *source;
 
-     char *filename;
 
-     int raw;
 
-
 
-     /* This is used for file input when the caller knows whether it
 
-	should be raw or text. A fatal error results if something
 
-	that's supposed to be data is text. */
 
-
 
-{
 
-  int datum;
 
-  list front_line, back_line, front_column, back_column;
 
-
 
-  if (!initialized)
 
-    avm_initialize_formin ();
 
-  front_line = (raw ? avm_received_list (source,(filename ? filename : "standard input")) : (back_line = NULL));
 
-  if (!raw)
 
-    {
 
-      if ((datum = getc (source)) != EOF)
 
-	{
 
-	  front_column = back_column = NULL;
 
-	  while (datum != line_break ? datum != EOF : 0)
 
-	    {
 
-	      avm_enqueue (&front_column, &back_column, avm_character_representation (datum));
 
-	      datum = getc (source);
 
-	    }
 
-	  avm_enqueue (&front_line, &back_line, front_column);
 
-	  while (datum == line_break)
 
-	    {
 
-	      front_column = back_column = NULL;
 
-	      while ((datum = getc (source)) != line_break ? datum != EOF : 0)
 
-		avm_enqueue (&front_column, &back_column,avm_character_representation (datum));
 
-	      avm_enqueue (&front_line, &back_line, front_column);
 
-	    }
 
-	}
 
-    }
 
-  if (filename)
 
-    if (fclose (source))
 
-      avm_non_fatal_io_error ("can't close", filename, errno);
 
-  return front_line;
 
-}
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_formin ()
 
-
 
-     /* This creates some static variables. */
 
-
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_branches ();
 
-  avm_initialize_chrcodes ();
 
-  shared_cell = avm_join (NULL, NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_formin ()
 
-
 
-     /* This frees some static variables. */
 
-
 
-{
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (shared_cell);
 
-  shared_cell = NULL;
 
-}

+ 0 - 316
src/formout.c
View File 

@@ -1,316 +0,0 @@
 
-
 
-/* functions writing lists out to text and data files
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.  
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/branches.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/rawio.h>
 
-#include <avm/formin.h>
 
-#include <avm/fnames.h>
 
-#include <avm/formout.h>
 
-#include <ctype.h>
 
-
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* the character code for a line break */
 
-static int line_break = 10;
 
-
 
-
 
-
 
-
 
-void
 
-avm_output (repository, filename, preamble, contents, trace_mode)
 
-     FILE *repository;
 
-     char *filename;
 
-     list preamble;
 
-     list contents;
 
-     int trace_mode;
 
-
 
-     /* Iff the preamble is non-empty, the contents are output in raw
 
-        data format. Iff the first character of the preamble is an
 
-        exclamation point, the file is marked executable. If the
 
-        preamble is empty, the contents are output as text. */
 
-
 
-{
 
-  int datum;
 
-  list line;
 
-  int ioerror;
 
-  int incomment;
 
-  int executable;
 
-
 
-  if (!initialized)
 
-    avm_initialize_formout ();
 
-  executable = ioerror = incomment = 0;
 
-  if (!repository)
 
-    avm_internal_error (24);
 
-  else if (preamble)
 
-    {
 
-      if (preamble->head ? 1 : !!(preamble->tail))
 
-	{
 
-	  incomment = 0;
 
-	  while (preamble ? !ioerror : 0)
 
-	    {
 
-	      line = preamble->head;
 
-	      if (!incomment)
 
-		{
 
-		  if (putc ('#', repository) != '#')
 
-		    avm_non_fatal_io_error ("can't write to", filename, errno);
 
-		}
 
-	      incomment = 0;
 
-	      while (line ? !ioerror : 0)
 
-		{
 
-		  if (line->head ? (line->head->characteristic ? 1 : 0) : 0)
 
-		    {
 
-		      incomment = (line->head->characterization == '\\');
 
-		      if (!executable)
 
-			executable = ((line->head == preamble->head->head) ? (line->head->characterization == '!') : 0);
 
-		      if (putc (line->head->characterization, repository) != line->head->characterization)
 
-			  avm_non_fatal_io_error ("can't write to", filename, errno);
 
-		      else if (line->head->characterization == line_break)
 
-			avm_error ("invalid output preamble format");
 
-		    }
 
-		  else
 
-		    {
 
-		      if ((datum = avm_character_code (line->head)) < 0)
 
-			avm_error ("invalid output preamble format");
 
-		      else if (datum == line_break)
 
-			avm_error ("invalid output preamble format");
 
-		      else if (putc (datum, repository) != datum)
 
-			  avm_non_fatal_io_error ("can't write to", filename, errno);
 
-		      else
 
-			{
 
-			  incomment = (datum == '\\');
 
-			  executable = executable ? 1 : ((line->head == preamble->head->head) ? (datum == '!') : 0);
 
-			}
 
-		    }
 
-		  line = line->tail;
 
-		}
 
-	      preamble = preamble->tail;
 
-	      if (putc (line_break, repository) != line_break)
 
-		avm_non_fatal_io_error ("can't write to", filename, errno);
 
-	    }
 
-	}
 
-      if (executable ? (repository != stdout) : 0)
 
-	chmod (filename, S_IXUSR | S_IXGRP | S_IXOTH | S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR);
 
-      avm_send_list (repository, contents, filename);
 
-    }
 
-  else
 
-    {
 
-      while (contents ? !ioerror : 0)
 
-	{
 
-	  line = contents->head;
 
-	  while (line ? !ioerror : 0)
 
-	    {
 
-	      if (line->head ? (line->head->characteristic ? 1 : 0) : 0)
 
-		{
 
-		  if (trace_mode)
 
-		    printf ("%c", line->head->characterization);
 
-		  if (putc (line->head->characterization, repository) != line->head->characterization)
 
-		    avm_non_fatal_io_error ("can't write to", filename, errno);
 
-		}
 
-	      else if ((datum = avm_character_code (line->head)) < 0)
 
-		avm_error ("invalid text format (code 3)");
 
-	      else if (putc (datum, repository) != datum)
 
-		avm_non_fatal_io_error ("can't write to", filename, errno);
 
-	      else if (trace_mode)
 
-		printf ("%c", datum);
 
-	      line = line->tail;
 
-	    }
 
-	  if (trace_mode ? (contents->tail) : 0)
 
-	    printf ("\n");
 
-	  if ((contents = contents->tail) ? putc (line_break, repository) != line_break : 0)
 
-	    avm_non_fatal_io_error ("can't write to", filename, errno);
 
-	}
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_output_as_directed (data, ask_to_overwrite_mode, verbose_mode)
 
-     list data;
 
-     int ask_to_overwrite_mode;
 
-     int verbose_mode;
 
-
 
-     /* This outputs a list of files specified in the form of a list
 
-        of quadruples ((overwrite,path),(preamble,contents)). If the
 
-        rewrite field is non-null, the file is opened for writing, but
 
-        if it's null, the file is opened for appending. For security
 
-        reasons, standard output is done last, so that malicious
 
-        virtual code applications can't alter the query messages by
 
-        using stdout to clobber the console.
 
-
 
-        Thanks to Norm Pleszkoch for the part about buffered input.
 
-     */
 
-
 
-{
 
-  int authorized;
 
-  FILE *repository;
 
-  char *filename;
 
-  char *program_name;
 
-  char key;
 
-  list old, front_preamble, back_preamble, front_contents, back_contents;
 
-
 
-#define current_file (data->head)
 
-#define current_overwrite (current_file->head->head)
 
-#define current_path (current_file->head->tail)
 
-#define current_preamble (current_file->tail->head)
 
-#define current_contents (current_file->tail->tail)
 
-
 
-  if (!initialized)
 
-    avm_initialize_formout ();
 
-  program_name = avm_program_name ();
 
-  front_preamble = back_preamble = front_contents = back_contents = NULL;
 
-  while (data)
 
-    {
 
-      if (!(current_file) ? 1 : !(current_file->tail) ? 1 : !(current_file->head))
 
-	avm_error ("invalid file specification");
 
-      else if (!(filename = avm_path_name (current_path)))
 
-	{
 
-	  avm_enqueue (&front_preamble, &back_preamble, avm_copied (current_preamble));
 
-	  avm_enqueue (&front_contents, &back_contents, avm_copied (current_contents));
 
-	}
 
-      else
 
-	{
 
-	  if (!(authorized = !(ask_to_overwrite_mode ? repository = fopen (filename, "rb") : 0)))
 
-	    {
 
-	      if (fclose (repository))
 
-		avm_non_fatal_io_error ("can't close", filename, errno);
 
-	      for (key = ' '; (authorized = (key != 'N')) && (key != 'Y');)
 
-		{
 
-		  printf ("%s: %s `%s'? (y/n) ", program_name, current_overwrite ? "overwrite" : "append to", filename);
 
-		  fflush (stdout);	/* usually stdout is buffered. (sometimes stderr is also) */
 
-		  key = toupper (getchar ());
 
-		  if (key != '\n')
 
-		    for (; '\n' != getchar (););
 
-		}
 
-	    }			/* flush out stdin up to (and including) the '\n' */
 
-	  if (authorized)
 
-	    {
 
-	      if (!(repository = fopen (filename, current_overwrite ? "wb" : "ab")))
 
-		avm_non_fatal_io_error ("can't write", filename, errno);
 
-	      else
 
-		{
 
-		  if (verbose_mode)
 
-		    {
 
-		      if(current_overwrite)
 
-			printf ("%s: writing `%s'\n", program_name, filename);
 
-		      else
 
-			printf ("%s: appending `%s'\n", program_name, filename);
 
-		    }
 
-		  avm_output (repository, filename, current_preamble, current_contents, 0);
 
-		  if (fclose (repository))
 
-		    avm_non_fatal_io_error ("can't close", filename, errno);
 
-		}
 
-	    }
 
-	  else if (verbose_mode)
 
-	    {
 
-	      if(current_overwrite)
 
-		printf ("%s: not writing `%s'\n", program_name, filename);
 
-	      else
 
-		printf ("%s: not appending `%s'\n", program_name, filename);
 
-	    }
 
-	  free (filename);
 
-	}
 
-      data = data->tail;
 
-    }
 
-  while (front_preamble)
 
-    {
 
-      avm_output (stdout, "standard output", front_preamble->head, front_contents->head, 0);
 
-      front_preamble = avm_copied ((old = front_preamble)->tail);
 
-      avm_dispose (old);
 
-      front_contents = avm_copied ((old = front_contents)->tail);
 
-      avm_dispose (old);
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_put_bytes (bytes)
 
-     list bytes;
 
-
 
-     /* This takes a list of character representations and sends it to
 
-	standard output as characters. */
 
-
 
-{
 
-  int ioerror;
 
-  int datum;
 
-
 
-  ioerror = 0;
 
-  if (!initialized)
 
-    avm_initialize_formout ();
 
-  while (bytes ? !ioerror : 0)
 
-    {
 
-      if ((datum = avm_character_code (bytes->head)) < 0)
 
-	avm_error ("invalid text format (code 2)");
 
-      else if (ioerror = (putc (datum, stdout) != datum))
 
-	avm_non_fatal_io_error ("can't write to", "standard output", errno);
 
-      bytes = bytes->tail;
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_formout ()
 
-
 
-     /* This initializes some static data. */
 
-
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_fnames ();
 
-  avm_initialize_branches ();
 
-  avm_initialize_chrcodes ();
 
-  avm_initialize_formin ();
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_formout ()
 
-
 
-     /* This is a hook for future use. */
 
-
 
-{
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-}

+ 0 - 477
src/glpklib.c
View File 

@@ -1,477 +0,0 @@
 
-
 
-/* this file interfaces to linear programming routines from glpk
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.  
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/compare.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/glpklib.h>
 
-#include <avm/mwrap.h>
 
-#if HAVE_GLPK
 
-#include <glpk.h>
 
-#endif
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list bad_glpk_spec = NULL;
 
-static list memory_overflow = NULL;
 
-static list unrecognized_function_name = NULL;
 
-
 
-/* function names as lists of lists of character representations */
 
-static list wild = NULL;
 
-static list funs = NULL;
 
-
 
-#if HAVE_GLPK
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static LPX
 
-*problem_object(cost_vector, constraint_matrix, constraint_vector, rows, columns, message, fault)
 
-     list cost_vector;
 
-     list constraint_matrix;
 
-     list constraint_vector;
 
-     int *rows;
 
-     int *columns;
 
-     list *message;
 
-     int *fault;
 
-
 
-     /* This takes the lists specifying the problem to an LPX type
 
-	problem object. It uses memory managment routines from mwrap.c
 
-	because glpk performs many allocations behind the scenes with
 
-	demonstrable leaks and no policy for exception handling
 
-	defined by the API. Memory management is switched off on exit
 
-	from this function, but will need to be on when the problem
 
-	object is deleted. If there is insufficient memory, a NULL
 
-	value is returned and if we're lucky everything is
 
-	reclaimed. */
 
-{
 
-  int  *ia, *ja, problem_size, position_number, row_number, column_number;
 
-  double *ar, *y, *c, *a;
 
-  LPX *lp;
 
-
 
-  if (*fault = (*fault ? 1 : !!(*message)))
 
-    return NULL;
 
-  ia = (int *) malloc((problem_size = 1 + (int) avm_length(constraint_matrix)) * sizeof(int));
 
-  ja = (int *) malloc(problem_size * sizeof(int));
 
-  ar = (double *) malloc(problem_size * sizeof(double));
 
-  if (*fault = !(ia ? (ja ? !!ar : 0) : 0))
 
-    {
 
-      if (ia)
 
-	free (ia);
 
-      if (ja)
 
-	free (ja);
 
-      if (ar)
 
-	free (ar);
 
-      *message = avm_copied (memory_overflow);
 
-      return NULL;
 
-    }
 
-  avm_manage_memory ();                                     /* all allocations by glpk will be logged from this point */
 
-  if (*fault = (avm_setjmp() != 0))
 
-    {
 
-      free (ia);                 /* this point is reached if setjmp is configured and malloc fails in a glpk function */
 
-      free (ja);
 
-      free (ar);
 
-      avm_clearjmp ();
 
-      *message = avm_copied (memory_overflow);
 
-      return NULL;
 
-    }
 
-  if (*fault = !(lp = lpx_create_prob ()))                    /* otherwise hope it returns a NULL if allocation fails */
 
-    {
 
-      free (ia);
 
-      free (ja);
 
-      free (ar);
 
-      avm_clearjmp ();
 
-      avm_free_managed_memory ();
 
-      *message = avm_copied (memory_overflow);
 
-      return NULL;
 
-    }
 
-  lpx_set_obj_dir (lp, LPX_MIN);                 /* success can't be verified via the documented API after this point */
 
-  lpx_set_int_parm (lp, LPX_K_MSGLEV, 0);
 
-  lpx_set_int_parm (lp, LPX_K_PRESOL, 1);
 
-  lpx_add_cols (lp, *columns = (int) avm_length (cost_vector));
 
-  column_number = 0;
 
-  lpx_set_obj_coef (lp, column_number, 0.0);
 
-  while (*fault ? 0 : (column_number++ < *columns))
 
-    {
 
-      avm_dont_manage_memory ();
 
-      c = ((*fault = !cost_vector) ? NULL : (double *) avm_value_of_list(cost_vector->head, message, fault));
 
-      avm_manage_memory ();
 
-      lpx_set_col_bnds(lp, column_number, LPX_LO, 0.0, 0.0);
 
-      lpx_set_obj_coef(lp, column_number, *fault ? 0.0 : *c);
 
-      cost_vector = cost_vector->tail;
 
-    }
 
-  lpx_add_rows(lp, *rows = (int) avm_length(constraint_vector));
 
-  row_number = 0;
 
-  while (*fault ? 0 : (row_number++ < *rows))
 
-    {
 
-      avm_dont_manage_memory ();
 
-      y = ((*fault = !constraint_vector) ? NULL : (double *) avm_value_of_list (constraint_vector->head, message, fault));
 
-      avm_manage_memory ();
 
-      lpx_set_row_bnds (lp, row_number, LPX_FX, *fault ? 0.0 : *y, *fault ? 0.0 : *y);
 
-      constraint_vector = constraint_vector->tail;
 
-    }
 
-  position_number = 0;
 
-  avm_dont_manage_memory ();
 
-  while (constraint_matrix ? !(*fault = (*fault ? 1 : !(constraint_matrix->head ? constraint_matrix->head->head : 0))) : 0)
 
-    {
 
-      ia[++position_number] = 1 + (int) avm_counter(constraint_matrix->head->head->head);
 
-      ja[position_number] = 1 + (int) avm_counter(constraint_matrix->head->head->tail);
 
-      *fault = ((ia[position_number] > *rows) ? 1 : (ja[position_number] > *columns));
 
-      a = (*fault ? NULL : (double *) avm_value_of_list(constraint_matrix->head->tail, message, fault));
 
-      ar[position_number] = (*fault ? 0.0 : *a);
 
-      constraint_matrix = constraint_matrix->tail;
 
-    }
 
-  avm_manage_memory ();
 
-  if (!*fault)
 
-    lpx_load_matrix(lp, problem_size - 1, ia, ja, ar);
 
-  avm_dont_manage_memory ();
 
-  free (ia);
 
-  free (ja);
 
-  free (ar);
 
-  if (!*fault)
 
-    {
 
-      avm_clearjmp ();
 
-      return lp;
 
-    }
 
-  *message = (*message ? *message : avm_copied (bad_glpk_spec));
 
-  avm_manage_memory ();
 
-  if (lp)
 
-    lpx_delete_prob (lp);
 
-  avm_free_managed_memory ();
 
-  avm_clearjmp ();
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-simplex_solution (lp, columns, fault)
 
-     LPX *lp;
 
-     int columns;
 
-     int *fault;
 
-
 
-     /* this gets the simplex solution out of the problem object,
 
-	ignoring the variables that aren't exactly zero */
 
-{
 
-  list front, back, item, index;
 
-  int column_number;
 
-  double x;
 
-
 
-  column_number = 0;
 
-  front = back = item = NULL;
 
-  while (*fault ? 0 : (column_number++ < columns))
 
-    if ((x = lpx_get_col_prim (lp, column_number)) != 0)
 
-      if (!(*fault = !((index = avm_recoverable_natural (column_number - 1)) ? 1 : !(column_number - 1))))
 
-	{
 
-	  item = avm_list_of_value((void *) &x, sizeof(double), fault);
 
-	  if (*fault)
 
-	    {
 
-	      if (index)
 
-		avm_dispose (index);
 
-	    }
 
-	  else if (!(*fault = !(item = avm_recoverable_join (index,item))))
 
-	    {
 
-	      avm_recoverable_enqueue(&front, &back, item, fault);
 
-	      item = NULL;
 
-	    }
 
-	}
 
-  if (*fault ? front : NULL)
 
-    avm_dispose (front);
 
-  return (*fault ? (item ? item : avm_copied (memory_overflow)) : front);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-interior_solution (lp, rows, columns, fault)
 
-     LPX *lp;
 
-     int rows;
 
-     int columns;
 
-     int *fault;
 
-
 
-     /* this gets the interior point solution out of the problem
 
-	object taking no more than the right number of variables by
 
-	ignoring the smallest ones */
 
-{
 
-  list front, back, item, index;
 
-  int column_number, non_zeros, threshold_index;
 
-  double x, threshold;
 
-
 
-  non_zeros = 0;
 
-  threshold = 0.0;
 
-  while ((non_zeros == rows) ? 0 : rows)
 
-    {
 
-      threshold_index = 0;
 
-      while ((non_zeros == rows) ? 0 : (threshold_index < columns))
 
-	{
 
-	  non_zeros = column_number = 0;
 
-	  threshold = lpx_ipt_col_prim (lp, threshold_index + 1);
 
-	  while ((non_zeros > rows) ? 0 : column_number < columns)
 
-	    non_zeros = non_zeros + ((lpx_ipt_col_prim (lp, ++column_number) >= threshold) ? 1 : 0);
 
-	  if (non_zeros < rows)
 
-	    while ((threshold_index < columns) ? (lpx_ipt_col_prim (lp, threshold_index + 1) >= threshold) : 0)
 
-	      threshold_index++;
 
-	  else if (non_zeros > rows)
 
-	    while ((threshold_index < columns) ? (lpx_ipt_col_prim (lp, threshold_index + 1) <= threshold) : 0)
 
-	      threshold_index++;
 
-	}
 
-      if (non_zeros != rows)
 
-	{
 
-	  non_zeros = 0;
 
-	  threshold = 0.0;
 
-	  rows--;
 
-	}
 
-    }
 
-  column_number = 0;
 
-  front = back = item = NULL;
 
-  while (*fault ? 0 : (column_number++ < columns))
 
-    if ((x = lpx_ipt_col_prim (lp, column_number)) >= threshold)
 
-      if (!(*fault = !((index = avm_recoverable_natural (column_number - 1)) ? 1 : !(column_number - 1))))
 
-	{
 
-	  item = avm_list_of_value((void *) &x, sizeof(double), fault);
 
-	  if (*fault)
 
-	    {
 
-	      if (index)
 
-		avm_dispose (index);
 
-	    }
 
-	  else if (!(*fault = !(item = avm_recoverable_join (index,item))))
 
-	    {
 
-	      avm_recoverable_enqueue(&front, &back, item, fault);
 
-	      item = NULL;
 
-	    }
 
-	}
 
-  if (*fault ? front : NULL)
 
-    avm_dispose (front);
 
-  return (*fault ? (item ? item : avm_copied (memory_overflow)) : front);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-solution(simplex, operand, fault)
 
-     int simplex;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* operand should represent a triple of (c,m,y), where c is a
 
-	list of cost function coefficients (with no constant term) m
 
-	is a sparse matrix in the form of a list of pairs ((i,j),a)
 
-	where i and j are row and column indices starting from 0 and a
 
-	is real, and y is a list of reals such that the problem
 
-	solution x minimizes cx subject to mx=y and all members of x
 
-	non-negative. The list of indices and values (i,xi) for
 
-	non-zero reals xi in the solution is returned. */
 
-{
 
-  list result;
 
-  LPX *lp;
 
-  int rows,columns;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !(operand ? (operand->tail) : NULL))
 
-    return avm_copied(bad_glpk_spec);
 
-  result = NULL;
 
-  lp = problem_object (operand->head, operand->tail->head, operand->tail->tail, &rows, &columns, &result, fault);
 
-  if (*fault = (*fault ? 1 : !!result))
 
-    return result;
 
-  avm_turn_off_stdout ();
 
-  if ((simplex ? lpx_simplex(lp) : lpx_interior(lp)) == LPX_E_OK)
 
-    result = (simplex ? simplex_solution(lp, columns, fault) : interior_solution (lp, rows, columns, fault));
 
-  avm_turn_on_stdout ();
 
-  avm_manage_memory ();
 
-  lpx_delete_prob (lp);
 
-  avm_free_managed_memory ();
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-#endif
 
-
 
-
 
-
 
-
 
-list
 
-avm_have_glpk_call (list function_name, int *fault)
 
-
 
-/* this reports the availability of a function */
 
-
 
-{
 
-#if HAVE_GLPK
 
-  list membership;
 
-  list comparison;
 
-  list result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_glpk ();
 
-  if (*fault)
 
-    return NULL;
 
-  comparison = avm_binary_comparison (function_name, wild, fault);
 
-  if (*fault)
 
-    return comparison;
 
-  if (comparison)
 
-    {
 
-      avm_dispose(comparison);
 
-      return avm_copied(funs);
 
-    }
 
-  if (!(membership = avm_binary_membership (function_name, funs, fault)) ? 1 : *fault)
 
-    return membership;
 
-  avm_dispose(membership);
 
-  return ((*fault = !(result = avm_recoverable_join(avm_copied(function_name),NULL))) ? avm_copied(memory_overflow) : result);
 
-#endif
 
-  return (NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_glpk_call (function_name, argument, fault)
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-{
 
-#if HAVE_GLPK
 
-
 
-  list message;
 
-  int function_number;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (! initialized)
 
-    avm_initialize_glpk ();
 
-  if (!(function_number = 0xff & (function_name ? function_name->characterization : 0)))
 
-    {
 
-      message = avm_position (function_name, funs, fault);
 
-      if (*fault = (*fault ? 1 : !message))
 
-	return (message ? message : avm_copied (unrecognized_function_name));
 
-      function_number = message->characterization;
 
-      function_name->characterization = function_number;
 
-      avm_dispose (message);
 
-    }
 
-  switch (function_number)
 
-    {
 
-    case 1: return solution (0, argument, fault);
 
-    case 2: return solution (1, argument, fault);
 
-    }
 
-#endif /* HAVE_GLPK */
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_glpk ()
 
-
 
-     /* This initializes some static data structures. */
 
-
 
-{
 
-  char *funames[] = {
 
-    "interior",
 
-    "simplex",
 
-    NULL};            /* add more function names here up to a total of 255 */
 
-  list back;
 
-  int string_number;
 
-
 
-  if (initialized)
 
-      return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_chrcodes ();
 
-  avm_initialize_mwrap ();
 
-  wild = avm_strung("*");
 
-  bad_glpk_spec = avm_join (avm_strung ("bad glpk problem specification"), NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  unrecognized_function_name = avm_join (avm_strung ("unrecognized glpk function name"), NULL);
 
-  string_number = 0;
 
-  funs = back = NULL;
 
-  while (funames[string_number])
 
-      avm_enqueue (&funs, &back, avm_standard_strung (funames[string_number++]));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_glpk ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-
 
-  if (!initialized)
 
-      return;
 
-  initialized = 0;
 
-  avm_dispose (funs);
 
-  avm_dispose (wild);
 
-  avm_dispose (bad_glpk_spec);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (unrecognized_function_name);
 
-  funs = NULL;
 
-  wild = NULL;
 
-  bad_glpk_spec = NULL;
 
-  memory_overflow = NULL;
 
-  unrecognized_function_name = NULL;
 
-}

+ 0 - 364
src/gsldiflib.c
View File 

@@ -1,364 +0,0 @@
 
-
 
-/* this file incorporates numerical differentiation routines from gsl
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.  
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/compare.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/gsldiflib.h>
 
-#include <math.h>
 
-#include <avm/apply.h>
 
-
 
-#if HAVE_GSL
 
-
 
-#include <gsl/gsl_math.h>
 
-#include <gsl/gsl_deriv.h>
 
-#include <gsl/gsl_errno.h>
 
-
 
-#endif
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list bad_dif_spec = NULL;
 
-static list differentiation_error = NULL;
 
-static list memory_overflow = NULL;
 
-static list unrecognized_function_name = NULL;
 
-
 
-/* function names as lists of lists of character representations */
 
-static list wild = NULL;
 
-static list funs = NULL;
 
-
 
-#if HAVE_GSL
 
-
 
-struct fspec {
 
-  list operator;
 
-  list message;
 
-  int fault;
 
-};
 
-
 
-#define DEFAULT_TOLERANCE 1.0e-8
 
-
 
-typedef struct fspec *fsptr;
 
-typedef int (*differentiator)(gsl_function*,double,double,double*,double*);
 
-
 
-
 
-double
 
-differand (x,params)
 
-     double x;
 
-     void* params;
 
-
 
-     /* the c function passed to gsl for differentiaiton */
 
-{
 
-  fsptr spec;
 
-  list result;
 
-  double *y;
 
-
 
-  spec = (fsptr) params;
 
-  if (spec->fault = ((spec->fault) ? 1 : !!(spec->message)))
 
-    return 0.0;
 
-  result = avm_list_of_value ((void *) &x, sizeof(double), &spec->fault);
 
-  if (spec->fault)
 
-    {
 
-      spec->message = result;
 
-      return 0.0;
 
-    }
 
-  result = avm_recoverable_apply(avm_copied(spec->operator), result, &(spec->fault));
 
-  if (spec->fault)
 
-    {
 
-      spec->message = result;
 
-      return 0.0;
 
-    }
 
-  y = (double *) avm_value_of_list (result, &(spec->message), &(spec->fault));
 
-  if (spec->fault)
 
-    {
 
-      avm_dispose (result);
 
-      return 0.0;
 
-    }
 
-  x = *y;
 
-  avm_dispose (result);
 
-  return x;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-derivative(method,argument,fault)
 
-     differentiator method;
 
-     list argument;
 
-     int *fault;
 
-
 
-     /* evaluates a derivative by the given method; the argument is a
 
-	list representing (f,x), where f is a real valued function of
 
-	a real variable, and x is a real number */
 
-{
 
-  list result;
 
-  double *x;
 
-  int code;
 
-  gsl_function F;
 
-  double dy,roundoff_error;
 
-  struct fspec spec;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !(argument ? (argument->head ? argument->tail : NULL) : NULL))
 
-    return avm_copied (bad_dif_spec);
 
-  result = NULL;
 
-  x = (double *) avm_value_of_list(argument->tail,&result,fault);
 
-  if (*fault = (*fault ? 1 : !!result))
 
-    return result;
 
-  spec.operator = argument->head;
 
-  spec.fault = 0;
 
-  spec.message = NULL;
 
-  F.params = (void *) &spec;
 
-  F.function = &differand;
 
-  if (!((code = (*method)(&F, *x, DEFAULT_TOLERANCE, &dy, &roundoff_error)) ? 1 : spec.fault))
 
-    return avm_list_of_value((void *) &dy,sizeof(double),fault);
 
-  if (!spec.message)
 
-    spec.message = avm_recoverable_join(avm_recoverable_strung((char *) gsl_strerror(code),fault),NULL);
 
-  result = (spec.message ? spec.message : avm_copied(differentiation_error));
 
-  *fault = 1;
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-t_derivative(method,argument,fault)
 
-     differentiator method;
 
-     list argument;
 
-     int *fault;
 
-
 
-     /* evaluates a derivative by the given method; the argument is a
 
-	list representing ((f,t),x), where f is a real valued function
 
-	of a real variable, t is a real tolerance, and x is a real
 
-	number */
 
-{
 
-  list result;
 
-  double *x;
 
-  double *t;
 
-  int code;
 
-  gsl_function F;
 
-  double dy,roundoff_error;
 
-  struct fspec spec;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !(argument ? (argument->head ? argument->tail : NULL) : NULL))
 
-    return avm_copied (bad_dif_spec);
 
-  if (*fault = !(argument->head->head ? argument->head->tail : NULL))
 
-    return avm_copied (bad_dif_spec);
 
-  result = NULL;
 
-  x = (double *) avm_value_of_list(argument->tail,&result,fault);
 
-  if (*fault = (*fault ? 1 : !!result))
 
-    return result;
 
-  t = (double *) avm_value_of_list(argument->head->tail,&result,fault);
 
-  if (*fault = (*fault ? 1 : !!result))
 
-    return result;
 
-  spec.operator = argument->head->head;
 
-  spec.fault = 0;
 
-  spec.message = NULL;
 
-  F.params = (void *) &spec;
 
-  F.function = &differand;
 
-  if (!((code = (*method)(&F, *x, *t, &dy, &roundoff_error)) ? 1 : spec.fault))
 
-    return avm_list_of_value((void *) &dy,sizeof(double),fault);
 
-  if (!spec.message)
 
-    spec.message = avm_recoverable_join(avm_recoverable_strung((char *) gsl_strerror(code),fault),NULL);
 
-  result = (spec.message ? spec.message : avm_copied(differentiation_error));
 
-  *fault = 1;
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-#endif
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_have_gsldif_call (list function_name, int *fault)
 
-
 
-/* this reports the availability of a function */
 
-
 
-{
 
-#if HAVE_GSL
 
-  list membership;
 
-  list comparison;
 
-  list result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_gsldif ();
 
-  if (*fault)
 
-    return NULL;
 
-  comparison = avm_binary_comparison (function_name, wild, fault);
 
-  if (*fault)
 
-    return comparison;
 
-  if (comparison)
 
-    {
 
-      avm_dispose(comparison);
 
-      return avm_copied(funs);
 
-    }
 
-  if (!(membership = avm_binary_membership (function_name, funs, fault)) ? 1 : *fault)
 
-    return membership;
 
-  avm_dispose(membership);
 
-  return ((*fault = !(result = avm_recoverable_join(avm_copied(function_name),NULL))) ? avm_copied(memory_overflow) : result);
 
-#endif
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_gsldif_call (function_name, argument, fault)
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-
 
-     /* This figures out what function to call and calls it. */
 
-
 
-{
 
-#if HAVE_GSL
 
-  list message;
 
-  int function_number;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (! initialized)
 
-    avm_initialize_gsldif ();
 
-  if (!(function_number = 0xff & (function_name ? function_name->characterization : 0)))
 
-    {
 
-      message = avm_position (function_name, funs, fault);
 
-      if (*fault)
 
-	return message;
 
-      if (*fault = !message)
 
-	return avm_copied (unrecognized_function_name);
 
-      function_number = message->characterization;
 
-      function_name->characterization = function_number;
 
-      avm_dispose (message);
 
-    }
 
-  switch (function_number)
 
-    {
 
-    case 1: return derivative((differentiator) &gsl_deriv_central, argument, fault);
 
-    case 2: return derivative((differentiator) &gsl_deriv_forward, argument, fault);
 
-    case 3: return derivative((differentiator) &gsl_deriv_backward, argument, fault);
 
-    case 4: return t_derivative((differentiator) &gsl_deriv_central, argument, fault);
 
-    case 5: return t_derivative((differentiator) &gsl_deriv_forward, argument, fault);
 
-    case 6: return t_derivative((differentiator) &gsl_deriv_backward, argument, fault);
 
-    }
 
-#endif /* HAVE_GSL */
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_gsldif ()
 
-
 
-     /* This initializes some static data structures. */
 
-
 
-{
 
-  char *funames[] = {
 
-    "central",
 
-    "forward",
 
-    "backward",
 
-    "t_central",
 
-    "t_forward",
 
-    "t_backward",
 
-    NULL};            /* add more function names here up to a total of 255 */
 
-  list back;
 
-#if HAVE_GSL
 
-  gsl_error_handler_t *old_handler;
 
-#endif
 
-  int string_number;
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_apply ();
 
-  avm_initialize_listfuns ();
 
-  avm_initialize_chrcodes ();
 
-#if HAVE_GSL
 
-  old_handler = gsl_set_error_handler_off();
 
-#endif
 
-  wild = avm_strung("*");
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  bad_dif_spec = avm_join (avm_strung ("bad derivative specification"), NULL);
 
-  differentiation_error = avm_join (avm_strung ("differentiation error"), NULL);
 
-  unrecognized_function_name = avm_join (avm_strung ("unrecognized gsldif function name"), NULL);
 
-  string_number = 0;
 
-  funs = back = NULL;
 
-  while (funames[string_number])
 
-    avm_enqueue (&funs, &back, avm_standard_strung (funames[string_number++]));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_gsldif ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (funs);
 
-  avm_dispose (wild);
 
-  avm_dispose (bad_dif_spec);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (differentiation_error);
 
-  avm_dispose (unrecognized_function_name);
 
-  funs = NULL;
 
-  wild = NULL;
 
-  bad_dif_spec = NULL;
 
-  memory_overflow = NULL;
 
-  differentiation_error = NULL;
 
-  unrecognized_function_name = NULL;
 
-}

+ 0 - 260
src/gslevu.c
View File 

@@ -1,260 +0,0 @@
 
-
 
-/* this file incorporates series acceleration routines from gsl
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/compare.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/gslevu.h>
 
-#include <math.h>
 
-#include <avm/apply.h>
 
-#include <avm/matcon.h>
 
-
 
-#if HAVE_GSL
 
-
 
-#include <gsl/gsl_sum.h>
 
-#include <gsl/gsl_math.h>
 
-#include <gsl/gsl_errno.h>
 
-
 
-#endif
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list empty_sequence = NULL;
 
-static list memory_overflow = NULL;
 
-static list unrecognized_function_name = NULL;
 
-
 
-/* function names as lists of lists of character representations */
 
-static list wild = NULL;
 
-static list funs = NULL;
 
-
 
-#if HAVE_GSL
 
-
 
-
 
-
 
-
 
-list
 
-levinu(trunc, series, fault)
 
-     int trunc;
 
-     list series;
 
-     int *fault;
 
-
 
-     /* series should be a list of doubles; the result is a pair
 
-	of doubles (sum,error) */
 
-{
 
-  double *terms;
 
-  double sum,error;
 
-  list result,sum_list,error_list;
 
-  size_t number_of_terms;
 
-  gsl_sum_levin_u_workspace *w;
 
-  gsl_sum_levin_utrunc_workspace *tw;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  if (*fault = !(number_of_terms = avm_length(series)))
 
-    return avm_copied(empty_sequence);
 
-  terms = avm_vector_of_list (series, sizeof(double), &result, fault);
 
-  w = (trunc ? NULL : gsl_sum_levin_u_alloc (number_of_terms));
 
-  tw = (trunc ? gsl_sum_levin_utrunc_alloc (number_of_terms) : NULL);
 
-  if (trunc ? 0 : !(*fault = (*fault ? 1 : !(w ? terms : NULL))))
 
-    gsl_sum_levin_u_accel (terms, number_of_terms, w, &sum, &error);
 
-  if (trunc ? !(*fault = (*fault ? 1 : !(tw ? terms : NULL))) : 0)
 
-    gsl_sum_levin_utrunc_accel (terms, number_of_terms, tw, &sum, &error);
 
-  if (w)
 
-    gsl_sum_levin_u_free (w);
 
-  if (tw)
 
-    gsl_sum_levin_utrunc_free (tw);
 
-  if (terms)
 
-    free (terms);
 
-  sum_list = (*fault ? NULL : avm_list_of_value((void *) &sum, sizeof(double),fault));
 
-  error_list = (*fault ? NULL : avm_list_of_value((void *) &error, sizeof(double), fault));
 
-  if (*fault = (*fault ? 1 : !!result))
 
-    {
 
-      if (sum_list)
 
-	avm_dispose(sum_list);
 
-      if (error_list)
 
-	avm_dispose(error_list);
 
-    }
 
-  else
 
-    *fault = !(result = avm_recoverable_join(sum_list,error_list));
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-#endif
 
-
 
-
 
-
 
-list
 
-avm_have_gslevu_call (list function_name, int *fault)
 
-
 
-/* this reports the availability of a function */
 
-
 
-{
 
-#if HAVE_GSL
 
-  list membership;
 
-  list comparison;
 
-  list result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_gslevu ();
 
-  if (*fault)
 
-    return NULL;
 
-  comparison = avm_binary_comparison (function_name, wild, fault);
 
-  if (*fault)
 
-    return comparison;
 
-  if (comparison)
 
-    {
 
-      avm_dispose(comparison);
 
-      return avm_copied(funs);
 
-    }
 
-  if (!(membership = avm_binary_membership (function_name, funs, fault)) ? 1 : *fault)
 
-    return membership;
 
-  avm_dispose(membership);
 
-  return ((*fault = !(result = avm_recoverable_join(avm_copied(function_name),NULL))) ? avm_copied(memory_overflow) : result);
 
-#endif
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_gslevu_call (function_name, argument, fault)
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-
 
-     /* This figures out what function to call and calls it. */
 
-{
 
-#if HAVE_GSL
 
-  list message;
 
-  int function_number;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (! initialized)
 
-    avm_initialize_gsldif ();
 
-  if (!(function_number = 0xff & (function_name ? function_name->characterization : 0)))
 
-    {
 
-      message = avm_position (function_name, funs, fault);
 
-      if (*fault)
 
-	return message;
 
-      if (*fault = !message)
 
-	return avm_copied (unrecognized_function_name);
 
-      function_number = message->characterization;
 
-      function_name->characterization = function_number;
 
-      avm_dispose (message);
 
-    }
 
-  switch (function_number)
 
-    {
 
-    case 1: return levinu (0, argument, fault);
 
-    case 2: return levinu (1, argument, fault);
 
-    }
 
-#endif /* HAVE_GSL */
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_gslevu ()
 
-
 
-     /* This initializes some static data structures. */
 
-
 
-{
 
-  char *funames[] = {
 
-    "accel",
 
-    "utrunc",
 
-    NULL};            /* add more function names here up to a total of 255 */
 
-  list back;
 
-#if HAVE_GSL
 
-  gsl_error_handler_t *old_handler;
 
-#endif
 
-  int string_number;
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_apply ();
 
-  avm_initialize_listfuns ();
 
-  avm_initialize_matcon ();
 
-  avm_initialize_chrcodes ();
 
-#if HAVE_GSL
 
-  old_handler = gsl_set_error_handler_off();
 
-#endif
 
-  wild = avm_strung("*");
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  empty_sequence = avm_join (avm_strung ("empty gslevu sequence"), NULL);
 
-  unrecognized_function_name = avm_join (avm_strung ("unrecognized gslevu function name"), NULL);
 
-  string_number = 0;
 
-  funs = back = NULL;
 
-  while (funames[string_number])
 
-    avm_enqueue (&funs, &back, avm_standard_strung (funames[string_number++]));
 
-}
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_gslevu ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-
 
-  if (!initialized)
 
-    {
 
-      return;
 
-    }
 
-  initialized = 0;
 
-  avm_dispose (funs);
 
-  avm_dispose (wild);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (empty_sequence);
 
-  avm_dispose (unrecognized_function_name);
 
-  funs = NULL;
 
-  wild = NULL;
 
-  memory_overflow = NULL;
 
-  empty_sequence = NULL;
 
-  unrecognized_function_name = NULL;
 
-}

+ 0 - 523
src/gslintlib.c
View File 

@@ -1,523 +0,0 @@
 
-
 
-/* this file incorporates numerical integration routines from gsl
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.  
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/compare.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/gslintlib.h>
 
-#include <avm/apply.h>
 
-#define __USE_ISOC99 1
 
-#include <math.h>
 
-#if HAVE_SETJMP
 
-#include <setjmp.h>
 
-#else
 
-typdef int jmp_buf;
 
-#endif
 
-#if HAVE_GSL
 
-#include <gsl/gsl_integration.h>
 
-#include <gsl/gsl_math.h>
 
-#include <gsl/gsl_errno.h>
 
-
 
-
 
-struct fspec {
 
-  double error;
 
-  counter neval;
 
-  jmp_buf caller;
 
-  list operator;
 
-  list message;
 
-  int fault;
 
-};
 
-
 
-typedef struct fspec *fsptr;
 
-
 
-#endif
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list bad_int_spec = NULL;
 
-static list memory_overflow = NULL;
 
-static list slow_convergence = NULL;
 
-static list integration_error = NULL;
 
-static list unrecognized_function_name = NULL;
 
-
 
-/* function names as lists of lists of character representations */
 
-static list wild = NULL;
 
-static list funs = NULL;
 
-
 
-#if HAVE_GSL
 
-#if HAVE_SETJMP
 
-
 
-#endif
 
-
 
-/* the tightest tolerance worth trying */
 
-#define MINIMUM_TOLERANCE 2E-14
 
-
 
-/* the number of retries at bigger tolerances before giving up due to slow convergence */
 
-#define RETRY_LIMIT 20
 
-
 
-/* the factor by which the tolerance is increased on each attempt */
 
-#define MAGNIFIER 3.16227766016838
 
-
 
-/* the number of intervals stored in a work space used by gsl */
 
-#define WORK_SIZE 1000
 
-
 
-/* the maximum number of function evaluations allowed for integration before giving up due to slow convergence */
 
-#define MAXIMUM_EVALUATIONS 3600
 
-
 
-/* non-convergence codes returned by gsl */
 
-#define ERRORS ((code == GSL_EBADTOL) ? 1 : ((code == GSL_ETOL) ? 1 : (code == GSL_EROUND)))
 
-
 
-/* used by integration routines */
 
-static gsl_integration_workspace* work = NULL;
 
-
 
-
 
-
 
-
 
-double
 
-integrand (x,params)
 
-     double x;
 
-     void* params;
 
-
 
-     /* the c function passed to gsl for integration */
 
-{
 
-  list result;
 
-  double *y;
 
-  fsptr spec;
 
-
 
-  spec = (fsptr) params;
 
-  if (spec->fault = (spec->fault ? 1 : !!(spec->message)))
 
-    return 0.0;
 
-  if ((spec->neval)++ > MAXIMUM_EVALUATIONS)
 
-    {
 
-#if HAVE_SETJMP
 
-      longjmp(spec->caller,-1);   /* no other way to recover from non-convergence unless this has been fixed lately */
 
-#else
 
-      avm_error("stuck on a non-converging integral; try qagx_tol");  /* better this than non-termination */
 
-#endif
 
-    }
 
-  result = avm_list_of_value ((void *) &x, sizeof(double), &(spec->fault));
 
-  if (spec->fault)
 
-    {
 
-      spec->message = result;
 
-      return 0.0;
 
-    }
 
-  result = avm_recoverable_apply(avm_copied(spec->operator), result, &(spec->fault));
 
-  if (spec->fault)
 
-    {
 
-      spec->message = result;
 
-      return 0.0;
 
-    }
 
-  y = (double *) avm_value_of_list (result, &(spec->message), &(spec->fault));
 
-  if (spec->fault)
 
-    {
 
-      avm_dispose (result);
 
-      return 0.0;
 
-    }
 
-  x = *y;
 
-  avm_dispose (result);
 
-  return x;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-one_piece_integral (adaptive, lower_limit, upper_limit, eps, retry_limit, operator, fault)
 
-     int adaptive;
 
-     double lower_limit;
 
-     double upper_limit;
 
-     double eps;
 
-     int retry_limit;
 
-     list operator;
 
-     int *fault;
 
-
 
-     /* calls a gsl integration function for the given parameters */
 
-{
 
-  double output;
 
-  gsl_function F;
 
-  int code;
 
-  int tries;
 
-  list result;
 
-  double error;
 
-  int started;
 
-  size_t sneval;
 
-  struct fspec spec;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  tries = 0;
 
-  spec.fault = 0;
 
-  spec.message = NULL;
 
-  spec.operator = operator;
 
-  F.params = &spec;
 
-  F.function = &integrand;
 
-#if HAVE_SETJMP
 
-  if (setjmp(spec.caller) != 0)
 
-    eps = eps * MAGNIFIER;
 
-#endif
 
-  started = spec.fault;
 
-  while (started ? (spec.fault ? 0 : ((++tries <= retry_limit) ? ERRORS : 0)) : (started = 1))
 
-    {
 
-      spec.neval = 0;
 
-      if (!adaptive)
 
-	code = gsl_integration_qng (&F, lower_limit, upper_limit, 0.0, eps, &output, &error, &sneval);
 
-      else if ((lower_limit < 0.0)  ? (fpclassify(lower_limit) ==  FP_INFINITE) : 0)
 
-	{
 
-	  if ((upper_limit > 0.0) ? (fpclassify(upper_limit) == FP_INFINITE) : 0)
 
-	    code = gsl_integration_qagi (&F, 0.0, eps, WORK_SIZE, work, &output, &error);
 
-	  else
 
-	    code = gsl_integration_qagil (&F, upper_limit, 0.0, eps, WORK_SIZE, work, &output, &error);
 
-	}
 
-      else if ((upper_limit > 0.0) ? (fpclassify(upper_limit) == FP_INFINITE) : 0)
 
-	code = gsl_integration_qagiu (&F, lower_limit, 0.0, eps, WORK_SIZE, work, &output, &error);
 
-      else
 
-	code = gsl_integration_qags (&F, lower_limit, upper_limit, 0.0, eps, WORK_SIZE, work, &output, &error);
 
-      eps = MAGNIFIER * eps;
 
-    }
 
-  if (!(code ? 1 : (spec.fault ? 1 : ((tries > retry_limit + 1) ? 1 : !!(spec.message)))))
 
-    return avm_list_of_value((void *) &output,sizeof(double),fault);
 
-  if (*fault = !!spec.message)
 
-    return spec.message;
 
-  if (code != 0)
 
-    {
 
-      spec.message = avm_recoverable_strung((char *) gsl_strerror(code), fault);
 
-      spec.message = (*fault ? spec.message : (spec.message ? avm_recoverable_join(spec.message,NULL) : NULL));
 
-      *fault = 1;
 
-      return (spec.message ? spec.message : avm_copied(integration_error));
 
-    }
 
-  *fault = 1;
 
-  return avm_copied (slow_convergence);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-piecewise_integral (pts, npts, eps, retry_limit, operator, fault)
 
-     double *pts;
 
-     size_t npts;
 
-     double eps;
 
-     int retry_limit;
 
-     list operator;
 
-     int *fault;
 
-
 
-     /* calls a gsl_integration_qagp for the given parameters */
 
-{
 
-  double output;
 
-  gsl_function F;
 
-  int code;
 
-  int tries;
 
-  list result;
 
-  double error;
 
-  int started;
 
-  struct fspec spec;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  tries = 0;
 
-  spec.fault = 0;
 
-  spec.message = NULL;
 
-  spec.operator = operator;
 
-  F.params = &spec;
 
-  F.function = &integrand;
 
-#if HAVE_SETJMP
 
-  if (setjmp(spec.caller) != 0)
 
-    eps = eps * MAGNIFIER;
 
-#endif
 
-  started = spec.fault;
 
-  while (started ? (spec.fault ? 0 : ((++tries <= retry_limit) ? ERRORS : 0)) : (started = 1))
 
-    {
 
-      spec.neval = 0;
 
-      code = gsl_integration_qagp (&F, pts, npts, 0.0, eps, WORK_SIZE, work, &output, &error);
 
-      eps = MAGNIFIER * eps;
 
-    }
 
-  if (!(code ? 1 : (spec.fault ? 1 : ((tries > retry_limit + 1) ? 1 : !!(spec.message)))))
 
-    return avm_list_of_value((void *) &output,sizeof(double),fault);
 
-  if (*fault = !!spec.message)
 
-    return spec.message;
 
-  if (code != 0)
 
-    {
 
-      spec.message = avm_recoverable_strung((char *) gsl_strerror(code), fault);
 
-      spec.message = (*fault ? spec.message : (spec.message ? avm_recoverable_join(spec.message,NULL) : NULL));
 
-      *fault = 1;
 
-      return (spec.message ? spec.message : avm_copied(integration_error));
 
-    }
 
-  *fault = 1;
 
-  return avm_copied (slow_convergence);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-integral (piecewise, adaptive, fixed_tolerance, operand, fault)
 
-     int piecewise;
 
-     int adaptive;
 
-     int fixed_tolerance;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* operand is either (f,a,b), ((f,t),a,b), (f,p), or ((f,t),p),
 
-	with function f, tolerance t, lower limit a, upper limit b and
 
-	list of endpoints p */
 
-{
 
-  double *lower_limit;
 
-  double *upper_limit;
 
-  double *pts;
 
-  size_t npts;
 
-  double *eps;
 
-  list f,t,a,b,p;
 
-  list result;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  npts = 0;
 
-  pts = NULL;
 
-  t = result = NULL;
 
-  *fault = !(operand ? ((f = operand->head) ? (p = operand->tail) : NULL) : NULL);
 
-  if (*fault = (*fault ? 1 : !(fixed_tolerance ? ((f = operand->head->head) ? !!(t = operand->head->tail) : 0) : 1)))
 
-    return avm_copied (bad_int_spec);
 
-  if (*fault = !((a = p->head) ? (b = p->tail) : 0))
 
-    return avm_copied (bad_int_spec);
 
-  if (piecewise ? !(piecewise = !!(p->tail->tail)) : 0)
 
-    {
 
-      b = p->tail->head;
 
-      adaptive = 1;
 
-    }
 
-  eps = (fixed_tolerance ? (double *) avm_value_of_list (t, &result, fault) : NULL);
 
-  if (piecewise)
 
-    {
 
-      npts = (size_t) avm_length (p);
 
-      pts = (*fault ? NULL : (double *) avm_vector_of_list (p, sizeof(double), &result, fault));
 
-    }
 
-  else
 
-    {
 
-      lower_limit = (*fault ? NULL : (double *) avm_value_of_list (a, &result, fault));
 
-      upper_limit = (*fault ? NULL : (double *) avm_value_of_list (b, &result, fault));
 
-    }
 
-  if (*fault = (*fault ? 1 : !!result))
 
-    return (result ? result : avm_copied (bad_int_spec));
 
-  if (!piecewise)
 
-    {
 
-      if (fixed_tolerance)
 
-	return one_piece_integral (adaptive, *lower_limit, *upper_limit, *eps, 0, f, fault);
 
-      return one_piece_integral (adaptive, *lower_limit, *upper_limit, MINIMUM_TOLERANCE, RETRY_LIMIT, f, fault);
 
-    }
 
-  if (fixed_tolerance)
 
-    result = piecewise_integral (pts, npts, *eps, 0, f, fault);
 
-  else
 
-    result = piecewise_integral (pts, npts, MINIMUM_TOLERANCE, RETRY_LIMIT, f, fault);
 
-  if (pts)
 
-    free (pts);
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-#endif
 
-
 
-
 
-
 
-
 
-list
 
-avm_have_gslint_call (list function_name, int *fault)
 
-
 
-/* this reports the availability of a function */
 
-
 
-{
 
-#if HAVE_GSL
 
-  list membership;
 
-  list comparison;
 
-  list result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_gslint ();
 
-  if (*fault)
 
-    return NULL;
 
-  comparison = avm_binary_comparison (function_name, wild, fault);
 
-  if (*fault)
 
-    return comparison;
 
-  if (comparison)
 
-    {
 
-      avm_dispose(comparison);
 
-      return avm_copied(funs);
 
-    }
 
-  if (!(membership = avm_binary_membership (function_name, funs, fault)) ? 1 : *fault)
 
-    return membership;
 
-  avm_dispose(membership);
 
-  return ((*fault = !(result = avm_recoverable_join(avm_copied(function_name),NULL))) ? avm_copied(memory_overflow) : result);
 
-#endif
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_gslint_call (function_name, argument, fault)
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-{
 
-#if HAVE_GSL
 
-  list message;
 
-  int function_number;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (! initialized)
 
-    avm_initialize_gslint ();
 
-  if (!(function_number = 0xff & (function_name ? function_name->characterization : 0)))
 
-    {
 
-      message = avm_position (function_name, funs, fault);
 
-      if (*fault)
 
-	return message;
 
-      if (*fault = !message)
 
-	return avm_copied (unrecognized_function_name);
 
-      function_number = message->characterization;
 
-      function_name->characterization = function_number;
 
-      avm_dispose (message);
 
-    }
 
-  switch (function_number)
 
-    {
 
-    case 1: return integral (0, 0, 0, argument, fault);
 
-    case 2: return integral (0, 0, 1, argument, fault);
 
-    case 3: return integral (0, 1, 0, argument, fault);
 
-    case 4: return integral (0, 1, 1, argument, fault);
 
-    case 5: return integral (1, 1, 0, argument, fault);
 
-    case 6: return integral (1, 1, 1, argument, fault);
 
-    }
 
-#endif /* HAVE_GSL */
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_gslint ()
 
-
 
-     /* This initializes some static data structures. */
 
-
 
-{
 
-  char *funames[] = {
 
-    "qng",
 
-    "qng_tol",
 
-    "qagx",
 
-    "qagx_tol",
 
-    "qagp",
 
-    "qagp_tol",
 
-    NULL};            /* add more function names here up to a total of 255 */
 
-  list back;
 
-#if HAVE_GSL
 
-  gsl_error_handler_t *old_handler;
 
-#endif
 
-  int string_number;
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_apply ();
 
-  avm_initialize_listfuns ();
 
-  avm_initialize_chrcodes ();
 
-  wild = avm_strung ("*");
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  slow_convergence = avm_join (avm_strung ("slow convergence"), NULL);
 
-  integration_error = avm_join (avm_strung ("integration error"), NULL);
 
-  bad_int_spec = avm_join (avm_strung ("bad integral specfication"), NULL);
 
-  unrecognized_function_name = avm_join (avm_strung ("unrecognized gslint function name"), NULL);
 
-  string_number = 0;
 
-  funs = back = NULL;
 
-  while (funames[string_number])
 
-    avm_enqueue (&funs, &back, avm_standard_strung (funames[string_number++]));
 
-#if HAVE_GSL
 
-  old_handler = gsl_set_error_handler_off();
 
-  if (!(work = gsl_integration_workspace_alloc(WORK_SIZE)))
 
-    avm_error ("can't initialize gsl integration workspace");
 
-#endif
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_gslint ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (funs);
 
-  avm_dispose (wild);
 
-  avm_dispose (bad_int_spec);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (slow_convergence);
 
-  avm_dispose (integration_error);
 
-  avm_dispose (unrecognized_function_name);
 
-#if HAVE_GSL
 
-  gsl_integration_workspace_free (work);
 
-#endif
 
-  funs = NULL;
 
-  wild = NULL;
 
-  bad_int_spec = NULL;
 
-  memory_overflow = NULL;
 
-  slow_convergence = NULL;
 
-  unrecognized_function_name = NULL;
 
-}

+ 0 - 344
src/harminv.c
View File 

@@ -1,344 +0,0 @@
 
-
 
-/* this file interfaces to the harminv harmonic inversion library
 
-
 
-   Copyright (C) 2008 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
 
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/compare.h>
 
-#include <avm/harminv.h>
 
-#include <avm/matcon.h>
 
-#include <avm/mwrap.h>
 
-#include <avm/chrcodes.h>
 
-#include <math.h>
 
-#include <string.h>
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list bad_harminv = NULL;
 
-static list memory_overflow = NULL;
 
-static list counter_overflow = NULL;
 
-static list unrecognized_function_name = NULL;
 
-
 
-/* function names as lists of lists of character representations */
 
-static list funs = NULL;
 
-
 
-static list shared_cell = NULL;
 
-static list wild = NULL;
 
-
 
-#if HAVE_COMPLEX
 
-#if HAVE_HARMINV
 
-#include <complex.h>
 
-#include <harminv.h>
 
-
 
-/*typedef void *harminv_data;*/
 
-
 
-extern void harminv_solve(harminv_data d);
 
-extern int harminv_get_num_freqs(harminv_data d);
 
-extern void harminv_data_destroy(harminv_data d);
 
-extern double harminv_get_Q(harminv_data d, int k);
 
-extern double harminv_get_freq(harminv_data d, int k);
 
-extern double harminv_get_decay(harminv_data d, int k);
 
-extern complex harminv_get_omega(harminv_data d, int k);
 
-extern complex harminv_get_amplitude(harminv_data d, int k);
 
-extern double harminv_get_freq_error(harminv_data d, int k);
 
-extern harminv_data harminv_data_create(int n, const complex *signal,double fmin, double fmax, int nf);
 
-
 
-
 
-
 
-static list
 
-extraction (d, fault)
 
-     harminv_data d;
 
-     int *fault;
 
-
 
-     /* This takes an already solved harminv_data structure to a list
 
-	of quintuples (type %jeeeeXXXXL in Ursala notation) of
 
-	(amplitude,frequency,decay,quality,error). */
 
-{
 
-  list result,message;
 
-  complex h;
 
-  double e;
 
-  int k;
 
-
 
-  result = NULL;
 
-  if (*fault)
 
-    return NULL;
 
-  k = harminv_get_num_freqs (d);
 
-  while (*fault ? 0 : k)
 
-    {
 
-      k--;
 
-      e = harminv_get_freq_error (d, k);
 
-      message = avm_list_of_value ((void *) &e, sizeof(double), fault);
 
-      e = harminv_get_Q (d, k);
 
-      message = (*fault ? message : avm_recoverable_join (avm_list_of_value ((void *) &e, sizeof(double), fault), message));
 
-      *fault = (*fault ? *fault : !(message));
 
-      e = harminv_get_decay (d, k);
 
-      message = (*fault ? message : avm_recoverable_join (avm_list_of_value ((void *) &e, sizeof(double), fault), message));
 
-      *fault = (*fault ? *fault : !(message));
 
-      e = harminv_get_freq (d, k);
 
-      message = (*fault ? message : avm_recoverable_join (avm_list_of_value ((void *) &e, sizeof(double), fault), message));
 
-      *fault = (*fault ? *fault : !(message));
 
-      h = harminv_get_amplitude (d, k);
 
-      message = (*fault ? message : avm_recoverable_join (avm_list_of_value ((void *) &h, sizeof(complex), fault), message));
 
-      *fault = (*fault ? *fault : !(message));
 
-      result = (*fault ? result : avm_recoverable_join (message, result));
 
-      *fault = (*fault ? *fault : !(result));
 
-    }
 
-  if (!*fault)
 
-    return result;
 
-  avm_dispose (result);
 
-  return (message ? message : avm_copied (memory_overflow));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-solution (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* The operand should represent a tuple of the form
 
-        (signal,(fmin,fmax),nf) where signal is a list of complex
 
-        numbers, fmin and fmax are real numbers defining the band
 
-        limits, and nf is the natural number of spectral basis
 
-        functions. See README.gz from the harminv distribution for an
 
-        explanaiton. If nf is zero, a default value of min(300,(fmax -
 
-        fmin) * 1.1 * length(signal)) is used. The output is a list
 
-        of quintuples (type %jeeeeXXXXL in Ursala notation) of
 
-        (amplitude,frequency,decay,quality,error). */
 
-{
 
-  complex *signal;
 
-  double *fmin;
 
-  double *fmax;
 
-  list message;
 
-  int n, nf, N, k;
 
-  harminv_data d;
 
-  complex h;
 
-  double e;
 
-
 
-  message = NULL;
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !(operand ? (operand->head ? (operand->tail ? operand->tail->head : NULL) : NULL) : NULL))
 
-    return avm_copied (bad_harminv);
 
-  if (*fault = !(n = (int) avm_recoverable_length (operand->head)))
 
-    return avm_copied (counter_overflow);
 
-  signal = (complex *) avm_vector_of_list (operand->head, sizeof(complex), &message, fault);
 
-  fmin = (*fault ? NULL : (double *) avm_value_of_list (operand->tail->head->head, &message, fault));
 
-  fmax = (*fault ? NULL : (double *) avm_value_of_list (operand->tail->head->tail, &message, fault));
 
-  if (*fault)
 
-    return (message);
 
-  if (*fault = !(*fmin < *fmax))
 
-    {
 
-      free (signal);
 
-      return avm_copied (bad_harminv);
 
-    }
 
-  if (!(nf = (int) avm_counter (operand->tail->tail)))
 
-    {
 
-      if (*fault = !!(operand->tail->tail))
 
-	{
 
-	  free (signal);
 
-	  return avm_copied (counter_overflow);
 
-	}
 
-      nf = (11 * n) / 10;
 
-      nf = (nf > 300 ? 300 : nf);
 
-    }
 
-  if (avm_setjmp () != 0)
 
-    {
 
-      avm_clearjmp ();
 
-      free (signal);
 
-      *fault = 1;
 
-      return avm_copied (memory_overflow);
 
-    }
 
-  avm_manage_memory ();
 
-  harminv_solve (d = harminv_data_create (n, signal, *fmin, *fmax, nf));
 
-  h = harminv_get_amplitude (d, 0);
 
-  e = harminv_get_freq_error (d, 0);         /* force remaining memory allocations before stopping management */
 
-  avm_dont_manage_memory ();
 
-  message = extraction (d, fault);
 
-  avm_manage_memory ();
 
-  harminv_data_destroy (d);
 
-  avm_clearjmp ();
 
-  avm_free_managed_memory ();
 
-  free (signal);
 
-  return message;
 
-}
 
-
 
-
 
-
 
-
 
-#endif /* HAVE_HARMINV */
 
-#endif /*HAVE_COMPLEX */
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_have_harminv_call (function_name, fault)
 
-  list function_name;
 
-  int *fault;
 
-
 
-/* this reports the availability of a function */
 
-
 
-{
 
-#if HAVE_HARMINV
 
-#if HAVE_COMPLEX
 
-  list membership;
 
-  list comparison;
 
-  list result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_harminv ();
 
-  if (*fault)
 
-    return NULL;
 
-  comparison = avm_binary_comparison (function_name, wild, fault);
 
-  if (*fault)
 
-    return comparison;
 
-  if (comparison)
 
-    {
 
-      avm_dispose(comparison);
 
-      return avm_copied(funs);
 
-    }
 
-  if (!(membership = avm_binary_membership (function_name, funs, fault)) ? 1 : *fault)
 
-    return membership;
 
-  avm_dispose(membership);
 
-  return ((*fault = !(result = avm_recoverable_join(avm_copied(function_name),NULL))) ? avm_copied(memory_overflow) : result);
 
-#endif
 
-#endif
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_harminv_call (function_name, argument, fault)
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-
 
-     /* This figures out what function to call and calls it. */
 
-{
 
-#if HAVE_HARMINV
 
-#if HAVE_COMPLEX
 
-  list message;
 
-  int function_number;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (! initialized)
 
-    avm_initialize_harminv ();
 
-  if (!(function_number = 0xff & (function_name ? function_name->characterization : 0)))
 
-    {
 
-      message = avm_position (function_name, funs, fault);
 
-      if (*fault = (*fault ? 1 : !message))
 
-	return (message ? message : avm_copied (unrecognized_function_name));
 
-      function_number = message->characterization;
 
-      function_name->characterization = function_number;
 
-      avm_dispose (message);
 
-    }
 
-  switch (function_number)
 
-    {
 
-      case 1: return solution (argument, fault);
 
-    }
 
-#endif /* HAVE_COMPLEX */
 
-#endif /* HAVE_HARMINV */
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_harminv ()
 
-
 
-     /* This initializes some static data structures. */
 
-{
 
-  char *funames[] = {"hsolve",NULL};
 
-  list back;
 
-  int string_number;
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_listfuns ();
 
-  avm_initialize_matcon ();
 
-  avm_initialize_chrcodes ();
 
-  shared_cell = avm_join (NULL, NULL);
 
-  wild = avm_strung("*");
 
-  bad_harminv = avm_join (avm_strung ("bad harminv function call"), NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  counter_overflow = avm_join (avm_strung ("counter overflow"), NULL);
 
-  unrecognized_function_name = avm_join (avm_strung ("unrecognized harminv function name"), NULL);
 
-  string_number = 0;
 
-  funs = back = NULL;
 
-  while (funames[string_number])
 
-    avm_enqueue (&funs, &back, avm_standard_strung (funames[string_number++]));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_harminv ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (funs);
 
-  avm_dispose (wild);
 
-  avm_dispose (bad_harminv);
 
-  avm_dispose (shared_cell);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (counter_overflow);
 
-  avm_dispose (unrecognized_function_name);
 
-  funs = NULL;
 
-  bad_harminv = NULL;
 
-  shared_cell = NULL;
 
-  memory_overflow = NULL;
 
-  unrecognized_function_name = NULL;
 
-}

+ 0 - 182
src/instruct.c
View File 

@@ -1,182 +0,0 @@
 
-/* memory management and stack operations on instruction nodes
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-
 
-*/
 
-
 
-#include <avm/error.h>
 
-#include <avm/ports.h>
 
-#include <avm/portals.h>
 
-#include <avm/instruct.h>
 
-
 
-/* non-zero implies that static variables have been initialized */
 
-static int initialized = 0;
 
-
 
-/* a local cache of instruction nodes stored for fast reuse */
 
-static instruction available_instruction = NULL;
 
-
 
-/* the number of instruction nodes in the cache */
 
-static int available_instructions = 0;
 
-
 
-/* the total number of allocated instruction nodes excluding the cache */
 
-static counter extant_instructions = 0;
 
-
 
-/* the maximum number of instruction nodes allowed in the cache */
 
-#define instruction_cache_size 0xff
 
-
 
-
 
-
 
-void
 
-avm_retire (done)
 
-     instruction *done;
 
-
 
-     /* This pops an instruction node off a stack threaded through the
 
-        dependents field. The instruction referenced by the argument
 
-        will be reassigned to the dependents field of the instruction
 
-        node that was popped. The node will be either freed or stored
 
-        in a cache for later reuse. It is an internal error if the
 
-        instruction is NULL. */
 
-
 
-{
 
-  instruction old;
 
-
 
-  extant_instructions--;
 
-  if ((!done) ? 1 : !*done)
 
-      avm_internal_error (25);
 
-  *done = (old = *done)->dependents;
 
-  avm_dispose (old->datum.contents);
 
-  avm_dispose (old->actor.contents);
 
-  if (old->actor.impetus)
 
-    {
 
-      old->actor.impetus->facilitator = NULL;
 
-      old->actor.impetus = NULL;
 
-    }
 
-  if (available_instructions > instruction_cache_size)
 
-    free (old);
 
-  else
 
-    {
 
-      old->dependents = available_instruction;
 
-      available_instruction = old;
 
-      available_instructions++;
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-int
 
-avm_scheduled (actor_contents, datum_errors, datum_contents, client, next, sheet, remote, balanceable, granularity)
 
-     list actor_contents;
 
-     counter datum_errors;
 
-     list datum_contents;
 
-     port client;
 
-     instruction *next;
 
-     score sheet;
 
-     flag remote;
 
-     flag balanceable;
 
-     counter granularity;
 
-
 
-     /* This attempts to create storage for a new instruction node or
 
-        grabs one out of the cache, and initializes the fields with
 
-        the given parameters. Other fields are filled with zeros. If
 
-        allocation fails, a NULL pointer is returned. */
 
-{
 
-  instruction result;
 
-
 
-  if (result = available_instruction)
 
-    {
 
-      available_instruction = available_instruction->dependents;
 
-      available_instructions--;
 
-    }
 
-  else
 
-    result = (instruction) (malloc (sizeof (*result)));
 
-  if (result)
 
-    {
 
-      extant_instructions++;
 
-      memset (result, 0, sizeof (*result));
 
-      result->actor.contents = avm_copied (actor_contents);
 
-      result->datum.errors = datum_errors;
 
-      result->datum.contents = avm_copied (datum_contents);
 
-      result->sheet = sheet;
 
-      result->remotely_executable = remote;
 
-      result->non_deterministic = balanceable;
 
-      result->granularity = granularity;
 
-      result->client = client;
 
-      result->dependents = *next;
 
-      *next = result;
 
-    }
 
-  return (!!result);
 
-}
 
-
 
-
 
-
 
-
 
-void
 
-avm_reschedule (next)
 
-     instruction *next;
 
-
 
-     /* This interchanges the positions of two instructions on top of
 
-        a stack of them, which must have at least two nodes in it or
 
-        it's an internal error. */
 
-
 
-{
 
-  instruction temporary;
 
-
 
-  if (!*next ? 1 : !((*next)->dependents))
 
-    avm_internal_error (26);
 
-  temporary = *next;
 
-  *next = temporary->dependents;
 
-  temporary->dependents = (*next)->dependents;
 
-  (*next)->dependents = temporary;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_instruct ()
 
-
 
-     /* This initializes some static variables. */
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_ports ();
 
-  avm_initialize_profile ();
 
-  avm_initialize_portals ();
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_instruct ()
 
-
 
-     /* This frees some static variables and detects and reports
 
-	memory leaks. */
 
-{
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  if (extant_instructions)
 
-    avm_reclamation_failure ("instructions", extant_instructions);
 
-}

+ 0 - 272
src/jobs.c
View File 

@@ -1,272 +0,0 @@
 
-
 
-/* pertaining to concrete representations of dependence relations
 
-   to regulate concurrent evaluation strategies
 
-
 
-   Copyright (C) 2010 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/lists.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/error.h>
 
-#include <avm/jobs.h>
 
-#include <avm/farms.h>
 
-
 
-/* the maximum number of cached available jobs */
 
-#define CACHE_SIZE 0xff
 
-
 
-/* Non-zero means static variables have been initialized. */
 
-static int initialized = 0;
 
-
 
-/* the number of allocated and not reclaimed structs */
 
-static counter extant_jobs = 0;
 
-
 
-/* used to recycle job nodes more quickly than malloc and free */
 
-static job available_job = NULL;
 
-
 
-/* the number of job nodes in the cache */
 
-static int available_jobs = 0;
 
-
 
-/* an error message */
 
-static list memory_overflow = NULL;
 
-
 
-
 
-
 
-void
 
-avm_free_job (front)
 
-     job *front;
 
-
 
-     /* this gets rid of a job and all the roots in it */
 
-{
 
-  job back,old;
 
-
 
-  back = *front;
 
-  while (*front)
 
-    {
 
-      while ((*front)->prerequisites ? 1 : back->corequisites ? 1 : 0)
 
-	if (back->corequisites)
 
-	  back = back->corequisites;
 
-	else if ((*front)->prerequisites)
 
-	  {
 
-	    back->corequisites = (*front)->prerequisites;
 
-	    (*front)->prerequisites = NULL;
 
-	  }
 
-      *front = (old = *front)->corequisites;
 
-      avm_dispose (old->root);
 
-      if (available_jobs >= CACHE_SIZE)
 
-	{
 
-	  extant_jobs--;
 
-	  free (old);
 
-	}
 
-      else
 
-	{
 
-	  available_jobs++;
 
-	  old->corequisites = available_job;
 
-	  available_job = old;
 
-	}
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_new_job(front, back, root, dependent, prerequisites, dependence, fault)
 
-     job *front;
 
-     job *back;
 
-     list root;
 
-     job dependent;
 
-     job prerequisites;
 
-     int dependence;
 
-     int *fault;
 
-
 
-     /* allocates a job, fills in the fields, and enqueues it if the back is non-null */
 
-{
 
-  job result,old;
 
-
 
-  if (*fault)
 
-    return;
 
-  if (available_job)
 
-    {
 
-      result = available_job;
 
-      available_job = available_job->corequisites;
 
-      available_jobs--;
 
-    }
 
-  else 
-    {
 
-      if (*fault = !(result = (job) malloc (sizeof (*result))))
 
-	{
 
-	  avm_dispose (root);
 
-	  avm_free_job (&prerequisites);
 
-	  avm_free_job (front);
 
-	  return;
 
-	}
 
-      extant_jobs++;
 
-    }
 
-  memset (result, 0, sizeof (*result));
 
-  result->root = root;
 
-  result->dependent = dependent;
 
-  result->prerequisites = prerequisites;
 
-  result->dependence = dependence;
 
-  while (prerequisites)
 
-    {
 
-      prerequisites->dependent = result;
 
-      prerequisites = prerequisites->corequisites;
 
-    }
 
-  if (!back)
 
-    *front = result;
 
-  else
 
-    *back = (*back ? ((*back)->corequisites = result) : (*front = result));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_queue_job (front, back, top, dependent)
 
-     job *front;
 
-     job *back;
 
-     job *top;
 
-     job dependent;
 
-
 
-     /* this enqueues an existing job into a queue of jobs,
 
-	and removes it from the queue it was in */
 
-{
 
-  job old;
 
-
 
-  *back = (*back ? ((*back)->corequisites = *top) : (*front = *top));
 
-  (*top)->dependent = dependent;
 
-  if (dependent)
 
-    (dependent->dependence)++;
 
-  *top = (old = *top)->corequisites;
 
-  old->corequisites = NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_evaluation (top, balanceable, fault)
 
-     job top;
 
-     flag balanceable;
 
-     int *fault;
 
-
 
-     /* This function plants the leaves of a job tree in a newly
 
-        created farm. Then it calls the harvest function and waits for
 
-        the result to propagate back to the root. 
-
 
-        The balanceable parameter, which is passed through to the
 
-        harvest function, allows for improved performance through out
 
-        of order evaluation assuming the caller warrants that
 
-        correctness is preserved. Currently this condition holds only
 
-        for reduction with a commutative operator and sorting. */
 
-{
 
-  job next;
 
-  list result;
 
-  farm maggie;
 
-
 
-  next = top;
 
-  maggie = NULL;
 
-  while (*fault ? NULL : next)
 
-    if (next->prerequisites)
 
-      next = next->prerequisites;
 
-    else
 
-      {
 
-	avm_plant (&maggie, next, fault);
 
-	while (next ? !(next->corequisites) : 0)
 
-	  next = next->dependent;
 
-	next = (next ? next->corequisites : NULL);
 
-      }
 
-  if (*fault)
 
-    {
 
-      avm_free_job (&top);
 
-      return avm_copied (memory_overflow);
 
-    }
 
-  avm_harvest (maggie, balanceable, fault);
 
-  result = (top ? avm_copied (top->root) : NULL);
 
-  avm_free_job (&top);
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_jobs ()
 
-
 
-     /* This initializes static data structures. */
 
-{
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_chrcodes ();
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_jobs ()
 
-
 
-{
 
-  server_list old,servers;
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (memory_overflow);
 
-  memory_overflow = NULL;
 
-  if (extant_jobs)
 
-    avm_reclamation_failure ("jobs", extant_jobs);
 
-}

+ 0 - 680
src/kinsol.c
View File 

@@ -1,680 +0,0 @@
 
-
 
-/* This file interfaces to some non-linear constrained optimization
 
-   functions from the kinsol library in the sundials-serial package.
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/compare.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/apply.h>
 
-#include <avm/matcon.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/kinsol.h>
 
-#include <avm/mwrap.h>
 
-#include <math.h>
 
-#if HAVE_KINSOL
 
-#include <sundials_types.h>
 
-#include <sundials_math.h>
 
-#include <sundials_nvector.h>
 
-// #include <sundials_smalldense.h>
 
-#include <kinsol.h>
 
-#include <kinsol_dense.h>
 
-#include <kinsol_spgmr.h>
 
-#include <kinsol_spbcgs.h>
 
-#include <kinsol_sptfqmr.h>
 
-#include <kinsol_spils.h>
 
-#include <nvector_serial.h>
 
-
 
-struct fspec {                  /* a pointer to one of these is passed to c functions evaluating the system and jacobian */
 
-  list operator;                /* a function whose roots relative to the origin are sought */
 
-  list jacobian;                /* returns a list of rows, one for each output, each row a list of partial derivatives */
 
-  list message;                 /* returned by either operator or jacobian when evaluation causes an exception */
 
-  int fault;                    /* non-zero in the event of an exception */
 
-  counter number_of_inputs;     /* the length of the list to be passed to the operator as an argument */
 
-  counter number_of_outputs;    /* the length of the list expected to be returned by the operator */
 
-  double *output_origin;        /* constant to be subtracted from the operator's result, therefore having the same length */
 
-  list *row_number;             /* constant array of length number_of_outputs whose ith element is the representation of i */
 
-};
 
-
 
-typedef struct fspec *fsptr;
 
-typedef int (*spilsolver)(void*,int);
 
-
 
-#endif
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list kinsol_error = NULL;
 
-static list memory_overflow = NULL;
 
-static list bad_kinsol_spec = NULL;
 
-static list unrecognized_function_name = NULL;
 
-
 
-/* function names as lists of lists of character representations */
 
-static list wild = NULL;
 
-static list funs = NULL;
 
-
 
-#if HAVE_KINSOL
 
-/* the sundials library has to be built for double precision or it won't be compatible with avram */
 
-#if defined SUNDIALS_DOUBLE_PRECISION
 
-
 
-/* the tightest tolerance worth trying */
 
-#define MINIMUM_NORM_TOLERANCE 1E-16
 
-#define MINIMUM_STEP_TOLERANCE 1E-16
 
-
 
-/* the number of retries at bigger tolerances before giving up due to slow convergence */
 
-#define TIME_LIMIT 15
 
-
 
-/* the factor by which the tolerance is increased on each attempt */
 
-#define MAGNIFIER 4.64158883361278
 
-
 
-#define freeif(x) if (x)			\
 
-    free (x)
 
-
 
-#ifndef MIN
 
-#define MIN(a,b) ((a) < (b) ? (a) : (b))
 
-#endif
 
-
 
-#ifndef MAX
 
-#define MAX(a,b) ((a) < (b) ? (b) : (a))
 
-#endif
 
-
 
-
 
-
 
-
 
-
 
-static int
 
-func (u, fval, f_data)
 
-     N_Vector u;
 
-     N_Vector fval;
 
-     void *f_data;
 
-
 
-     /* computes the system function whose roots are sought by
 
-	evaluating the virtual code in the given f_data structure */
 
-{
 
-  double *y;
 
-  int i,n;
 
-  list row,operand,result;
 
-  double *item;
 
-  fsptr spec;
 
-
 
-  spec = (fsptr) f_data;
 
-  if (spec->fault = (spec->fault ? 1 : !!(spec->message)))
 
-    return -1;
 
-  if (spec->fault = ((NV_LENGTH_S(u) < spec->number_of_inputs) ? 1 : (NV_LENGTH_S(fval) < spec->number_of_outputs)))
 
-    {
 
-      spec->message = avm_copied (kinsol_error);
 
-      return -1;
 
-    }
 
-  operand = avm_list_of_vector((void *) NV_DATA_S(u), spec->number_of_inputs, sizeof(double), &(spec->fault));
 
-  if (spec->fault)
 
-    {
 
-      spec->message = operand;
 
-      return -1;
 
-    }
 
-  row = result = avm_recoverable_apply (avm_copied (spec->operator), operand, &(spec->fault));
 
-  if (spec->fault)
 
-    {
 
-      spec->message = result;
 
-      return -1;
 
-    }
 
-  i = 0;
 
-  y = (double *) NV_DATA_S(fval);
 
-  while ((i < spec->number_of_outputs) ? !(spec->fault = (spec->fault ? 1 : !row)) : 0)
 
-    {
 
-      item = (double *) avm_value_of_list (row->head, &(spec->message), &(spec->fault));
 
-      y[i] = (spec->fault ? 0.0 : ((*item) - ((spec->output_origin)[i])));
 
-      row = row->tail;
 
-      i++;
 
-    }
 
-  avm_dispose (result);
 
-  if (spec->fault = (spec->fault ? 1 : (row ? 1 : !!(spec->message))))
 
-    {
 
-      spec->message = (spec->message ? spec->message : avm_copied (bad_kinsol_spec));
 
-      return -1;
 
-    }
 
-  while (i < NV_LENGTH_S(u))  /* kinsol requires equally many inputs and outputs so the extras are set to zero */
 
-    y[i++] = 0.0;
 
-  return 0;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static int
 
-djac (N, J, u, fu, jac_data, tmp1, tmp2)
 
-     long int N;
 
-     N_Vector u;
 
-     N_Vector fu;
 
-     DlsMat J;
 
-     void *jac_data;
 
-     N_Vector tmp1;
 
-     N_Vector tmp2;
 
-
 
-     /* This c function is passed to kinsol as the user specified
 
-	jacobian for the dense solution method.  It finds the answer
 
-	by evaluating the virtual code jacobian function given by
 
-	jac_data. */
 
-{
 
-  int i,j;
 
-  list row,col,operand,result;
 
-  double *item;
 
-  fsptr spec;
 
-
 
-  spec = (fsptr) jac_data;
 
-  if (spec->fault = (spec->fault ? 1 : !!(spec->message)))
 
-    return -1;
 
-  if (spec->fault = ((NV_LENGTH_S(u) < spec->number_of_inputs) ? 1 : (N < spec->number_of_outputs)))
 
-    {
 
-      spec->message = avm_copied (kinsol_error);
 
-      return -1;
 
-    }
 
-  operand = avm_list_of_vector ((void *) NV_DATA_S(u), spec->number_of_inputs, sizeof(double), &(spec->fault));
 
-  if (spec->fault)
 
-    {
 
-      spec->message = operand;
 
-      return -1;
 
-    }
 
-  row = result = avm_recoverable_apply (avm_copied (spec->jacobian), operand, &(spec->fault));
 
-  if (spec->fault)
 
-    {
 
-      spec->message = result;
 
-      return -1;
 
-    }
 
-  i = 0;
 
-  while ((i < spec->number_of_outputs) ? !(spec->fault = (spec->fault ? 1 : !row)) : 0)
 
-    {
 
-      j = 0;
 
-      col = row->head;
 
-      while ((j < spec->number_of_inputs) ? !(spec->fault = (spec->fault ? 1 : !col)) : 0)
 
-	{
 
-	  item = (double *) avm_value_of_list (col->head, &(spec->message), &(spec->fault));
 
-	  printf("%d %d %d %10.4e\n",spec->fault,i,j,*item);
 
-	  DENSE_ELEM(J,i,j) = (spec->fault ? 0.0 : *item);
 
-	  printf("2\n");
 
-	  col = col->tail;
 
-	  j++;
 
-	}
 
-      spec->fault = (spec->fault ? 1 : !!col);
 
-      row = row->tail;
 
-      i++;
 
-    }
 
-  avm_dispose (result);
 
-  if (spec->fault = (spec->fault ? 1 : !!row))
 
-    {
 
-      spec->message = (spec->message ? spec->message : avm_copied (bad_kinsol_spec));
 
-      return -1;
 
-    }
 
-  return 0;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static int
 
-jtimes (v, Jv, u, new_u, jac_data)
 
-     N_Vector v;
 
-     N_Vector Jv;
 
-     N_Vector u;
 
-     booleantype new_u;
 
-     void *jac_data;
 
-
 
-     /* This is the c function passed to kinsol as a user specified
 
-        jacobian for the indirect solution methods (i.e., those other
 
-        than dense). The virtual code jacobian function in jac_data is
 
-        assumed to take an argument (i,<x..>) and return only the ith
 
-        row of the jacobian at <x..> instead of the whole thing. This
 
-        function computes the jacobian by multiple invocations of the
 
-        virtual code and stores the matrix product of the jacobian
 
-        with v in the vector Jv, as required by kinsol. */
 
-{
 
-  int i,j;
 
-  list row,col,operand,argument,result;
 
-  double *item;
 
-  fsptr spec;
 
-
 
-  spec = (fsptr) jac_data;
 
-  if (spec->fault = (spec->fault ? 1 : !!(spec->message)))
 
-    return -1;
 
-  if (spec->fault = ((NV_LENGTH_S(u) < spec->number_of_inputs) ? 1 : (NV_LENGTH_S(Jv) < spec->number_of_outputs)))
 
-    {
 
-      spec->message = avm_copied (kinsol_error);
 
-      return -1;
 
-    }
 
-  operand = avm_list_of_vector ((void *) NV_DATA_S(u), spec->number_of_inputs, sizeof(double), &(spec->fault));
 
-  if (spec->fault)
 
-    {
 
-      spec->message = operand;
 
-      return -1;
 
-    }
 
-  i = 0;
 
-  while (spec->fault ? 0 : (i < spec->number_of_outputs))
 
-    {
 
-      if (spec->fault = !(argument = avm_recoverable_join (avm_copied (spec->row_number[i]), avm_copied (operand))))
 
-	spec->message = avm_copied (memory_overflow);
 
-      else
 
-	result = avm_recoverable_apply (avm_copied (spec->jacobian), argument, &(spec->fault));
 
-      if (spec->fault)
 
-	{
 
-	  spec->message = (spec->message ? spec->message : result);
 
-	  result = NULL;
 
-	}
 
-      j = 0;
 
-      col = result;
 
-      NV_Ith_S(Jv,i) = 0.0;
 
-      while ((j < spec->number_of_inputs) ? !(spec->fault = (spec->fault ? 1 : !col)) : 0)
 
-	{
 
-	  item = (double *) avm_value_of_list (col->head, &(spec->message), &(spec->fault));
 
-	  NV_Ith_S(Jv,i) = (spec->fault ? 0.0 : NV_Ith_S(Jv,i) + (*item * NV_Ith_S(v,j)));
 
-	  col = col->tail;
 
-	  j++;
 
-	}
 
-      spec->fault = (spec->fault ? 1 : !!col);
 
-      avm_dispose (result);
 
-      i++;
 
-    }
 
-  while (i < NV_LENGTH_S(Jv))  /* kinsol requires equally many inputs and outputs so the extras are set to zero */
 
-    {
 
-      NV_Ith_S(Jv,i) = 0.0;
 
-      i++;
 
-    }
 
-  avm_dispose (operand);
 
-  if (spec->fault)
 
-    {
 
-      spec->message = (spec->message ? spec->message : avm_copied (bad_kinsol_spec));
 
-      return -1;
 
-    }
 
-  return 0;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-solution (jacobian, constrained, spils_method, operand, fault)
 
-     int jacobian;
 
-     int constrained;
 
-     spilsolver spils_method;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* This is a simplified interface to the kinsol dense solver and
 
-	spils solvers, but not the band solver, with or without
 
-	constraints and with or without a user defined jacobian.
 
-
 
-        jacobian should be 0 if there's no user supplied jacobian, in
 
-        which case the default difference approximation will be used,
 
-        and non-zero otherwise.
 
-
 
-        constrained should be zero if there are no constraints, and
 
-        non-zero if all variables are constrained to be non-negative.
 
-        There are no other alternatives, but this form incurs no loss
 
-        of generality.
 
-
 
-        spils_method is one of &KINSpgmr &KINSpbcg or &KINSptfqmr to
 
-        specify the corresponding indirect solution method, or NULL if
 
-        the dense method is intended.
 
-
 
-        operand is a list of the form ((f,j),i,o) if jacobian is
 
-        non-zero, or (f,i,o) otherwise, where f and j are virtual
 
-        machine code functions and i and o are lists of reals. 
-
 
-        * f represents the function to be optimized, and takes a list
 
-          of reals the length of i to a list of reals the length of
 
-          o. 
-
 
-	* If spils_method is null, then j computes the jacobian of f
 
-          by taking a list of reals the length of i to a list the
 
-          length of o, in which each item of the latter is a list of
 
-          reals the length of i containing the partial derivatives of
 
-          a particular output with respect to each input. If
 
-          spils_method is not null, then j computes the kth row of the
 
-          jacobian from an argument of the form (k,<x..>) where k is
 
-          a natural number less than the length of o, and <x..> is a
 
-          list of reals the length of i.
 
-
 
-	* i is an initial guess for the optimum input of f
 
-
 
-	* o is an output of f for which an x near i is sought to
 
-	  satisfy f(x) - o = 0
 
-
 
-        fault is a pointer to an integer that's set to a non-zero
 
-        value in the event of an exception due to memory overflows,
 
-        invalid input parameters, bugs in kinsol, or a failure
 
-        evaluating f or j.
 
-
 
-        If there's an exception, the result returned is a list
 
-        representing an error message as a list of lists of character
 
-        encodings, or in whatever form f or j returns if one of them
 
-        causes the exception. Otherwise, the result returned is a list
 
-        of reals x the same length as i satisfying f(x) - o = 0 if one
 
-        is found, or the empty list otherwise. Lack of convergence
 
-        doesn't constitute an exceptional condition but could cause the
 
-        result to be empty.
 
-
 
-     */
 
-
 
-{
 
-  struct fspec spec;
 
-  counter number_of_inputs;
 
-  long int N;
 
-  void *kin_mem;
 
-  N_Vector u,c,s;
 
-  double *input;
 
-  list result;
 
-  double norm_tol;
 
-  double step_tol;
 
-  int try,flag,i,strategy;
 
-
 
-#define divergent(flag)				\
 
-  ((flag == KIN_LINESEARCH_NONCONV) ? 1 :	\
 
-   ((flag == KIN_MAXITER_REACHED) ? 1 :		\
 
-    ((flag == KIN_MXNEWT_5X_EXCEEDED) ? 1 :	\
 
-     ((flag == KIN_LSETUP_FAIL) ? 1 :	\
 
-      (flag == KIN_LINESEARCH_BCFAIL)))))
 
-
 
-  u = NULL;
 
-  c = NULL;
 
-  s = NULL;
 
-  kin_mem = NULL;
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = spec.fault = !(operand ? (operand->head ? operand->tail : NULL) : NULL))
 
-    return avm_copied (bad_kinsol_spec);
 
-  spec.message = spec.jacobian = NULL;
 
-  if (!jacobian)
 
-    spec.operator = operand->head;
 
-  else if (*fault = !((spec.operator = operand->head->head) ? (spec.jacobian = operand->head->tail) : NULL))
 
-    return avm_copied (bad_kinsol_spec);
 
-  spec.number_of_inputs = avm_length (operand->tail->head);
 
-  spec.number_of_outputs = avm_length (operand->tail->tail);
 
-  avm_turn_off_stderr ();                                      /* kinsol whinges too much so temporarily disable stderr */
 
-  N = MAX(spec.number_of_inputs, spec.number_of_outputs);
 
-  result = NULL;
 
-  input = (*fault ? NULL : (double *) avm_vector_of_list (operand->tail->head, sizeof(double), &result, fault));
 
-  spec.output_origin = (*fault ? NULL : (double *) avm_vector_of_list(operand->tail->tail, sizeof(double), &result, fault));
 
-  *fault = (*fault ? 1 : !(kin_mem = KINCreate ()));
 
-  u = (*fault ? NULL : N_VNew_Serial (N));
 
-  if (*fault ? 0 : !(*fault = !u))
 
-    {
 
-      memcpy ((void *) NV_DATA_S (u), (void *) input, sizeof(double) * spec.number_of_inputs);
 
-      for (i = spec.number_of_inputs; i < N; i++)
 
-	NV_Ith_S(u,i) = 0.0;
 
-    }
 
-  // *fault = (*fault ? 1 : (KINSetFdata (kin_mem, (void *) &spec) != KIN_SUCCESS));    /* old API */
 
-  spec.row_number = (*fault ? NULL : (spils_method ? avm_row_number_array (spec.number_of_outputs, fault) : NULL));
 
-  norm_tol = MINIMUM_NORM_TOLERANCE * ((jacobian ? spils_method : NULL) ? 1.0 : 10.0);
 
-  step_tol = MINIMUM_STEP_TOLERANCE * ((jacobian ? spils_method : NULL) ? 1.0 : 10.0);
 
-  *fault = (*fault ? 1 : (KINSetFuncNormTol (kin_mem, norm_tol) != KIN_SUCCESS));
 
-  *fault = (*fault ? 1 : (KINSetScaledStepTol (kin_mem, step_tol) != KIN_SUCCESS));
 
-  if (*fault ? 0 : (constrained ? !(*fault = !(c = N_VNew_Serial (N))) : 0))
 
-    {
 
-      N_VConst (2.0, c);
 
-      *fault = (KINSetConstraints (kin_mem, c) != KIN_SUCCESS);
 
-      N_VDestroy (c);
 
-    }
 
-  *fault = (*fault ? 1 : ((spils_method ? (*spils_method)(kin_mem, 0) : KINDense(kin_mem, N)) != KIN_SUCCESS));
 
-  if (*fault ? 0 : (jacobian ? spils_method : NULL))
 
-    *fault = (KINSpilsSetJacTimesVecFn(kin_mem, &jtimes) != KIN_SUCCESS);
 
-  else if (*fault ? 0 : jacobian)
 
-    *fault = (KINDlsSetDenseJacFn (kin_mem, &djac) != KIN_SUCCESS);
 
-  *fault = (*fault ? 1 : !(s = N_VNew_Serial (N)));
 
-  if (!*fault)
 
-    N_VConst (1.0, s);
 
-  strategy = KIN_NONE;
 
-  strategy = KIN_LINESEARCH;    /* tha alternative is KIN_NONE */
 
-  spec.fault = try = flag = 0;
 
-  *fault = (*fault ? 1 : (KINSetUserData(kin_mem, (void *) &spec) != KIN_SUCCESS));
 
-  *fault = (*fault ? 1 : (KINInit (kin_mem, &func, u) != KIN_SUCCESS));
 
-  while (*fault ? 0 : (((flag = KINSol(kin_mem, u, strategy, s, s)) < 0) ? (divergent(flag) ? (try++ < TIME_LIMIT) : 0) : 0))
 
-    {
 
-      *fault = (spec.fault ? 1 : !!(spec.message));
 
-      *fault = (*fault ? 1 : (KINSetFuncNormTol (kin_mem, norm_tol = (norm_tol * MAGNIFIER)) != KIN_SUCCESS));
 
-      *fault = (*fault ? 1 : (KINSetScaledStepTol (kin_mem, step_tol = (step_tol * MAGNIFIER)) != KIN_SUCCESS));
 
-      memcpy((void *) NV_DATA_S(u), (void *) input, sizeof(double) * spec.number_of_inputs);
 
-      for (i = spec.number_of_inputs; i < N; i++)
 
-	NV_Ith_S(u,i) = 0.0;
 
-    }
 
-  if (input)
 
-    free (input);
 
-  if (spec.output_origin)
 
-    free (spec.output_origin);
 
-  if (spec.row_number)
 
-    avm_dispose_rows (spec.number_of_outputs, spec.row_number);
 
-  if (s)
 
-    N_VDestroy (s);
 
-  if (kin_mem)
 
-    KINFree (&kin_mem);
 
-  if (!(*fault = (*fault ? 1 : (spec.fault ? 1 : (spec.message ? 1 : !!result)))))
 
-    {
 
-      if (*fault = ((flag < 0) ? !divergent(flag) : 0))
 
-	result = avm_copied (kinsol_error);
 
-      else if (flag >= 0)
 
-	result = avm_list_of_vector ((void *) NV_DATA_S(u), spec.number_of_inputs, sizeof(double), fault);
 
-    }
 
-  else if (result ? spec.message : NULL)
 
-    avm_dispose (spec.message);
 
-  else
 
-    result = (result ? result : spec.message);
 
-  if (u)
 
-    N_VDestroy (u);
 
-  avm_turn_on_stderr ();                                                                          /* restore stderr */
 
-  return (*fault ? (result ? result : avm_copied (memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-#endif
 
-#endif
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_have_kinsol_call (function_name, fault)
 
-     list function_name;
 
-     int *fault;
 
-
 
-     /* this reports the availability of a function */
 
-{
 
-#if HAVE_KINSOL
 
-#if defined SUNDIALS_DOUBLE_PRECISION
 
-  list membership;
 
-  list comparison;
 
-  list result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_kinsol ();
 
-  if (*fault)
 
-    return NULL;
 
-  comparison = avm_binary_comparison (function_name, wild, fault);
 
-  if (*fault)
 
-    return comparison;
 
-  if (comparison)
 
-    {
 
-      avm_dispose(comparison);
 
-      return avm_copied(funs);
 
-    }
 
-  if (!(membership = avm_binary_membership (function_name, funs, fault)) ? 1 : *fault)
 
-    return membership;
 
-  avm_dispose(membership);
 
-  return ((*fault = !(result = avm_recoverable_join(avm_copied(function_name),NULL))) ? avm_copied(memory_overflow) : result);
 
-#endif
 
-#endif
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_kinsol_call (function_name, argument, fault)
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-{
 
-#if HAVE_KINSOL
 
-#if defined SUNDIALS_DOUBLE_PRECISION
 
-  list message;
 
-  int function_number;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (! initialized)
 
-    avm_initialize_kinsol ();
 
-  if (!(function_number = 0xff & (function_name ? function_name->characterization : 0)))
 
-    {
 
-      message = avm_position (function_name, funs, fault);
 
-      if (*fault)
 
-	return message;
 
-      if (*fault = !message)
 
-	return avm_copied (unrecognized_function_name);
 
-      function_number = message->characterization;
 
-      function_name->characterization = function_number;
 
-      avm_dispose (message);
 
-    }
 
-  switch (function_number)
 
-    {
 
-    case 1: return solution (0, 0, NULL, argument, fault);
 
-    case 2: return solution (0, 1, NULL, argument, fault);
 
-    case 3: return solution (1, 0, NULL, argument, fault);
 
-    case 4: return solution (1, 1, NULL, argument, fault);
 
-    case 5: return solution (0, 0, &KINSpgmr, argument, fault);
 
-    case 6: return solution (0, 1, &KINSpgmr, argument, fault);
 
-    case 7: return solution (1, 0, &KINSpgmr, argument, fault);
 
-    case 8: return solution (1, 1, &KINSpgmr, argument, fault);
 
-    case 9: return solution (0, 0, &KINSpbcg, argument, fault);
 
-    case 10: return solution (0, 1, &KINSpbcg, argument, fault);
 
-    case 11: return solution (1, 0, &KINSpbcg, argument, fault);
 
-    case 12: return solution (1, 1, &KINSpbcg, argument, fault);
 
-    case 13: return solution (0, 0, &KINSptfqmr, argument, fault);
 
-    case 14: return solution (0, 1, &KINSptfqmr, argument, fault);
 
-    case 15: return solution (1, 0, &KINSptfqmr, argument, fault);
 
-    case 16: return solution (1, 1, &KINSptfqmr, argument, fault);
 
-    }
 
-#endif
 
-#endif
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_kinsol ()
 
-
 
-     /* This initializes some static data structures. */
 
-{
 
-  char *funames[] = {
 
-    "ud_dense",
 
-    "cd_dense",
 
-    "uj_dense",
 
-    "cj_dense",
 
-    "ud_gmres",
 
-    "cd_gmres",
 
-    "uj_gmres",
 
-    "cj_gmres",
 
-    "ud_bicgs",
 
-    "cd_bicgs",
 
-    "uj_bicgs",
 
-    "cj_bicgs",
 
-    "ud_tfqmr",
 
-    "cd_tfqmr",
 
-    "uj_tfqmr",
 
-    "cj_tfqmr",
 
-    NULL};            /* add more function names here up to a total of 255 */
 
-  list back;
 
-  int string_number;
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_matcon ();
 
-  avm_initialize_chrcodes ();
 
-  wild = avm_strung("*");
 
-  kinsol_error = avm_join (avm_strung ("kinsol error"), NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  bad_kinsol_spec = avm_join (avm_strung ("bad kinsol specification"), NULL);
 
-  unrecognized_function_name = avm_join (avm_strung ("unrecognized kinsol function name"), NULL);
 
-  string_number = 0;
 
-  funs = back = NULL;
 
-  while (funames[string_number])
 
-    avm_enqueue (&funs, &back, avm_standard_strung (funames[string_number++]));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_kinsol ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (funs);
 
-  avm_dispose (wild);
 
-  avm_dispose (kinsol_error);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (bad_kinsol_spec);
 
-  avm_dispose (unrecognized_function_name);
 
-  funs = NULL;
 
-  wild = NULL;
 
-  kinsol_error = NULL;
 
-  memory_overflow = NULL;
 
-  bad_kinsol_spec = NULL;
 
-  unrecognized_function_name = NULL;
 
-}

+ 0 - 2113
src/lapack.c
View File 

@@ -1,2113 +0,0 @@
 
-
 
-/* this file interfaces to a couple of linear algebra functions from lapack
 
-
 
-   Copyright (C) 2006,2009 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/compare.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/matcon.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/lapack.h>
 
-#if HAVE_LAPACK
 
-typedef double complex[2];
 
-#define RE 0
 
-#define IM 1
 
-#endif
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list lapack_error = NULL;
 
-static list bad_lapack_spec = NULL;
 
-static list memory_overflow = NULL;
 
-static list unrecognized_function_name = NULL;
 
-
 
-/* function names as lists of lists of character representations */
 
-static list wild = NULL;
 
-static list funs = NULL;
 
-
 
-#define MIN(x,y) ((x < y) ? x : y)
 
-#define MAX(x,y) ((x < y) ? y : x)
 
-
 
-/* the smallest number whose inverse is finitely representable */
 
-static double safemin = 0.0;
 
-
 
-#if HAVE_LAPACK
 
-
 
-/* use the LU factorization to compute the solution to a real system of linear equations A * X = B */
 
-extern void
 
-dgesvx_(char *fact, char *trans, int *n, int *nrhs, double *a, int *lda, double *af, int *ldaf, int *ipiv, char *equed,
 
-	double *r, double *c, double *b, int *ldb, double *x, int *ldx, double *rcond, double *ferr, double *berr,
 
-	double *work, int *iwork, int *info);
 
-
 
-/* use the LU factorization to compute the solution to a complex system of linear equations A * X = B */
 
-extern void
 
-zgesvx_(char *fact, char *trans, int *n, int *nrhs, complex *a, int *lda, complex *af, int *ldaf, int *ipiv,
 
-	char *equed, double *r, double *c, complex *b, int *ldb, complex *x, int *ldx, double *rcond, double *ferr,
 
-	double *berr, complex *work, double *rwork, int *info);
 
-
 
-/* compute the singular value decomposition (SVD) of a real M-by-N matrix A */
 
-extern void
 
-dgesdd_(char *jobz, int *m, int *n, double *a, int *lda, double *s, double *u, int *ldu, double *vt, int *ldvt,
 
-	double *work, int *lwork, int *iwork, int *info);
 
-
 
-/* compute the singular value decomposition (SVD) of a complex M-by-N matrix A */
 
-extern void
 
-zgesdd_(char *jobz, int *m, int *n, complex *a, int *lda, double *s, complex *u, int *ldu, complex *vt, int *ldvt,
 
-	complex *work, int *lwork, double *rwork, int *iwork, int *info);
 
-
 
-/* compute the minimum-norm solution to a real linear least squares problem */
 
-extern void
 
-dgelsd_(int *m, int *n, int *nrhs, double *a, int *lda, double *b, int *ldb, double *s, double *rcond, int *rank,
 
-	double *work, int *lwork, int *iwork, int *info);
 
-
 
-/* compute the minimum-norm solution to a complex linear least squares problem */
 
-extern void
 
-zgelsd_(int *m, int *n, int *nrhs, complex *a, int *lda, complex *b, int *ldb, double *s, double *rcond, int *rank,
 
-	complex *work, int *lwork, double *rwork, int *iwork, int *info);
 
-
 
-/* compute all the eigenvalues and, optionally, eigenvectors of a real symmetric matrix A in packed storage */
 
-extern void
 
-dspev_(char *jobz, char *uplo, int *n, double *ap, double *w, double *z, int *ldz, double *work, int *info);
 
-
 
-/* compute selected eigenvalues and, optionally, eigenvectors of a real symmetric matrix */
 
-extern void
 
-dsyevr_(char *jobz, char *range, char *uplo, int *n, double *a, int *lda, double *vl, double *vu, int *il, int *iu,
 
-	double *abstol, int *m, double *w, double *z, int *ldz, int *isuppz, double *work, int *lwork, int *iwork,
 
-	int *liwork, int *info);
 
-
 
-/* compute all the eigenvalues and, optionally, eigenvectors of a complex Hermitian matrix A in packed storage */
 
-extern void
 
-zhpev_(char *jobz, char *uplo, int *n, complex *ap, double *w, complex *z, int *ldz, complex *work, double *rwork,
 
-       int *info);
 
-
 
-/* compute selected eigenvalues and, optionally, eigenvectors of a complex Hermitian matrix */
 
-extern void
 
-zheevr_(char *jobz, char *range, char *uplo, int *n, complex *a, int *lda, double *vl, double *vu, int *il, int *iu,
 
-	double *abstol, int *m, double *w, complex *z, int *ldz, int *isuppz, complex *work, int *lwork, double *rwork,
 
-	int *lrwork, int *iwork, int *liwork, int *info);
 
-
 
-/* compute for an N-by-N real nonsymmetric matrix A, the eigenvalues and, optionally, the left and/or right eigenvectors */
 
-extern void
 
-dgeevx_(char *balanc, char *jobvl, char *jobvr, char *sense, int *n, double *a, int *lda, double *wr, double *wi,
 
-	double *vl, int *ldvl, double *vr, int *ldvr, int *ilo, int *ihi, double *scale, double *abnrm, double *rconde,
 
-	double *rcondv, double *work, int *lwork, int *iwork, int *info);
 
-
 
-/* compute for an N-by-N complex nonsymmetric matrix A, the eigenvalues and, optionally, the left and/or right eigenvectors */
 
-extern void
 
-zgeevx_(char *balanc, char *jobvl, char *jobvr, char *sense, int *n, complex *a, int *lda, complex *w, complex *vl,
 
-	int *ldvl, complex *vr, int *ldvr, int *ilo, int *ihi, double *scale, double *abnrm, double *rconde,
 
-	double *rcondv, complex *work, int *lwork, double *rwork, int *info);
 
-
 
-/* compute the Shur decomposition for an N-by-N real non-symmetric matrix A */ 
-extern void
 
-dgeesx_(char *jobvs, char *sort, void *select, char *sense, int *n, double *a, int *lda, int *sdim, double *wr, double *wi,
 
-        double *vs, int *ldvs, double *rconde, double *rcondv, double *work, int * lwork, int *iwork, int *liwork, int *bwork,
 
-        int *info);
 
-
 
-/* compute the Shur decomposition for an N-by-N complex non-symmetric matrix A */ 
-extern void
 
-zgeesx_(char *jobvs, char *sort, void *select, char *sense, int *n, complex *a, int *lda, int *sdim, complex *w, complex *vs,
 
-        int *ldvs, double *rconde, double *rcondv, complex *work, int *lwork, double *rwork, int *bwork, int *info);
 
-
 
-/* compute the Cholesky factorization of a real symmetric positive definite matrix A stored in packed format */
 
-extern void
 
-dpptrf_(char *uplo, int *n, double *ap, int *info);
 
-
 
-/* compute the Cholesky factorization of a complex Hermitian positive definite matrix A stored in packed format */
 
-extern void
 
-zpptrf_(char *uplo, int *n, complex *ap, int *info);
 
-
 
-/* determines double precision machine parameters */
 
-extern double
 
-dlamch_(char *cmach);
 
-
 
-/* choose problem-dependent parameters for the local environment */
 
-extern int
 
-ilaenv_(int *ispec,char *name,char *opts,int *n1, int *n2,int *n3,int *n4);
 
-
 
-/* solve the linear equality-constrained least squares (LSE) problem */
 
-extern void
 
-dgglse_(int *m, int *n, int *p, double *a, int *lda, double *b, int *ldb, double *c, double *d, double *x, double *work,
 
-	int *lwork, int *info);
 
-
 
-/* solve the linear equality-constrained least squares (LSE) problem */
 
-extern void
 
-zgglse_(int *m, int *n, int *p, complex *a, int *lda, complex *b, int *ldb, complex *c, complex *d, complex *x, complex *work,
 
-	int *lwork, int *info);
 
-
 
-/* solve a general Gauss-Markov linear model (GLM) problem */
 
-extern void
 
-dggglm_(int *n, int *m, int *p, double *a, int *lda, double *b, int *ldb, double *d, double *x, double *y, double *work,
 
-	int *lwork, int *info);
 
-
 
-/* solve a general Gauss-Markov linear model (GLM) problem */
 
-extern void
 
-zggglm_(int *n, int *m, int *p, complex *a, int *lda, complex *b, int *ldb, complex *d, complex *x, complex *y, complex *work,
 
-	int *lwork, int *info);
 
-
 
-
 
-
 
-
 
-static list
 
-dgesvx_caller (ab, fault)
 
-     list ab;
 
-     int *fault;
 
-
 
-     /* takes a list representing a pair (<<a..>..>,<b..>) where the
 
-	left is a row ordered square matrix and returns the solution
 
-	of the corresponding system of linear equations as a list of
 
-	numbers; returns an empty list if the matrix is singular */
 
-{
 
-  char fact;
 
-  char trans;
 
-  int n;
 
-  int nrhs;
 
-  double *a;
 
-  int lda;
 
-  double *af;
 
-  int ldaf,*ipiv;
 
-  char equed;
 
-  double *r,*c,*b;
 
-  int ldb;
 
-  double *x;
 
-  int ldx;
 
-  double rcond,*ferr,*berr,*work;
 
-  int *iwork,info;
 
-  list result;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  if (*fault = !(ab ? (avm_length(ab->head) == avm_length(ab->tail)) : 0))
 
-    return avm_copied(bad_lapack_spec);
 
-  fact = 'E';
 
-  trans = 'N';
 
-  n = avm_length(ab->head);
 
-  nrhs = 1;
 
-  a = (double *) avm_matrix_of_list(1,0,0,1,ab->head,sizeof(double),&result,fault);
 
-  lda = n;
 
-  af = (double *) malloc(n * n * sizeof(double));
 
-  ldaf = n;
 
-  ipiv = (int *) malloc(n * sizeof(int));
 
-  r = (double *) malloc(n * sizeof(double));
 
-  c = (double *) malloc(n * sizeof(double));
 
-  b = (double *) avm_vector_of_list(ab->tail,sizeof(double),&result,fault);
 
-  ldb = n;
 
-  x = (double *) malloc(n * sizeof(double));
 
-  ldx = n;
 
-  ferr = (double *) malloc(nrhs * sizeof(double));
 
-  berr = (double *) malloc(nrhs * sizeof(double));
 
-  work = (double *) malloc(4 * n * sizeof(double));
 
-  iwork = (int *) malloc(n * sizeof(int));
 
-  if (!*fault)
 
-    *fault = !(a ? (af ? (ipiv ? (r ? (c ? (b ? (x ? (ferr ? (berr ? (work ? !!iwork : 0):0):0):0):0):0):0):0):0):0);
 
-  if (*fault)
 
-    result = (result ? result : avm_copied(memory_overflow));
 
-  else
 
-    dgesvx_(&fact,&trans,&n,&nrhs,a,&lda,af,&ldaf,ipiv,&equed,r,c,b,&ldb,x,&ldx,&rcond,ferr,berr,work,iwork,&info);
 
-  if (a)
 
-    free(a);
 
-  if (af)
 
-    free (af);
 
-  if (ipiv)
 
-    free (ipiv);
 
-  if (r)
 
-    free(r);
 
-  if (c)
 
-    free (c);
 
-  if (b)
 
-    free (b);
 
-  if (ferr)
 
-    free (ferr);
 
-  if (berr)
 
-    free (berr);
 
-  if (work)
 
-    free (work);
 
-  if (iwork)
 
-    free (iwork);
 
-  if (*fault ? 1 : (info > n))
 
-    result = (result ? result : avm_copied(lapack_error));
 
-  else if (info < 0)
 
-    avm_internal_error (84);
 
-  else if (info == 0)
 
-    result = avm_list_of_vector((void *) x,n,sizeof(double),fault);
 
-  if (x)
 
-    free (x);
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-zgesvx_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* same as above but for complex numbers */
 
-{
 
-  char fact;
 
-  char trans;
 
-  int n;
 
-  int nrhs;
 
-  complex *a;
 
-  int lda;
 
-  complex *af;
 
-  int ldaf;
 
-  int *ipiv;
 
-  char equed;
 
-  double *r;
 
-  double *c;
 
-  complex *b;
 
-  int ldb;
 
-  complex *x;
 
-  int ldx;
 
-  double rcond;
 
-  double *ferr;
 
-  double *berr;
 
-  complex *work;
 
-  double *rwork;
 
-  int info;
 
-  list result;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !(operand ? (avm_length(operand->head) == avm_length(operand->tail)) : 0))
 
-    result = avm_copied (bad_lapack_spec);
 
-  fact = 'E';
 
-  trans = 'N';
 
-  n = (int) avm_length(operand);
 
-  nrhs = 1;
 
-  a = (*fault ? NULL : (complex *) avm_matrix_of_list(1,0,0,1,operand->head,sizeof(complex),&result,fault));
 
-  lda = n;
 
-  ldaf = n;
 
-  af = malloc(sizeof(complex) * ldaf * n);
 
-  ipiv = (int *) malloc(sizeof(int) * n);
 
-  r = (double *) malloc(sizeof(double) * n);
 
-  c = (double *) malloc(sizeof(double) * n);
 
-  ldb = n;
 
-  b = (*fault ? NULL : (complex *) avm_vector_of_list(operand->tail,sizeof(double),&result,fault));
 
-  ldx = n;
 
-  x = (complex *) malloc(sizeof(complex) * ldx * nrhs);
 
-  ferr = (double *) malloc(sizeof(double) * nrhs);
 
-  berr = (double *) malloc(sizeof(double) * nrhs);
 
-  work = (complex *) malloc(sizeof(complex) * 2 * n);
 
-  rwork = (double *) malloc(sizeof(double) * 2 * n);
 
-  if (!*fault)
 
-    *fault = !(a ? (af ? (ipiv ? (r ? (c ? (b ? (x ? (ferr ? (berr ? (work ? !!rwork : 0):0):0):0):0):0):0):0):0):0);
 
-  if (!*fault)
 
-    zgesvx_(&fact,&trans,&n,&nrhs,a,&lda,af,&ldaf,ipiv,&equed,r,c,b,&ldb,x,&ldx,&rcond,ferr,berr,work,rwork,&info);
 
-  if (a)
 
-    free(a);
 
-  if (af)
 
-    free (af);
 
-  if (ipiv)
 
-    free (ipiv);
 
-  if (r)
 
-    free(r);
 
-  if (c)
 
-    free (c);
 
-  if (b)
 
-    free (b);
 
-  if (ferr)
 
-    free (ferr);
 
-  if (berr)
 
-    free (berr);
 
-  if (work)
 
-    free (work);
 
-  if (rwork)
 
-    free (rwork);
 
-  if (*fault ? 1 : (info > n))
 
-    result = (result ? result : avm_copied(lapack_error));
 
-  else if (info < 0)
 
-    avm_internal_error (89);
 
-  else if (info == 0)
 
-    result = avm_list_of_vector((void *) x,n,sizeof(complex),fault);
 
-  if (x)
 
-    free (x);
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-dgesdd_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* takes a list of m time series each of length n and returns a
 
-	list of basis vectors each of length n for the singular value
 
-	decomposition; the number of basis vectors is at most min(m,n)
 
-	but could be less if the input time series aren't linearly
 
-	independent; an empty list could be returned due to failure of
 
-	convergence */
 
-{
 
-#define EPS 1.0e-8  /* for deciding the rank; consecutive singular values shouldn't fall by more than this ratio */
 
-
 
-  char jobz;
 
-  int m;
 
-  int n;
 
-  double *a;
 
-  int lda;
 
-  double *s;
 
-  double *u;
 
-  int ldu;
 
-  double *vt;
 
-  int ldvt;
 
-  double *work;
 
-  int lwork;
 
-  int *iwork;
 
-  int info;
 
-  list result;
 
-  int ucol,vtcol,prank,optimum_lwork;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !operand)
 
-    return avm_copied(bad_lapack_spec);
 
-  result = NULL;
 
-  jobz = 'O';
 
-  m = (int) avm_length(operand);
 
-  n = (int) avm_length(operand->head);
 
-  a = (double *) avm_matrix_of_list(0,0,0,1,operand,sizeof(double),&result,fault);
 
-  lda = m;
 
-  s = (double *) malloc(sizeof(double) * MIN(m,n));
 
-  ucol = ldu = ((m < n) ? m : 1);
 
-  u = (double *) malloc(ldu * ucol * sizeof(double)); 
-  vtcol = ldvt = ((m < n) ? 1 : n);
 
-  vt = (double *) malloc(ldvt * vtcol * sizeof(double));
 
-  work = (double *) malloc(sizeof(double));
 
-  lwork = (3 * MIN(m,n) * MIN(m,n)) + MAX(MAX(m,n),(5 * MIN(m,n) * MIN(m,n)) + (4 * MIN(m,n)));
 
-  iwork = (int *) malloc(sizeof(int) * 8 * MIN(m,n));
 
-  if (!(*fault = (*fault ? 1 : !(a ? (s ? (u ? (vt ? (work ? !!iwork : 0) : 0) : 0) : 0) : 0))))
 
-    {
 
-      optimum_lwork = -1;
 
-      dgesdd_(&jobz,&m,&n,a,&lda,s,u,&ldu,vt,&ldvt,work,&optimum_lwork,iwork,&info);
 
-      optimum_lwork = work[0];
 
-      free(work);
 
-      if (work = (double *) malloc(sizeof(double) * optimum_lwork))
 
-	lwork = optimum_lwork;
 
-      else
 
-	*fault = !(work = (double *) malloc(sizeof(double) * lwork));
 
-    }
 
-  if (*fault)
 
-    result = (result ? result : avm_copied(memory_overflow));
 
-  else
 
-    dgesdd_(&jobz,&m,&n,a,&lda,s,u,&ldu,vt,&ldvt,work,&lwork,iwork,&info);
 
-  if (*fault ? 0 : (info < 0))
 
-    avm_internal_error (85);
 
-  if (u)
 
-    free (u);
 
-  if (work)
 
-    free (work);
 
-  if (iwork)
 
-    free (iwork);
 
-  prank = 1;
 
-  if (s)
 
-    {
 
-      while (*fault ? 0 : ((prank < MIN(m,n) ? ((safemin < s[prank - 1]) ? ((s[prank] / s[prank - 1]) > EPS) : 0) : 0)))
 
-	prank++;
 
-      free (s);
 
-    }
 
-  if (*fault ? 0 : ((info == 0) ? (m < n) : 0))
 
-    {
 
-      free(vt);
 
-      vt = NULL;
 
-      a = (double *) avm_matrix_transposition((void *) a,n,m,sizeof(double));
 
-      result = avm_list_of_matrix((void *) a,MIN(prank + 1,m),n,sizeof(double),fault);
 
-    }
 
-  else if (*fault ? 0 : (info == 0))
 
-    {
 
-      free (a);
 
-      a = NULL;
 
-      vt = (double *) avm_matrix_transposition((void *) vt,n,n,sizeof(double));
 
-      result = avm_list_of_matrix((void *) vt,MIN(prank + 1,n),n,sizeof(double),fault);
 
-    }
 
-  if (a)
 
-    free (a);
 
-  if (vt)
 
-    free (vt);
 
-  return (*fault ? (result ? result : avm_copied(lapack_error)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-zgesdd_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* same as above for complex numbers */
 
-{
 
-  char jobz;
 
-  int m;
 
-  int n;
 
-  complex *a;
 
-  int lda;
 
-  double *s;
 
-  complex *u;
 
-  int ldu;
 
-  complex *vt;
 
-  int ldvt;
 
-  complex *work;
 
-  int lwork;
 
-  double *rwork;
 
-  int *iwork;
 
-  int info;
 
-  list result;
 
-  int ucol,vtcol,opt_lwork;
 
-  int prank;
 
-
 
-#define EPS 1.0e-8  /* for deciding the rank; consecutive singular values shouldn't fall by more than this ratio */
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !operand)
 
-    return avm_copied(bad_lapack_spec);
 
-  result = NULL;
 
-  jobz = 'A';
 
-  m = (int) avm_length(operand);
 
-  n = (int) avm_length(operand->head);
 
-  a = (complex *) avm_matrix_of_list(0,0,0,1,operand,sizeof(complex),&result,fault);
 
-  lda = m;
 
-  s = (double *) malloc(sizeof(double) * MIN(m,n));
 
-  ucol = ldu = ((m < n) ? m : 1);
 
-  u = (complex *) malloc(ldu * ucol * sizeof(complex));
 
-  vtcol = ldvt = ((m < n) ? 1 : n);
 
-  vt = (complex *) malloc(ldvt * vtcol * sizeof(complex));
 
-  work = (complex *) malloc(sizeof(complex));
 
-  lwork = (MIN(m,n) * MIN(m,n)) + (2 * MIN(m,n)) + MAX(m,n);
 
-  rwork = (double *) malloc(sizeof(double) * (5 * MIN(m,n) * MIN(m,n) + 5 * MIN(m,n)));
 
-  iwork = (int *) malloc(sizeof(int) * 8 * MIN(m,n));
 
-  if (!(*fault = !(a ? (s ? (u ? (vt ? (work ? (rwork ? !!iwork : 0) : 0) : 0) : 0) : 0) : 0)))
 
-    {
 
-      opt_lwork = -1;
 
-      zgesdd_(&jobz,&m,&n,a,&lda,s,u,&ldu,vt,&ldvt,work,&opt_lwork,rwork,iwork,&info);
 
-      opt_lwork = work[0][RE];
 
-      free(work);
 
-      if (work = (complex *) malloc(sizeof(complex) * opt_lwork))
 
-	lwork = opt_lwork;
 
-      else
 
-	*fault = !(work = (complex *) malloc(sizeof(complex) * lwork));
 
-    }
 
-  if (*fault)
 
-    result = (result ? result : avm_copied(memory_overflow));
 
-  else
 
-    zgesdd_(&jobz,&m,&n,a,&lda,s,u,&ldu,vt,&ldvt,work,&lwork,rwork,iwork,&info);
 
-  if (*fault ? 0 : (info < 0))
 
-    avm_internal_error (90);
 
-  if (u)
 
-    free (u);
 
-  if (work)
 
-    free (work);
 
-  if (iwork)
 
-    free (iwork);
 
-  if (rwork)
 
-    free (rwork);
 
-  prank = 1;
 
-  if (s)
 
-    {
 
-      while (*fault ? 0 : ((prank < MIN(m,n) ? ((safemin < s[prank - 1]) ? ((s[prank] / s[prank - 1]) > EPS) : 0) : 0)))
 
-	prank++;
 
-      free (s);
 
-    }
 
-  if (*fault ? 0 : ((info == 0) ? (m < n) : 0))
 
-    {
 
-      free(vt);
 
-      vt = NULL;
 
-      a = (complex *) avm_matrix_transposition((void *) a,n,m,sizeof(complex));
 
-      result = avm_list_of_matrix((void *) a,MIN(prank + 1,m),n,sizeof(complex),fault);
 
-    }
 
-  else if (*fault ? 0 : (info == 0))
 
-    {
 
-      free (a);
 
-      a = NULL;
 
-      vt = (complex *) avm_matrix_transposition((void *) vt,n,n,sizeof(complex));
 
-      result = avm_list_of_matrix((void *) vt,MIN(prank + 1,n),n,sizeof(complex),fault);
 
-    }
 
-  if (a)
 
-    free (a);
 
-  if (vt)
 
-    free (vt);
 
-  return (*fault ? (result ? result : avm_copied(lapack_error)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-dgelsd_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* operand represents a pair (a,b) of a matrix and a vector; a
 
-	vector of coefficients for the least squares fit is returned,
 
-	but it could be empty due to failure of convergence */
 
-{
 
-  int m;
 
-  int n;
 
-  int nrhs;
 
-  double *a;
 
-  int lda;
 
-  double *b;
 
-  int ldb;
 
-  double *s;
 
-  double rcond;
 
-  int rank;
 
-  double *work;
 
-  int lwork;
 
-  int *iwork;
 
-  int info;
 
-  list result;
 
-  int opt_lwork;
 
-  double *req_b;
 
-  int ispec;
 
-  char *name = "DGELSD";
 
-  char *opts = "";
 
-  int smlsiz;
 
-  int nlvl;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  if (*fault = !(operand ? (operand->head ? (avm_length(operand->head) == avm_length(operand->tail)) : 0) : 0))
 
-    return avm_copied (bad_lapack_spec);
 
-  m = (int) avm_length(operand->head);
 
-  n = (int) avm_length(operand->head->head);
 
-  nrhs = 1;
 
-  a = (double *) avm_matrix_of_list(0,0,0,1,operand->head,sizeof(double),&result,fault);
 
-  lda = m;
 
-  b = (*fault ? NULL : (double *) avm_vector_of_list(operand->tail,sizeof(double),&result,fault));
 
-  if (*fault ? 0 : (n > m))
 
-    if (!(*fault = !(req_b = (double *) realloc((void *) b,sizeof(double) * n))))
 
-      b = req_b;
 
-  ldb = MAX(n,m);
 
-  s = (double *) malloc(sizeof(double) * MIN(m,n));
 
-  rcond = -1.0;
 
-  ispec = 9;
 
-  smlsiz = ilaenv_(&ispec,name,opts,&n,&m,&nrhs,&lda);
 
-  ispec = MIN(m,n) / ((smlsiz = MAX(smlsiz,25)) + 1);
 
-  nlvl = 0;
 
-  while (ispec)
 
-    {
 
-      ispec = ispec >> 1;
 
-      nlvl++;
 
-    }
 
-  work = (double *) malloc(sizeof(double));
 
-  lwork = (12 * MIN(m,n)) + (2 * MIN(m,n) * smlsiz) + (8 * MIN(m,n) * nlvl) + (MIN(m,n) * nrhs) + ((smlsiz+1) * (smlsiz+1));
 
-  iwork = (int *) malloc(sizeof(int) * (3 * MIN(m,n) * nlvl + 11 * MIN(m,n)));
 
-  if (!(*fault = (*fault ? 1 : !(a ? (b ? (s ? (work ? !!iwork : 0) : 0) : 0) : 0))))
 
-    {
 
-      opt_lwork = -1;
 
-      dgelsd_(&m,&n,&nrhs,a,&lda,b,&ldb,s,&rcond,&rank,work,&opt_lwork,iwork,&info);
 
-      opt_lwork = work[0];
 
-      free(work);
 
-      if (work = (double *) malloc(sizeof(double) * opt_lwork))
 
-	lwork = opt_lwork;
 
-      else
 
-	*fault = !(work = (double *) malloc(sizeof(double) * lwork));
 
-    }
 
-  if (!*fault)
 
-    {
 
-      dgelsd_(&m,&n,&nrhs,a,&lda,b,&ldb,s,&rcond,&rank,work,&lwork,iwork,&info);
 
-      if ((info < 0) ? (info >= -14) : 0)
 
-	avm_internal_error (80);
 
-      if (*fault = (info < 0))
 
-	result = (result ? result : avm_copied (lapack_error));
 
-    }
 
-  if (a)
 
-    free (a);
 
-  if (s)
 
-    free (s);
 
-  if (work)
 
-    free (work);
 
-  if (iwork)
 
-    free (iwork);
 
-  if (*fault ? 0 : (info == 0))
 
-    result = avm_list_of_vector((void *) b,n,sizeof(double),fault);
 
-  if (b)
 
-    free (b);
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-zgelsd_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* same as above for complex numbers */
 
-{
 
-  int m;
 
-  int n;
 
-  int nrhs;
 
-  complex *a;
 
-  int lda;
 
-  complex *b;
 
-  int ldb;
 
-  double *s;
 
-  double rcond;
 
-  int rank;
 
-  complex *work;
 
-  int lwork;
 
-  double *rwork;
 
-  int *iwork;
 
-  int info;
 
-  list result;
 
-  int opt_lwork;
 
-  complex *req_b;
 
-  int ispec;
 
-  char *name = "ZGELSD";
 
-  char *opts = "";
 
-  int smlsiz;
 
-  int nlvl;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !(operand ? (operand->head ? (avm_length(operand->head) == avm_length(operand->tail)) : 0) : 0))
 
-    return avm_copied (bad_lapack_spec);
 
-  result = NULL;
 
-  m = (int) avm_length(operand->head);
 
-  n = (int) avm_length(operand->head->head);
 
-  nrhs = 1;
 
-  a = (complex *) avm_matrix_of_list(1,0,0,1,operand->head,sizeof(complex),&result,fault);
 
-  lda = n;
 
-  b = (*fault ? NULL : (complex *) avm_vector_of_list(operand->tail,sizeof(complex),&result,fault));
 
-  if (*fault ? 0 : (n > m))
 
-    if (!(*fault = !(req_b = (complex *) realloc((void *) b,sizeof(complex) * n))))
 
-      b = req_b;
 
-  ldb = 1;
 
-  s = (double *) malloc(sizeof(double) * MIN(m,n));
 
-  rcond = -1.0;
 
-  work = (complex *) malloc(sizeof(complex));
 
-  lwork = (2 * MIN(m,n)) + (MIN(m,n) * nrhs);
 
-  ispec = 9;
 
-  smlsiz = ilaenv_(&ispec,name,opts,&n,&m,&nrhs,&lda);
 
-  ispec = MIN(m,n) / ((smlsiz = MAX(smlsiz,25)) + 1);
 
-  nlvl = 0;
 
-  while (ispec)
 
-    {
 
-      ispec = ispec >> 1;
 
-      nlvl++;
 
-    }
 
-  if (n < m)
 
-    rwork = (double *) malloc(sizeof(double) * ((10*n)+(2*n*smlsiz)+(8*n*nlvl)+(3*smlsiz*nrhs)+((smlsiz+1)*(smlsiz+1))));
 
-  else
 
-    rwork = (double *) malloc(sizeof(double) * ((10*m)+(2*m*smlsiz)+(8*m*nlvl)+(3*smlsiz*nrhs)+((smlsiz+1)*(smlsiz+1))));
 
-  iwork = (int *) malloc(sizeof(int) * ((3 * MIN(m,n) * nlvl) + (11 * MIN(m,n))));
 
-  if (!(*fault = (*fault ? 1 : !(a ? (b ? (s ? (work ? (rwork ? !!iwork : 0) : 0) : 0) : 0) : 0))))
 
-    {
 
-      opt_lwork = -1;
 
-      zgelsd_(&m,&n,&nrhs,a,&lda,b,&ldb,s,&rcond,&rank,work,&opt_lwork,rwork,iwork,&info);
 
-      opt_lwork = work[0][RE];
 
-      free(work);
 
-      if (work = (complex *) malloc(sizeof(complex) * opt_lwork))
 
-	lwork = opt_lwork;
 
-      else
 
-	*fault = !(work = (complex *) malloc(sizeof(complex) * lwork));
 
-    }
 
-  if (!*fault)
 
-    {
 
-      zgelsd_(&m,&n,&nrhs,a,&lda,b,&ldb,s,&rcond,&rank,work,&lwork,rwork,iwork,&info);
 
-      if ((info < 0) ? (info > -15) : 0)
 
-	avm_internal_error (91);
 
-      else if (info < 0)
 
-	result = (result ? result : avm_copied(lapack_error));
 
-    }
 
-  if (a)
 
-    free (a);
 
-  if (s)
 
-    free (s);
 
-  if (work)
 
-    free (work);
 
-  if (rwork)
 
-    free (rwork);
 
-  if (iwork)
 
-    free (iwork);
 
-  if (*fault ? 0 : (info == 0))
 
-    result = (result ? result : avm_list_of_vector((void *) b,n,sizeof(complex),fault));
 
-  if (b)
 
-    free (b);
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-dspev_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* computes eigenvectors and eigenvalues of a symmetric real
 
-	matrix the same as dsyevr_caller but with a slower algorithm
 
-	and using less memory and packed arrays */
 
-{
 
-  char jobz;
 
-  char uplo;
 
-  int n;
 
-  double *ap;
 
-  double *w;
 
-  double *z;
 
-  int ldz;
 
-  double *work;
 
-  int info;
 
-  list result;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  jobz = 'V';
 
-  uplo = ((operand ? (operand->head ? operand->head->tail : NULL) : NULL) ? 'U' : 'L');
 
-  n = (int) avm_length(operand);
 
-  ap = (double *) avm_packed_matrix_of_list(uplo == 'U',operand,n,sizeof(double),&result,fault);
 
-  w = (double *) malloc(sizeof(double) * n);
 
-  ldz = n;
 
-  z = (double *) malloc(sizeof(double) * ldz * n);
 
-  work = (double *) malloc(sizeof(double) * 3 * n);
 
-  if (!(*fault = (*fault ? 1 : !(ap ? (w ? (z ? !!work : 0) : 0) : 0))))
 
-    dspev_(&jobz,&uplo,&n,ap,w,z,&ldz,work,&info);
 
-  if (*fault ? 0 : ((info < 0) ? (info >= -9) : 0))
 
-    avm_internal_error (88);
 
-  if (ap)
 
-    free (ap);
 
-  if (work)
 
-    free (work);
 
-  result = (*fault ? result : avm_list_of_matrix((void *) z,ldz,n,sizeof(double),fault));
 
-  if (z)
 
-    free (z);
 
-  result = (*fault ? result : avm_recoverable_join(result,avm_list_of_vector((void *) w,n,sizeof(double),fault)));
 
-  if (w)
 
-    free (w);
 
-  *fault = (*fault ? 1 : !result);
 
-  return (result ? result : avm_copied (memory_overflow));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-dsyevr_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* takes a list representing a symmetric real matrix and returns
 
-        a list representing a pair (<<e..>..>,<l..>) with one item on
 
-        the left for each eigenvector and one item on the right for
 
-        each eigenvalue; since the input matrix is symmetric, the
 
-        upper or lower triangular portion may be omitted, which would
 
-        be indicated by the rows having increasing or decreasing
 
-        lengths, respectively; if the whole matrix is given, the
 
-        lower triangular part is ignored */
 
-{
 
-  char jobz;
 
-  char range;
 
-  char uplo;
 
-  int n;
 
-  double *a;
 
-  int lda;
 
-  double vl;
 
-  double vu;
 
-  int il;
 
-  int iu;
 
-  double abstol;
 
-  int m;
 
-  double *w;
 
-  double *z;
 
-  int ldz;
 
-  int *isuppz;
 
-  double *work;
 
-  int lwork;
 
-  int *iwork;
 
-  int liwork;
 
-  int info;
 
-  list result;
 
-  int opt_lwork,opt_liwork;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  if (*fault = !(operand ? operand->head : NULL))
 
-    return avm_copied(bad_lapack_spec);
 
-  jobz = 'V';
 
-  range = 'A';
 
-  uplo = (operand->head->tail ? 'U' : 'L');
 
-  lda = n = (int) avm_length(operand);
 
-  if (operand->tail ? (avm_length(operand->head) == avm_length(operand->tail->head)) : 1)
 
-    a = (double *) avm_matrix_of_list(1,0,0,1,operand,sizeof(double),&result,fault);
 
-  else
 
-    a = (double *) avm_matrix_of_list(1,uplo == 'U',uplo == 'L',1,operand,sizeof(double),&result,fault);
 
-  abstol = -1.0;
 
-  m = n;
 
-  w = (double *) malloc(sizeof(double) * n);
 
-  ldz = n;
 
-  z = (double *) malloc(sizeof(double) * ldz * m);
 
-  isuppz = (int *) malloc(sizeof(int) * 2 * m);
 
-  work = (double *) malloc(sizeof(double));
 
-  lwork = 26 * n;                                     /* bigger is better */
 
-  iwork = (int *) malloc(sizeof(int));
 
-  liwork = 10 * n;                                    /* bigger is better */
 
-  if (!(*fault = (*fault ? 1 : !(a ? (w ? (z ? (isuppz ? (work ? !!iwork : 0) : 0) : 0) : 0) : 0))))
 
-    {
 
-      opt_liwork = opt_lwork = -1;
 
-      dsyevr_(&jobz,&range,&uplo,&n,a,&lda,&vl,&vu,&il,&iu,&abstol,&m,w,z,&ldz,isuppz,work,&opt_lwork,iwork,&opt_liwork,
 
-	      &info);
 
-      opt_lwork = work[0];
 
-      opt_liwork = iwork[0];
 
-      free(work);
 
-      free(iwork);
 
-      if (work = (double *) malloc(sizeof(double) * opt_lwork))
 
-	lwork = opt_lwork;
 
-      else
 
-	*fault = !(work = (double *) malloc(sizeof(double) * lwork));
 
-      if (iwork = (int *) malloc(sizeof(int) * opt_liwork))
 
-	liwork = opt_liwork;
 
-      else
 
-	*fault = (*fault ? 1 : !(iwork = (int *) malloc(sizeof(int) * liwork)));
 
-    }
 
-  if (!*fault)
 
-    {
 
-      dsyevr_(&jobz,&range,&uplo,&n,a,&lda,&vl,&vu,&il,&iu,&abstol,&m,w,z,&ldz,isuppz,work,&lwork,iwork,&liwork,&info);
 
-      if ((info < 0) ? (info >= -21) : 0)
 
-	avm_internal_error (86);
 
-      if (*fault = (info != 0))
 
-	result = (result ? result : avm_copied (lapack_error));
 
-    }
 
-  if (a)
 
-    free (a);
 
-  if (isuppz)
 
-    free (isuppz);
 
-  if (work)
 
-    free (work);
 
-  if (iwork)
 
-    free (iwork);
 
-  result = (*fault ? result : avm_list_of_matrix((void *) z,ldz,m,sizeof(double),fault));
 
-  if (z)
 
-    free (z);
 
-  result = (*fault ? result : avm_recoverable_join(result,avm_list_of_vector((void *) w,n,sizeof(double),fault)));
 
-  if (w)
 
-    free (w);
 
-  *fault = (*fault ? 1 : !result);
 
-  if (*fault ? !result : 0)
 
-    {
 
-      *fault = 0;
 
-      result = dspev_caller(operand, fault);
 
-    }
 
-  return (result ? result : avm_copied (memory_overflow));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-zhpev_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* complex eigenvectors and real eigenvalues of a complex
 
-	Hermitian matrix, as below but with less space and a slower
 
-	or less accurate algorithm */
 
-{
 
-  char jobz;
 
-  char uplo;
 
-  int n;
 
-  complex *ap;
 
-  double *w;
 
-  complex *z;
 
-  int ldz;
 
-  complex *work;
 
-  double *rwork;
 
-  int info;
 
-  list result;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !(operand ? operand->head : NULL))
 
-    return avm_copied(bad_lapack_spec);
 
-  result = NULL;
 
-  jobz = 'V';
 
-  uplo = (operand->head->tail ? 'U' : 'L');
 
-  n = (int) avm_length (operand);
 
-  ap = (complex *) avm_packed_matrix_of_list(uplo == 'U',operand,n,sizeof(complex),&result,fault);
 
-  w = (double *) malloc(sizeof(double) * n);
 
-  ldz = ((jobz == 'V') ? n : 1);
 
-  z = (complex *) malloc(sizeof(complex) * ldz * n);
 
-  work = (complex *) malloc((sizeof(complex) * 2 * n) - 1);
 
-  rwork = (double *) malloc((sizeof(double) * 3 * n) - 2);
 
-  if (!(*fault = (*fault ? 1 : (ap ? (w ? (z ? (work ? !!rwork : 0) : 0) : 0) : 0))))
 
-    zhpev_(&jobz,&uplo,&n,ap,w,z,&ldz,work,rwork,&info);
 
-  if (*fault ? 0 : ((info < 0) ? (info >= -10) : 0))
 
-    avm_internal_error (94);
 
-  if (ap)
 
-    free (ap);
 
-  if (work)
 
-    free (work);
 
-  if (rwork)
 
-    free (rwork);
 
-  result = (*fault ? result : avm_list_of_matrix((void *) z,n,ldz,sizeof(complex),fault));
 
-  if (z)
 
-    free (z);
 
-  result = (*fault ? result : avm_recoverable_join(result,avm_list_of_vector((void *) w,n,sizeof(double),fault)));
 
-  if (w)
 
-    free (w);
 
-  *fault = (*fault ? 1 : !result);
 
-  return (result ? result : avm_copied (memory_overflow));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-zheevr_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* complex eigenvectors and real eigenvalues of a Hermitian
 
-	matrix, optionally in upper or lower triangular form */
 
-{
 
-  char jobz;
 
-  char range;
 
-  char uplo;
 
-  int n;
 
-  complex *a;
 
-  int lda;
 
-  double vl;
 
-  double vu;
 
-  int il;
 
-  int iu;
 
-  double abstol;
 
-  int m;
 
-  double *w;
 
-  complex *z;
 
-  int ldz;
 
-  int *isuppz;
 
-  complex *work;
 
-  int lwork;
 
-  double *rwork;
 
-  int lrwork;
 
-  int *iwork;
 
-  int liwork;
 
-  int info;
 
-  list result;
 
-  int opt_lwork,opt_lrwork,opt_liwork;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !(operand ? operand->head : NULL))
 
-    return avm_copied(bad_lapack_spec);
 
-  result = NULL;
 
-  jobz = 'V';
 
-  range = 'A';
 
-  uplo = (operand->head->tail ? 'U' : 'L');
 
-  n = (int) avm_length (operand);
 
-  lda = n;
 
-  if (operand->tail ? (avm_length(operand->head) == avm_length(operand->tail->head)) : 1)
 
-    a = (complex *) avm_matrix_of_list(1,0,0,1,operand,sizeof(complex),&result,fault);
 
-  else
 
-    a = (complex *) avm_matrix_of_list(1,uplo == 'U',uplo == 'L',1,operand,sizeof(complex),&result,fault);
 
-  vl = vu = 0.0;
 
-  il = iu = 0;
 
-  abstol = -1.0;
 
-  m = n;
 
-  w = (double *) malloc(sizeof(complex) * m);
 
-  ldz = ((jobz == 'V') ? n : 1);
 
-  z = (complex *) malloc(sizeof(complex) * m * ldz);
 
-  isuppz = (int *) malloc(sizeof(int) * 2 * m);
 
-  work = (complex *) malloc(sizeof(complex));
 
-  lwork = 2 * n;
 
-  rwork = (double *) malloc(sizeof(double));
 
-  lrwork = 24 * n;
 
-  iwork = (int *) malloc(sizeof(int));
 
-  liwork = 10 * n;
 
-  if (!(*fault = !(a ? (w ? (z ? (isuppz ? (work ? (rwork ? !!iwork : 0) : 0) : 0) : 0) : 0) : 0)))
 
-    {
 
-      opt_lwork = opt_lrwork = opt_liwork = -1;
 
-      zheevr_(&jobz,&range,&uplo,&n,a,&lda,&vl,&vu,&il,&iu,&abstol,&m,w,z,&ldz,isuppz,work,
 
-	      &opt_lwork,rwork,&opt_lrwork,iwork,&opt_liwork,&info);
 
-      opt_lwork = work[0][RE];
 
-      opt_lrwork = rwork[0];
 
-      opt_liwork = iwork[0];
 
-      free (work);
 
-      free(rwork);
 
-      free(iwork);
 
-      if (work = (complex *) malloc(sizeof(complex) * opt_lwork))
 
-	lwork = opt_lwork;
 
-      else if (!(work = (complex *) malloc(sizeof(complex) * lwork)))
 
-	*fault = 1;
 
-      if (rwork = (double *) malloc(sizeof(double) * opt_lrwork))
 
-	lrwork = opt_lrwork;
 
-      else if (!(rwork = (double *) malloc(sizeof(double) * lrwork)))
 
-	*fault = 1;
 
-      if (iwork = (int *) malloc(sizeof(int) * opt_liwork))
 
-	liwork = opt_liwork;
 
-      else if (!(iwork = (int *) malloc(sizeof(int) * liwork)))
 
-	*fault = 1;
 
-    }
 
-  if (!*fault)
 
-    {
 
-      zheevr_(&jobz,&range,&uplo,&n,a,&lda,&vl,&vu,&il,&iu,&abstol,&m,w,z,&ldz,isuppz,work,
 
-	      &lwork,rwork,&lrwork,iwork,&liwork,&info);
 
-      if ((info < 0) ? (info >= -23) : 0)
 
-	avm_internal_error (107);
 
-      if (*fault = (info > 0))
 
-	result = (result ? result : avm_copied(lapack_error));
 
-    }
 
-  if (a)
 
-    free (a);
 
-  if (isuppz)
 
-    free (isuppz);
 
-  if (work)
 
-    free (work);
 
-  if (rwork)
 
-    free (rwork);
 
-  if (iwork)
 
-    free (iwork);
 
-  result = (*fault ? result : avm_list_of_matrix((void *) z,ldz,m,sizeof(complex),fault));
 
-  if (z)
 
-    free (z);
 
-  result = (*fault ? result : avm_recoverable_join(result,avm_list_of_vector((void *) w,n,sizeof(double),fault)));
 
-  if (w)
 
-    free (w);
 
-  *fault = (*fault ? 1 : !result);
 
-  if (*fault ? !result : 0)
 
-    {
 
-      *fault = 0;
 
-      result = zhpev_caller(operand, fault);
 
-    }
 
-  return (result ? result : avm_copied(memory_overflow));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-dgeevx_decoder(wr,wi,vr,n,result,fault)
 
-     double *wr;
 
-     double *wi;
 
-     double *vr;
 
-     int n;
 
-     list result;
 
-     int *fault;
 
-
 
-     /* gets the eigenvectors and eigenvalues in complex form out of
 
-	the dgeevx parameters wr,wi,vr, and n, and also disposes of
 
-	the parameters; *fault could be true on entry in which case
 
-	the memory will still be freed if necessary but the given
 
-	result or a memory overflow message will be returned */
 
-{
 
-  complex *wz,*vz;
 
-  list vectors,values;
 
-  int i,j;
 
-
 
-  values = NULL;
 
-  wz = (complex *) malloc(sizeof(complex) * n);
 
-  if (!(*fault = (*fault ? 1 : !wz)))
 
-    {
 
-      for (i = 0; i < n; i++)
 
-	{
 
-	  wz[i][RE] = wr[i];
 
-	  wz[i][IM] = wi[i];
 
-	}
 
-      values = avm_list_of_vector((void *) wz,n,sizeof(complex),fault);
 
-      if (*fault)
 
-	{
 
-	  result = values;
 
-	  values = NULL;
 
-	}
 
-    }
 
-  if (wz)
 
-    free (wz);
 
-  if (wr)
 
-    free (wr);
 
-  vectors = NULL;
 
-  vz = (complex *) malloc(sizeof(complex) * n * n);
 
-  if (!(*fault = (*fault ? 1 : !vz)))
 
-    {
 
-      i = 0;
 
-      while (i < n)
 
-	if (wi[i] == 0.0)
 
-	  {
 
-	    for (j = 0; j < n; j++)
 
-	      {
 
-		vz[i * n + j][RE] = vr[j * n + i];
 
-		vz[i * n + j][IM] = 0.0;
 
-	      }
 
-	    i++;
 
-	  }
 
-	else
 
-	  {
 
-	    for (j = 0; j < n; j++)
 
-	      {
 
-		vz[i * n + j][RE] = vz[(i + 1) * n + j][RE] = vr[j * n + i];
 
-		vz[i * n + j][IM] = vr[j * n + i + 1];
 
-		vz[(i + 1) * n + j][IM] = -vr[j * n + i + 1];
 
-	      }
 
-	    i = i + 2;
 
-	  }
 
-      vectors = avm_list_of_matrix((void *) vz,n,n,sizeof(complex),fault);
 
-      if (*fault)
 
-	{
 
-	  result = vectors;
 
-	  vectors = NULL;
 
-	}
 
-      else
 
-	{
 
-	  *fault = !(result = avm_recoverable_join(vectors,values));
 
-	  values = vectors = NULL;
 
-	}
 
-    }
 
-  if (wi)
 
-    free (wi);
 
-  if (values)
 
-    avm_dispose (values);
 
-  if (vectors)
 
-    avm_dispose (vectors);
 
-  if (vz)
 
-    free (vz);
 
-  if (vr)
 
-    free (vr);
 
-  return (*fault ? (result ? result : avm_copied (memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-dgeevx_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* takes a list representing a non-symmetric real square matrix
 
-	and returns the complex right eigenvectors and eigenvalues
 
-	(<<e..>..>,<v..>) */
 
-{
 
-  char balanc;
 
-  char jobvl;
 
-  char jobvr;
 
-  char sense;
 
-  int n;
 
-  double *a;
 
-  int lda;
 
-  double *wr;
 
-  double *wi;
 
-  double *vl;
 
-  int ldvl;
 
-  double *vr;
 
-  int ldvr;
 
-  int ilo;
 
-  int ihi;
 
-  double *scale;
 
-  double abnrm;
 
-  double *rconde;
 
-  double *rcondv;
 
-  double *work;
 
-  int lwork;
 
-  int *iwork;
 
-  int info;
 
-  list result;
 
-  int opt_lwork;
 
-
 
-  result = NULL;
 
-  if (*fault)
 
-    return NULL;
 
-  balanc = 'B';
 
-  jobvl = 'N';
 
-  jobvr = 'V';
 
-  sense = 'N';
 
-  n = (int) avm_length(operand);
 
-  a = (double *) avm_matrix_of_list(1,0,0,1,operand,sizeof(double),&result,fault);
 
-  lda = n;
 
-  wr = (double *) malloc(sizeof(double) * n);
 
-  wi = (double *) malloc(sizeof(double) * n);
 
-  ldvl = ((jobvl == 'V') ? n : 1);
 
-  vl = (double *) malloc(sizeof(double) * ldvl * ((jobvl == 'V') ? n : 1));
 
-  ldvr = ((jobvr == 'V') ? n : 1);
 
-  vr = (double *) malloc(sizeof(double) * ldvr * ((jobvr == 'V') ? n : 1));
 
-  scale = (double *) malloc(sizeof(double) * n);
 
-  rconde = (double *) malloc(sizeof(double) * n);
 
-  rcondv = (double *) malloc(sizeof(double) * n);
 
-  work = (double *) malloc(sizeof(double));
 
-  lwork = (((sense = 'V') ? 1 : (sense = 'B')) ? (n * (n + 6)) : (((jobvl = 'V') ? 1 : (jobvr = 'V')) ? (3 * n) : (2 * n)));
 
-  iwork = (int *) malloc(sizeof(int) * (((sense == 'N') ? 1 : (sense == 'E')) ? 1 : ((2 * n) - 2)));
 
-  if (!*fault)
 
-    *fault = !(a ? (wr ? (wi ? (vl ? (vr ? (scale ? (rconde ? (rcondv ? (work ? !!iwork : 0): 0): 0): 0): 0): 0): 0): 0): 0);
 
-  if (!*fault)
 
-    {
 
-      opt_lwork = -1;
 
-      dgeevx_(&balanc,&jobvl,&jobvr,&sense,&n,a,&lda,wr,wi,vl,&ldvl,vr,&ldvr,&ilo,&ihi,scale,&abnrm,rconde,rcondv,work,
 
-	      &opt_lwork,iwork,&info);
 
-      opt_lwork = work[0];
 
-      free(work);
 
-      if (work = (double *) malloc(sizeof(double) * opt_lwork))
 
-	lwork = opt_lwork;
 
-      else
 
-	*fault = !(work = (double *) malloc(sizeof(double) * lwork));
 
-    }
 
-  if (!*fault)
 
-    {
 
-      dgeevx_(&balanc,&jobvl,&jobvr,&sense,&n,a,&lda,wr,wi,vl,&ldvl,vr,&ldvr,&ilo,&ihi,scale,&abnrm,rconde,rcondv,work,
 
-	      &lwork,iwork,&info);
 
-      if ((info < 0) ? (info >= -23) : 0)
 
-	avm_internal_error (81);
 
-      if (*fault = (info != 0))
 
-	result = (result ? result : avm_copied (lapack_error));
 
-    }
 
-  if (a)
 
-    free (a);
 
-  if (vl)
 
-    free (vl);
 
-  if (scale)
 
-    free (scale);
 
-  if (rconde)
 
-    free (rconde);
 
-  if (rcondv)
 
-    free (rcondv);
 
-  if (work)
 
-    free (work);
 
-  if (iwork)
 
-    free(iwork);
 
-  return dgeevx_decoder(wr,wi,vr,n,result,fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-zgeevx_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* complex eigenvectors and eigenvalues of a non-symmetric
 
-	complex square matrix; could return nil due to lack of
 
-	convergence, which isn't an exception */
 
-{
 
-  char balanc;
 
-  char jobvl;
 
-  char jobvr;
 
-  char sense;
 
-  int n;
 
-  complex *a;
 
-  int lda;
 
-  complex *w;
 
-  complex *vl;
 
-  int ldvl;
 
-  complex *vr;
 
-  int ldvr;
 
-  int ilo;
 
-  int ihi;
 
-  double *scale;
 
-  double abnrm;
 
-  double *rconde;
 
-  double *rcondv;
 
-  complex *work;
 
-  int lwork;
 
-  double *rwork;
 
-  int info;
 
-  list result;
 
-  int opt_lwork;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  balanc = 'B';
 
-  jobvl = 'N';
 
-  jobvr = 'V';
 
-  sense = 'N';
 
-  n = (int) avm_length(operand);
 
-  a = (complex *) avm_matrix_of_list(1,0,0,1,operand,sizeof(complex),&result,fault);
 
-  lda = n;
 
-  w = (complex *) malloc(sizeof(complex) * n);
 
-  ldvl = ((jobvl == 'V') ? n : 1);
 
-  vl = (complex *) malloc(sizeof(complex) * ldvl * n);
 
-  ldvr = ((jobvr == 'V') ? n : 1);
 
-  vr = (complex *) malloc(sizeof(complex) * ldvr * n);
 
-  scale = (double *) malloc(sizeof(double) * n);
 
-  rconde = (double *) malloc(sizeof(double) * n);
 
-  rcondv = (double *) malloc(sizeof(double) * n);
 
-  work = (complex *) malloc(sizeof(complex));
 
-  lwork = (((sense == 'N') ? 1 : (sense == 'E')) ? (2 * n) : ((n * n) + (2 * n)));
 
-  rwork = (double *) malloc(sizeof(double) * 2 * n);
 
-  if (!*fault)
 
-    *fault = !(a ? (w ? (vl ? (vr ? (scale ? (rconde ? (rcondv ? (work ? !!rwork : 0) : 0) : 0) : 0) : 0) : 0) : 0) : 0);
 
-  if (!*fault)
 
-    {
 
-      opt_lwork = -1;
 
-      zgeevx_(&balanc,&jobvl,&jobvr,&sense,&n,a,&lda,w,vl,&ldvl,vr,&ldvr,&ilo,&ihi,scale,&abnrm,rconde,rcondv,work,
 
-	      &opt_lwork,rwork,&info);
 
-      opt_lwork = work[0][RE];
 
-      free(work);
 
-      if (work = (complex *) malloc(sizeof(complex) * opt_lwork))
 
-	lwork = opt_lwork;
 
-      else
 
-	*fault = !(work = (complex *) malloc(sizeof(complex) * lwork));
 
-    }
 
-  if (!*fault)
 
-    {
 
-      zgeevx_(&balanc,&jobvl,&jobvr,&sense,&n,a,&lda,w,vl,&ldvl,vr,&ldvr,&ilo,&ihi,scale,&abnrm,rconde,rcondv,work,
 
-	      &lwork,rwork,&info);
 
-      if ((info < 0) ? (info >= -22) : 0)
 
-	avm_internal_error (93);
 
-      else if (*fault = (info < 0))
 
-	result = (result ? result : avm_copied(lapack_error));
 
-    }
 
-  if (a)
 
-    free (a);
 
-  if (vl)
 
-    free (vl);
 
-  if (scale)
 
-    free (scale);
 
-  if (rconde)
 
-    free (rconde);
 
-  if (rcondv)
 
-    free (rcondv);
 
-  if (work)
 
-    free (work);
 
-  if (rwork)
 
-    free (rwork);
 
-  result = ((*fault ? 1 : (info != 0)) ? result : avm_list_of_matrix((void *) vr,n,ldvr,sizeof(complex),fault));
 
-  if (vr)
 
-    free (vr);
 
-  if (*fault ? 0 : (info == 0))
 
-    result = avm_recoverable_join(result,avm_list_of_vector((void *) w,n,sizeof(complex),fault));
 
-  if (w)
 
-    free (w);
 
-  *fault = (*fault ? 1 : ((info == 0) ? !result : 0));
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-dpptrf_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* returns either the upper or lower factor of the Cholesky
 
-	decomposition, depending on whether the upper or lower half of
 
-	the matrix is given; if the whole matrix is given the upper
 
-	factor is returned; if the matrix isn't positive definite, nil
 
-	is returned but it's not an exception */
 
-{
 
-  char uplo;
 
-  int n;
 
-  double *ap;
 
-  int info;
 
-  list result;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  uplo = (operand->head->tail ? 'U' : 'L');
 
-  n = (int) avm_length(operand);
 
-  ap = (double *) avm_packed_matrix_of_list(uplo == 'U',operand,n,sizeof(double),&result,fault);
 
-  if (!*fault)
 
-    dpptrf_(&uplo,&n,ap,&info);
 
-  if (*fault ? 0 : info < 0)
 
-    avm_internal_error (87);
 
-  if (*fault ? 0 : (info == 0))
 
-    result = avm_list_of_packed_matrix(uplo == 'U',(void *) ap,n,sizeof(double),fault);
 
-  if (ap)
 
-    free (ap);
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-zpptrf_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* same as above but for complex numbers */
 
-{
 
-  char uplo;
 
-  int n;
 
-  complex *ap;
 
-  int info;
 
-  list result;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  uplo = (operand->head->tail ? 'U' : 'L');
 
-  n = (int) avm_length(operand);
 
-  ap = (complex *) avm_packed_matrix_of_list(uplo == 'U',operand,n,sizeof(complex),&result,fault);
 
-  if (!*fault)
 
-    zpptrf_(&uplo,&n,ap,&info);
 
-  if (*fault ? 0 : info < 0)
 
-    avm_internal_error (92);
 
-  if (*fault ? 0 : (info == 0))
 
-    result = avm_list_of_packed_matrix(uplo == 'U',(void *) ap,n,sizeof(complex),fault);
 
-  if (ap)
 
-    free (ap);
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-dgglse_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* The operand represents ((A,c),(B,d)) where A and B are
 
-        matrices and c and d are vectors.  A and c are of length m and
 
-        B and d are of length p. Both A and B are of width n. The
 
-        result is a vector x of length n to minimize |Ax-c| subject to
 
-        the constraint that Bx=d. */
 
-
 
-{
 
-  int m;
 
-  int n;
 
-  int p;
 
-  double *a;
 
-  int lda;
 
-  double *b;
 
-  int ldb;
 
-  double *c;
 
-  double *d;
 
-  double *x;
 
-  double *work;
 
-  int lwork;
 
-  int info;
 
-  list result,ac,bd;
 
-  int opt_lwork;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  if (*fault = !(operand ? ((ac = operand->head) ? ((bd = operand->tail) ? (ac->head ? !!(bd->head) : 0) : 0) : 0) : 0))
 
-    return avm_copied(bad_lapack_spec);
 
-  m = (int) avm_length(ac->head);
 
-  n = (int) avm_length(ac->head->head);
 
-  p = (int) avm_length(bd->head);
 
-  if (*fault = !((p <= n) ? ((n <= m + p) ? (n == (int) avm_length(bd->head->head)) : 0): 0))
 
-    return avm_copied(bad_lapack_spec);
 
-  if (*fault = ((m != (int) avm_length(ac->tail)) ? 1 : (p != (int) avm_length(bd->tail))))
 
-    return avm_copied(bad_lapack_spec);
 
-  a = (double *) avm_matrix_of_list(0,0,0,1,ac->head,sizeof(double),&result,fault);
 
-  lda = m;
 
-  b = (*fault ? NULL : (double *) avm_matrix_of_list(0,0,0,1,bd->head,sizeof(double),&result,fault));
 
-  ldb = p;
 
-  c = (*fault ? NULL : (double *) avm_vector_of_list(ac->tail,sizeof(double),&result,fault));
 
-  d = (*fault ? NULL : (double *) avm_vector_of_list(bd->tail,sizeof(double),&result,fault));
 
-  x = (double *) malloc(sizeof(double) * p);
 
-  work = (double *) malloc(sizeof(double));
 
-  lwork = m + n + p;
 
-  if (!(*fault = (*fault ? 1 : !(a ? (b ? (c ? (d ? (x ? !!work : 0) : 0) : 0) : 0) : 0))))
 
-    {
 
-      opt_lwork = -1;
 
-      dgglse_(&m,&n,&p,a,&lda,b,&ldb,c,d,x,work,&opt_lwork,&info);
 
-      opt_lwork = work[0];
 
-      free (work);
 
-      if (work = (double *) malloc(sizeof(double) * opt_lwork))
 
-	lwork = opt_lwork;
 
-      else
 
-	*fault = !(work = (double *) malloc(sizeof(double) * lwork));
 
-    }
 
-  if (!*fault)
 
-    {
 
-      dgglse_(&m,&n,&p,a,&lda,b,&ldb,c,d,x,work,&lwork,&info);
 
-      if ((info < 0) ? (info >= -13) : 0)
 
-	avm_internal_error (98);
 
-      if (*fault = (info != 0))
 
-	result = (result ? result : avm_copied(lapack_error));
 
-    }
 
-  if (a)
 
-    free (a);
 
-  if (b)
 
-    free (b);
 
-  if (c)
 
-    free (c);
 
-  if (d)
 
-    free (d);
 
-  if (work)
 
-    free (work);
 
-  result = (*fault ? result : avm_list_of_vector((void *) x,n,sizeof(double),fault));
 
-  if (x)
 
-    free (x);
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-zgglse_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* same as above for complex numbers */
 
-{
 
-  int m;
 
-  int n;
 
-  int p;
 
-  complex *a;
 
-  int lda;
 
-  complex *b;
 
-  int ldb;
 
-  complex *c;
 
-  complex *d;
 
-  complex *x;
 
-  complex *work;
 
-  int lwork;
 
-  int info;
 
-  list result,ac,bd;
 
-  int opt_lwork;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  if (*fault = !(operand ? ((ac = operand->head) ? ((bd = operand->tail) ? (ac->head ? !!(bd->head) : 0) : 0) : 0) : 0))
 
-    return avm_copied(bad_lapack_spec);
 
-  m = (int) avm_length(ac->head);
 
-  n = (int) avm_length(ac->head->head);
 
-  p = (int) avm_length(bd->head);
 
-  if (*fault = !((p <= n) ? ((n <= m + p) ? (n == (int) avm_length(bd->head->head)) : 0): 0))
 
-    return avm_copied(bad_lapack_spec);
 
-  if (*fault = ((m != (int) avm_length(ac->tail)) ? 1 : (p != (int) avm_length(bd->tail))))
 
-    return avm_copied(bad_lapack_spec);
 
-  a = (complex *) avm_matrix_of_list(0,0,0,1,ac->head,sizeof(complex),&result,fault);
 
-  lda = m;
 
-  b = (*fault ? NULL : (complex *) avm_matrix_of_list(0,0,0,1,bd->head,sizeof(complex),&result,fault));
 
-  ldb = p;
 
-  c = (*fault ? NULL : (complex *) avm_vector_of_list(ac->tail,sizeof(complex),&result,fault));
 
-  d = (*fault ? NULL : (complex *) avm_vector_of_list(bd->tail,sizeof(complex),&result,fault));
 
-  x = (complex *) malloc(sizeof(complex) * p);
 
-  work = (complex *) malloc(sizeof(complex));
 
-  lwork = m + n + p;
 
-  if (!(*fault = (*fault ? 1 : !(a ? (b ? (c ? (d ? (x ? !!work : 0) : 0) : 0) : 0) : 0))))
 
-    {
 
-      opt_lwork = -1;
 
-      zgglse_(&m,&n,&p,a,&lda,b,&ldb,c,d,x,work,&opt_lwork,&info);
 
-      opt_lwork = work[0][RE];
 
-      free (work);
 
-      if (work = (complex *) malloc(sizeof(complex) * opt_lwork))
 
-	lwork = opt_lwork;
 
-      else
 
-	*fault = !(work = (complex *) malloc(sizeof(complex) * lwork));
 
-    }
 
-  if (!*fault)
 
-    {
 
-      zgglse_(&m,&n,&p,a,&lda,b,&ldb,c,d,x,work,&lwork,&info);
 
-      if ((info < 0) ? (info >= -13) : 0)
 
-	avm_internal_error (95);
 
-      if (*fault = (info != 0))
 
-	result = (result ? result : avm_copied(lapack_error));
 
-    }
 
-  if (a)
 
-    free (a);
 
-  if (b)
 
-    free (b);
 
-  if (c)
 
-    free (c);
 
-  if (d)
 
-    free (d);
 
-  if (work)
 
-    free (work);
 
-  result = (*fault ? result : avm_list_of_vector((void *) x,n,sizeof(complex),fault));
 
-  if (x)
 
-    free (x);
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-dggglm_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* The operand represents a pair of matrices and a vector
 
-	((A,B),d). The result is a pair of vectors (x,y) satisfying
 
-        Ax + By = d for which |y| is minimal */
 
-{
 
-  int n;
 
-  int m;
 
-  int p;
 
-  double *a;
 
-  int lda;
 
-  double *b;
 
-  int ldb;
 
-  double *d;
 
-  double *x;
 
-  double *y;
 
-  double *work;
 
-  int lwork;
 
-  int info;
 
-  list result,ab;
 
-  int opt_lwork;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  if (*fault = !(operand ? ((ab = operand->head) ? (ab->head ? !!(ab->tail) : 0) : 0) : 0))
 
-    return avm_copied(bad_lapack_spec);
 
-  n = (int) avm_length(ab->head);
 
-  m = (int) avm_length(ab->head->head);
 
-  p = (int) avm_length(ab->tail->head);
 
-  if (*fault = !(p ? (n ? (m ? ((m <= n) ? ((n <= m+p) ? (n == (int) avm_length(ab->tail)) : 0) : 0) : 0) : 0) : 0))
 
-    return avm_copied(bad_lapack_spec);
 
-  if (*fault = (n != (int) avm_length(operand->tail)))
 
-    return avm_copied(bad_lapack_spec);
 
-  lda = n;
 
-  a = (double *) avm_matrix_of_list(0,0,0,1,ab->head,sizeof(double),&result,fault);
 
-  ldb = n;
 
-  b = (*fault ? NULL : (double *) avm_matrix_of_list(0,0,0,1,ab->tail,sizeof(double),&result,fault));
 
-  d = (*fault ? NULL : (double *) avm_vector_of_list(operand->tail,sizeof(double),&result,fault));
 
-  x = (double *) malloc(sizeof(double) * m);
 
-  y = (double *) malloc(sizeof(double) * p);
 
-  work = (double *) malloc(sizeof(double));
 
-  lwork = n + m + p;
 
-  if (!(*fault = !(a ? (b ? (d ? (x ? (y ? !!work : 0) : 0) : 0) : 0) : 0)))
 
-    {
 
-      opt_lwork = -1;
 
-      dggglm_(&n,&m,&p,a,&lda,b,&ldb,d,x,y,work,&opt_lwork,&info);
 
-      opt_lwork = work[0];
 
-      free(work);
 
-      if (work = (double *) malloc(sizeof(double) * opt_lwork))
 
-	lwork = opt_lwork;
 
-      else
 
-	*fault = !(work = (double *) malloc(sizeof(double) * lwork));
 
-    }
 
-  if (!*fault)
 
-    {
 
-      dggglm_(&n,&m,&p,a,&lda,b,&ldb,d,x,y,work,&lwork,&info);
 
-      if ((info < 0) ? (info >= -13) : 0)
 
-	avm_internal_error (96);
 
-      if (*fault = (info != 0))
 
-	result = (result ? result : avm_copied(lapack_error));
 
-    }
 
-  if (a)
 
-    free (a);
 
-  if (b)
 
-    free (b);
 
-  if (d)
 
-    free (d);
 
-  if (work)
 
-    free (work);
 
-  result = (*fault ? result : avm_list_of_vector((void *) x,m,sizeof(double),fault));
 
-  if (x)
 
-    free (x);
 
-  if (!*fault)
 
-    result = avm_recoverable_join(result,avm_list_of_vector((void *) y,p,sizeof(double),fault));
 
-  if (y)
 
-    free (y);
 
-  *fault = (*fault ? 1 : !result);
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-zggglm_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* same as above with complex numbers */
 
-{
 
-  int n;
 
-  int m;
 
-  int p;
 
-  complex *a;
 
-  int lda;
 
-  complex *b;
 
-  int ldb;
 
-  complex *d;
 
-  complex *x;
 
-  complex *y;
 
-  complex *work;
 
-  int lwork;
 
-  int info;
 
-  list result,ab;
 
-  int opt_lwork;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  if (*fault = !(operand ? ((ab = operand->head) ? (ab->head ? !!(ab->tail) : 0) : 0) : 0))
 
-    return avm_copied(bad_lapack_spec);
 
-  n = (int) avm_length(ab->head);
 
-  m = (int) avm_length(ab->head->head);
 
-  p = (int) avm_length(ab->tail->head);
 
-  if (*fault = !(p ? (n ? (m ? ((m <= n) ? ((n <= m+p) ? (n == (int) avm_length(ab->tail)) : 0) : 0) : 0) : 0) : 0))
 
-    return avm_copied(bad_lapack_spec);
 
-  if (*fault = (n != (int) avm_length(operand->tail)))
 
-    return avm_copied(bad_lapack_spec);
 
-  lda = n;
 
-  a = (complex *) avm_matrix_of_list(0,0,0,1,ab->head,sizeof(complex),&result,fault);
 
-  ldb = n;
 
-  b = (*fault ? NULL : (complex *) avm_matrix_of_list(0,0,0,1,ab->tail,sizeof(complex),&result,fault));
 
-  d = (*fault ? NULL : (complex *) avm_vector_of_list(operand->tail,sizeof(complex),&result,fault));
 
-  x = (complex *) malloc(sizeof(complex) * m);
 
-  y = (complex *) malloc(sizeof(complex) * p);
 
-  work = (complex *) malloc(sizeof(complex));
 
-  lwork = n + m + p;
 
-  if (!(*fault = !(a ? (b ? (d ? (x ? (y ? !!work : 0) : 0) : 0) : 0) : 0)))
 
-    {
 
-      opt_lwork = -1;
 
-      zggglm_(&n,&m,&p,a,&lda,b,&ldb,d,x,y,work,&opt_lwork,&info);
 
-      opt_lwork = work[0][RE];
 
-      free(work);
 
-      if (work = (complex *) malloc(sizeof(complex) * opt_lwork))
 
-	lwork = opt_lwork;
 
-      else
 
-	*fault = !(work = (complex *) malloc(sizeof(complex) * lwork));
 
-    }
 
-  if (!*fault)
 
-    {
 
-      zggglm_(&n,&m,&p,a,&lda,b,&ldb,d,x,y,work,&lwork,&info);
 
-      if ((info < 0) ? (info >= -13) : 0)
 
-	avm_internal_error (97);
 
-      if (*fault = (info != 0))
 
-	result = (result ? result : avm_copied(lapack_error));
 
-    }
 
-  if (a)
 
-    free (a);
 
-  if (b)
 
-    free (b);
 
-  if (d)
 
-    free (d);
 
-  if (work)
 
-    free (work);
 
-  result = (*fault ? result : avm_list_of_vector((void *) x,m,sizeof(complex),fault));
 
-  if (x)
 
-    free (x);
 
-  if (!*fault)
 
-    result = avm_recoverable_join(result,avm_list_of_vector((void *) y,p,sizeof(complex),fault));
 
-  if (y)
 
-    free (y);
 
-  *fault = (*fault ? 1 : !result);
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-dgeesx_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-{
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-zgeesx_caller (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-{
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-#endif
 
-
 
-
 
-
 
-list
 
-avm_have_lapack_call (function_name, fault)
 
-     list function_name;
 
-     int *fault;
 
-
 
-/* this reports the availability of a function */
 
-
 
-{
 
-#if HAVE_LAPACK
 
-  list membership;
 
-  list comparison;
 
-  list result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_lapack ();
 
-  if (*fault)
 
-    return NULL;
 
-  comparison = avm_binary_comparison (function_name, wild, fault);
 
-  if (*fault)
 
-    return comparison;
 
-  if (comparison)
 
-    {
 
-      avm_dispose(comparison);
 
-      return avm_copied(funs);
 
-    }
 
-  if (!(membership = avm_binary_membership (function_name, funs, fault)) ? 1 : *fault)
 
-    return membership;
 
-  avm_dispose(membership);
 
-  return ((*fault = !(result = avm_recoverable_join(avm_copied(function_name),NULL))) ? avm_copied(memory_overflow) : result);
 
-#endif
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_lapack_call (function_name, argument, fault)
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-{
 
-#if HAVE_LAPACK
 
-  list message;
 
-  int function_number;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (! initialized)
 
-    avm_initialize_lapack ();
 
-  if (!(function_number = 0xff & (function_name ? function_name->characterization : 0)))
 
-    {
 
-      message = avm_position (function_name, funs, fault);
 
-      if (*fault)
 
-	return (message);
 
-      if (*fault = !message)
 
-	return(avm_copied (unrecognized_function_name));
 
-      function_number = message->characterization;
 
-      function_name->characterization = function_number;
 
-      avm_dispose (message);
 
-    }
 
-  switch (function_number)
 
-    {
 
-    case 1: return dgesvx_caller (argument, fault);
 
-    case 2: return zgesvx_caller (argument, fault);
 
-    case 3: return dgesdd_caller (argument, fault);
 
-    case 4: return zgesdd_caller (argument, fault);
 
-    case 5: return dgelsd_caller (argument, fault);
 
-    case 6: return zgelsd_caller (argument, fault);
 
-    case 7: return dsyevr_caller (argument, fault);
 
-    case 8: return zheevr_caller (argument, fault);
 
-    case 9: return dgeevx_caller (argument, fault);
 
-    case 10: return zgeevx_caller (argument, fault);
 
-    case 11: return dpptrf_caller (argument, fault);
 
-    case 12: return zpptrf_caller (argument, fault);
 
-    case 13: return dspev_caller (argument, fault);
 
-    case 14: return zhpev_caller (argument, fault);
 
-    case 15: return dgglse_caller (argument, fault);
 
-    case 16: return zgglse_caller (argument, fault);
 
-    case 17: return dggglm_caller (argument, fault);
 
-    case 18: return zggglm_caller (argument, fault);
 
-    case 19: return dgeesx_caller (argument, fault);
 
-    case 20: return zgeesx_caller (argument, fault);
 
-    }
 
-#endif /* HAVE_LAPACK */
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_lapack ()
 
-
 
-     /* This initializes some static data structures. */
 
-{
 
-  char *funames[] = {
 
-    "dgesvx",
 
-    "zgesvx",
 
-    "dgesdd",
 
-    "zgesdd",
 
-    "dgelsd",
 
-    "zgelsd",
 
-    "dsyevr",
 
-    "zheevr",
 
-    "dgeevx",
 
-    "zgeevx",
 
-    "dpptrf",
 
-    "zpptrf",
 
-    "dspev",
 
-    "zhpev",
 
-    "dgglse",
 
-    "zgglse",
 
-    "dggglm",
 
-    "zggglm",
 
-    "dgeesx",
 
-    "zgeesx",
 
-    NULL};            /* add more function names here up to a total of 255 */
 
-  list back;
 
-  int string_number;
 
-  char S;
 
-
 
-  S = 'S';
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_matcon ();
 
-  avm_initialize_chrcodes ();
 
-  wild = avm_strung("*");
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  lapack_error = avm_join (avm_strung ("lapack error"), NULL);
 
-  bad_lapack_spec = avm_join (avm_strung ("bad lapack specification"), NULL);
 
-  unrecognized_function_name = avm_join (avm_strung ("unrecognized lapack function name"), NULL);
 
-#if HAVE_LAPACK
 
-  safemin = dlamch_(&S);
 
-#endif
 
-  string_number = 0;
 
-  funs = back = NULL;
 
-  while (funames[string_number])
 
-    avm_enqueue (&funs, &back, avm_standard_strung (funames[string_number++]));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_lapack ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (funs);
 
-  avm_dispose (wild);
 
-  avm_dispose (lapack_error);
 
-  avm_dispose (bad_lapack_spec);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (unrecognized_function_name);
 
-  funs = NULL;
 
-  wild = NULL;
 
-  lapack_error = NULL;
 
-  memory_overflow = NULL;
 
-  unrecognized_function_name = NULL;
 
-}

+ 0 - 323
src/libfuns.c
View File 

@@ -1,323 +0,0 @@
 
-
 
-/* this file glues external libraries into the virtual machine
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/mathlib.h>
 
-#include <avm/rmathlib.h>
 
-#include <avm/gslintlib.h>
 
-#include <avm/glpklib.h>
 
-#include <avm/gsldiflib.h>
 
-#include <avm/gslevu.h>
 
-#include <avm/complexlib.h>
 
-#include <avm/mtwist.h>
 
-#include <avm/umf.h>
 
-#include <avm/mpfr.h>
 
-#include <avm/lapack.h>
 
-#include <avm/fftw.h>
 
-#include <avm/minpack.h>
 
-#include <avm/kinsol.h>
 
-#include <avm/libfuns.h>
 
-#include <avm/bes.h>
 
-#include <avm/lpsolve.h>
 
-#include <avm/harminv.h>
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list unrecognized_library = NULL;
 
-static list memory_overflow = NULL;
 
-
 
-/* library names as lists of lists of character representations */
 
-static list libs = NULL;
 
-static list wild_libs = NULL;
 
-
 
-/* wild card search pattern */
 
-static list wild = NULL;
 
-
 
-
 
-
 
-
 
-list
 
-avm_library_call (library_name, function_name, argument, fault)
 
-     list library_name;
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-
 
-     /* This figures out what library to call and calls it. */
 
-{
 
-  list message;
 
-  int library_number;
 
-
 
-  if (! initialized)
 
-      avm_initialize_libfuns ();
 
-  if (*fault)
 
-    return NULL;
 
-  library_number = 0xff & (library_name ? library_name->characterization : 0);
 
-  if (! library_number)
 
-    {
 
-      message = avm_position (library_name, libs, fault);
 
-      if (*fault)
 
-	return (message);
 
-      if (*fault = !message)
 
-	return (avm_copied(unrecognized_library));
 
-      library_number = message->characterization;
 
-      library_name->characterization = library_number;
 
-      avm_dispose (message);
 
-    }
 
-  switch (library_number)
 
-    {
 
-    case 1: return avm_math_call (function_name, argument, fault);
 
-    case 2: return avm_complex_call (function_name, argument, fault);
 
-    case 3: return avm_rmath_call (function_name, argument, fault);
 
-    case 4: return avm_mtwist_call (function_name, argument, fault);
 
-    case 5: return avm_gslint_call (function_name, argument, fault);
 
-    case 6: return avm_gsldif_call (function_name, argument, fault);
 
-    case 7: return avm_gslevu_call (function_name, argument, fault);
 
-    case 8: return avm_glpk_call (function_name, argument, fault);
 
-    case 9: return avm_umf_call (function_name, argument, fault);
 
-    case 10: return avm_mpfr_call (function_name, argument, fault);
 
-    case 11: return avm_lapack_call (function_name, argument, fault);
 
-    case 12: return avm_fftw_call (function_name, argument, fault);
 
-    case 13: return avm_minpack_call (function_name, argument, fault);
 
-    case 14: return avm_kinsol_call (function_name, argument, fault);
 
-    case 15: return avm_bes_call (function_name, argument, fault);
 
-    case 16: return avm_lpsolve_call (function_name, argument, fault);
 
-    case 17: return avm_harminv_call (function_name, argument, fault);
 
-    default: *fault = 1;
 
-    }
 
-  return avm_copied (unrecognized_library);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_have_library_call (library_name, function_name, fault)
 
-     list library_name;
 
-     list function_name;
 
-     int *fault;
 
-
 
-     /* This checks whether a library function is available. */
 
-
 
-{
 
-  list looked_up;
 
-  list results;
 
-  list temporary;
 
-  list reversal;
 
-  list library_names;
 
-  int library_number;
 
-
 
-  if (! initialized)
 
-    avm_initialize_libfuns ();
 
-  if (*fault)
 
-    return NULL;
 
-  results = NULL;
 
-  looked_up = avm_position (library_name, wild_libs, fault);
 
-  if (*fault)
 
-    return (looked_up);
 
-  if (!looked_up)
 
-    return (NULL);
 
-  library_number = looked_up->characterization;
 
-  avm_dispose(looked_up);
 
-  looked_up = NULL;
 
-  if (library_number == 1)
 
-    library_names = avm_copied(libs);
 
-  else
 
-    {
 
-      library_number--;
 
-      if (*fault = !(library_names = avm_recoverable_join(avm_copied(library_name),NULL)))
 
-	return avm_copied (memory_overflow);
 
-    }
 
-  while (*fault ? NULL : library_names)
 
-    {
 
-      switch (library_number)
 
-	{
 
-	case 1: looked_up = avm_have_math_call (function_name, fault); break;
 
-	case 2: looked_up = avm_have_complex_call (function_name, fault); break;
 
-	case 3: looked_up = avm_have_rmath_call (function_name, fault); break;
 
-	case 4: looked_up = avm_have_mtwist_call (function_name, fault); break;
 
-	case 5: looked_up = avm_have_gslint_call (function_name, fault); break;
 
-	case 6: looked_up = avm_have_gsldif_call (function_name, fault); break;
 
-	case 7: looked_up = avm_have_gslevu_call (function_name, fault); break;
 
-	case 8: looked_up = avm_have_glpk_call (function_name, fault); break;
 
-	case 9: looked_up = avm_have_umf_call (function_name, fault); break;
 
-	case 10: looked_up = avm_have_mpfr_call (function_name, fault); break;
 
-	case 11: looked_up = avm_have_lapack_call (function_name, fault); break;
 
-	case 12: looked_up = avm_have_fftw_call (function_name, fault); break;
 
-	case 13: looked_up = avm_have_minpack_call (function_name, fault); break;
 
-	case 14: looked_up = avm_have_kinsol_call (function_name, fault); break;
 
-	case 15: looked_up = avm_have_bes_call (function_name, fault); break;
 
-	case 16: looked_up = avm_have_lpsolve_call (function_name, fault); break;
 
-	case 17: looked_up = avm_have_harminv_call (function_name, fault); break;
 
-	default: *fault = 1;
 
-	  looked_up = avm_copied (unrecognized_library);
 
-	}
 
-      temporary = NULL;
 
-      *fault = (*fault ? 1 : !(temporary = avm_recoverable_join(avm_copied(library_names->head),looked_up)));
 
-      looked_up = (*fault ? NULL : avm_distribution(temporary,fault));
 
-      avm_dispose(temporary);
 
-      library_names = avm_copied((temporary = library_names)->tail);
 
-      avm_dispose(temporary);
 
-      library_number++;
 
-      while (*fault ? NULL : looked_up)
 
-	{
 
-	  results = avm_recoverable_join(avm_copied(looked_up->head),results);
 
-	  looked_up = avm_copied((temporary = looked_up)->tail);
 
-	  avm_dispose(temporary);
 
-	  if (*fault = !results)
 
-	    {
 
-	      avm_dispose(looked_up);
 
-	      looked_up = NULL;
 
-	    }
 
-	}
 
-    }
 
-  avm_dispose(library_names);
 
-  if (*fault)
 
-    {
 
-      avm_dispose (results);
 
-      return (looked_up ? looked_up : avm_copied (memory_overflow));
 
-    }
 
-  reversal = NULL;
 
-  while (results)
 
-    {
 
-      temporary = results->tail;
 
-      results->tail = reversal;
 
-      reversal = results;
 
-      results = temporary;
 
-    }
 
-  return reversal;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_libfuns ()
 
-
 
-     /* This initializes some static data structures. */
 
-
 
-{
 
-  list back;
 
-  int string_number;
 
-  char *libnames[] = {
 
-    "math",
 
-    "complex",
 
-    "rmath",
 
-    "mtwist",
 
-    "gslint",
 
-    "gsldif",
 
-    "gslevu",
 
-    "glpk",
 
-    "umf",
 
-    "mpfr",
 
-    "lapack",
 
-    "fftw",
 
-    "minpack",
 
-    "kinsol",
 
-    "bes",
 
-    "lpsolve",
 
-    "harminv",
 
-    NULL};            /* add more library names here up to a total of 255 */
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_math ();
 
-  avm_initialize_lists ();
 
-  avm_initialize_listfuns ();
 
-  avm_initialize_complex ();
 
-  avm_initialize_rmath ();
 
-  avm_initialize_mtwist ();
 
-  avm_initialize_gslint ();
 
-  avm_initialize_gsldif ();
 
-  avm_initialize_gslevu ();
 
-  avm_initialize_glpk ();
 
-  avm_initialize_umf ();
 
-  avm_initialize_mpfr ();
 
-  avm_initialize_lapack ();
 
-  avm_initialize_fftw ();
 
-  avm_initialize_minpack ();
 
-  avm_initialize_kinsol ();
 
-  avm_initialize_bes ();
 
-  avm_initialize_lpsolve ();
 
-  avm_initialize_harminv ();
 
-  avm_initialize_chrcodes ();
 
-  wild = avm_strung ("*");
 
-  unrecognized_library = avm_join (avm_strung ("unrecognized library"), NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  string_number = 0;
 
-  libs = back = NULL;
 
-  while (libnames[string_number])
 
-    avm_enqueue (&libs, &back, avm_standard_strung (libnames[string_number++]));
 
-  wild_libs = avm_join(avm_copied(wild),avm_copied(libs));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_libfuns ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-  if (!initialized)
 
-    return;
 
-  avm_count_math ();
 
-  avm_count_listfuns ();
 
-  avm_count_complex ();
 
-  avm_count_rmath ();
 
-  avm_count_mtwist ();
 
-  avm_count_gslint ();
 
-  avm_count_gsldif ();
 
-  avm_count_gslevu ();
 
-  avm_count_glpk ();
 
-  avm_count_umf ();
 
-  avm_count_mpfr ();
 
-  avm_count_lapack ();
 
-  avm_count_fftw ();
 
-  avm_count_minpack ();
 
-  avm_count_kinsol ();
 
-  avm_count_bes ();
 
-  avm_count_lpsolve ();
 
-  avm_count_harminv ();
 
-  initialized = 0;
 
-  avm_dispose (libs);
 
-  avm_dispose (wild_libs);
 
-  avm_dispose (unrecognized_library);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (wild);
 
-  libs = NULL;
 
-  unrecognized_library = NULL;
 
-}

+ 0 - 683
src/listfuns.c
View File 

@@ -1,683 +0,0 @@
 
-
 
-/* this file contains some more complicated operations on lists
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/compare.h>
 
-#include <avm/listfuns.h>
 
-
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* represents (nil,nil) */
 
-static list shared_cell = NULL;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list empty_size = NULL;
 
-static list invalid_value = NULL;
 
-static list missing_value = NULL;
 
-static list memory_overflow = NULL;
 
-static list counter_overflow = NULL;
 
-static list invalid_transpose = NULL;
 
-static list invalid_membership = NULL;
 
-static list invalid_distribution = NULL;
 
-static list invalid_concatenation = NULL;
 
-
 
-
 
-
 
-
 
-void
 
-*avm_value_of_list (operand, message, fault)
 
-     list operand;
 
-     list *message;
 
-     int *fault;
 
-
 
-     /* This takes a list representing a value used by a library
 
-        function and returns a pointer to the value. The value field
 
-        in such a list will normally point to the block of memory
 
-        holding the value, and the list itself will be a list of
 
-        character representations whose binary encodings spell out the
 
-        value. The redundancy is deliberate because it allows a list
 
-        representing a value to be written out to a file in the usual
 
-        avm format without any loss of information. */
 
-
 
-{
 
-  char *temporary;
 
-  void *result;
 
-  int datum;
 
-  counter size;
 
-  list root;
 
-
 
-  if (*fault = (*fault ? 1 : !!(*message)))
 
-    return NULL;
 
-  if (*fault = !operand)
 
-    {
 
-      *message = avm_copied (missing_value);
 
-      return NULL;
 
-    }
 
-  if (operand->value)
 
-    return operand->value;
 
-  if (*fault = ! (result = (void *) malloc (size = avm_length (operand))))
 
-    {
 
-      *message = avm_copied (memory_overflow);
 
-      return NULL;
 
-    }
 
-  operand->value = result;
 
-  temporary = (char *) result;
 
-  root = operand;
 
-  while (*fault ? NULL : operand)
 
-    if (*fault = (datum = avm_standard_character_code (operand->head)) < 0)
 
-      *message = avm_copied (invalid_value);
 
-    else
 
-      {
 
-	if (!size--)
 
-	  avm_internal_error(60);
 
-	*temporary++ = datum;
 
-	operand = operand->tail;
 
-      }
 
-  if (!*fault)
 
-    return result;
 
-  free (root->value);
 
-  root->value = NULL;
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_list_of_value (contents, size, fault)
 
-     void *contents;
 
-     size_t size;
 
-     int *fault;
 
-
 
-     /* inverse of value_of_list, takes the address and the size of
 
-	the value to a list, making a copy of the contents rather
 
-        than relying on the original */
 
-{
 
-  list front,back,entry;
 
-  char *temporary;
 
-  void *result;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if(*fault = !size)
 
-    return avm_copied (empty_size);
 
-  if(*fault = !(result = (void *) malloc (size)))
 
-    return avm_copied (memory_overflow);
 
-  front = back = NULL;
 
-  memcpy (result, contents, size);
 
-  temporary = (char *) contents;
 
-  while (*fault ? 0 : size)
 
-    {
 
-      entry = avm_standard_character_representation (*temporary++);
 
-      avm_recoverable_enqueue (&front, &back, entry, fault);
 
-      size--;
 
-    }
 
-  if (*fault)
 
-    {
 
-      avm_dispose (front);
 
-      free (result);
 
-      front = avm_copied (memory_overflow);
 
-    }
 
-  else
 
-    front->value = result;
 
-  return front;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_reversal (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* This returns a copy of the reversal of a list. */
 
-
 
-{
 
-  list result;
 
-
 
-  *fault = 0;
 
-  if (!operand ? 1 : !(operand->tail))
 
-    return avm_copied (operand);
 
-  result = NULL;
 
-  while (*fault ? 0 : operand)
 
-    {
 
-      *fault = !(result = avm_recoverable_join (avm_copied (operand->head), result));
 
-      operand = operand->tail;
 
-    }
 
-  if (*fault)
 
-    return avm_copied (memory_overflow);
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_distribution (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* This creates a list in which every item is a pair with the
 
-	head of the original operand on the left and the corresponding
 
-	member of the tail of the original operand on the right. */
 
-
 
-{
 
-  list left, right, front, back;
 
-
 
-  if (*fault = !operand)
 
-    return (avm_copied (invalid_distribution));
 
-  left = operand->head;
 
-  right = operand->tail;
 
-  front = back = (right ? avm_recoverable_join(NULL, NULL) : NULL);
 
-  if (right ? !(*fault = !back) : 0)
 
-    {
 
-      front->known_weight = 0;
 
-      *fault = !(back->head = avm_recoverable_join (avm_copied (left),avm_copied (right->head)));
 
-      right = right->tail;
 
-    }
 
-  while (*fault ? 0 : right)
 
-    {
 
-      if (! (*fault = !(back = back->tail = avm_recoverable_join (NULL, NULL))))
 
-	*fault = !(back->head = avm_recoverable_join (avm_copied (left),avm_copied (right->head)));
 
-      right = right->tail;
 
-    }
 
-  if (*fault)
 
-    {
 
-      avm_dispose (front);
 
-      return avm_copied (memory_overflow);
 
-    }
 
-  return front;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_concatenation (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* This makes a list with the head of the operand concatenated to
 
-	the tail. */
 
-
 
-{
 
-  list left, front, back;
 
-
 
-  if (*fault = !operand)
 
-    return avm_copied (invalid_concatenation);
 
-  if (!(operand->tail))
 
-    return avm_copied(operand->head);
 
-  if (!(left = operand->head))
 
-    return avm_copied(operand->tail);
 
-  if (! (*fault = !(front = back = avm_recoverable_join (NULL, NULL))))
 
-    {
 
-      back->head = avm_copied (left->head);
 
-      left = left->tail;
 
-    }
 
-  while (left ? !(*fault = !back) : 0)
 
-    {
 
-      if (back = back->tail = avm_recoverable_join (NULL, NULL))
 
-	back->head = avm_copied (left->head);
 
-      left = left->tail;
 
-    }
 
-  if (!(*fault = !back))
 
-    back->tail = avm_copied (operand->tail);
 
-  if (*fault)
 
-    {
 
-      avm_dispose (front);
 
-      return avm_copied (memory_overflow);
 
-    }
 
-  return front;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_flattened (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* equivalent to reduce(cat,nil) in Ursala notation */
 
-{
 
-  list front,back,item;
 
-
 
-  front = back = NULL;
 
-  while (*fault ? NULL : operand)
 
-    {
 
-      item = operand->head;
 
-      while (*fault ? NULL : item)
 
-	{
 
-	  avm_recoverable_enqueue (&front, &back, avm_copied (item->head), fault);
 
-	  item = item->tail;
 
-	}
 
-      operand = operand->tail;
 
-    }
 
-  return front;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_transposition (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-    /* This requires the operand to represent a list of equal length
 
-       lists. It returns the list of lists in which the first item is
 
-       the list of all first items in the operand, the second item is
 
-       the list of all second items, and so on. The operand is
 
-       disposed of. */
 
-
 
-{
 
-  list old, front_head, back_head, front_tail, back_tail, front, back;
 
-
 
-#define queue(f,b,x)							                                  \
 
-  if(!*fault)								                                  \
 
-    {									                                  \
 
-      if((*fault=!(b?(b=b->tail=avm_recoverable_join(NULL,NULL)):(f=b=avm_recoverable_join(NULL,NULL))))) \
 
-	{								                                  \
 
-	  avm_dispose(f);	                                         		        	  \
 
-	  f = avm_copied(memory_overflow);				                                  \
 
-	}								                                  \
 
-      else								                                  \
 
-	b->head = avm_copied(x);					                                  \
 
-    }
 
-  
-  *fault = 0;
 
-  front = back = NULL;
 
-  while (operand ? (!!(operand->head) ? !*fault : 0) : 0)
 
-    {
 
-      front_head = back_head = front_tail = back_tail = NULL;
 
-      while (*fault ? 0 : operand)
 
-	{
 
-	  queue (front_head, back_head, operand->head->head);
 
-	  queue (front_tail, back_tail, operand->head->tail);
 
-	  operand = avm_copied ((old = operand)->tail);
 
-	  avm_dispose (old);
 
-	  if (!operand ? 0 : *fault ? 0 : (*fault = !(operand->head)))
 
-	    {
 
-	      avm_dispose (front);
 
-	      front = avm_copied (invalid_transpose);
 
-	    }
 
-	}
 
-      queue (front, back, front_head);
 
-      avm_dispose (front_head);
 
-      operand = front_tail;
 
-    }
 
-  while (operand)
 
-    {
 
-      if (*fault ? 0 : (*fault = !!(operand->head)))
 
-	{
 
-	  avm_dispose (front);
 
-	  front = avm_copied (invalid_transpose);
 
-	}
 
-      operand = avm_copied ((old = operand)->tail);
 
-      avm_dispose (old);
 
-    }
 
-  return front;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_binary_membership (operand, members, fault)
 
-     list operand;
 
-     list members;
 
-     int *fault;
 
-
 
-     /* This computes the membership predicate; returns NULL if the
 
-        operand isn't anywhere in the members, but returns
 
-        shared_cell if it is. */
 
-{
 
-  list message;
 
-
 
-  message = NULL;
 
-  while (*fault ? 0 : (message ? 0 : !!members))
 
-    {
 
-      message = avm_binary_comparison (operand, members->head, fault);
 
-      members = members->tail;
 
-    }
 
-  return message;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_membership (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* This computes the membership predicate; returns NULL if the
 
-        head isn't anywhere in the tail of the operand, but returns
 
-        shared_cell if it is. The operand must be non-empty or an
 
-        error message is returned. */
 
-{
 
-  if (*fault = !operand)
 
-    return avm_copied (invalid_membership);
 
-  return avm_binary_membership (operand->head, operand->tail, fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_position (key, table, fault)
 
-     list key;
 
-     list table;
 
-     int *fault;
 
-
 
-     /* This takes a key and list whose items are possible keys, and
 
-        returns position the corresponding item as a character
 
-        encoding if any; otherwise returns NULL. */
 
-
 
-{
 
-  int found;
 
-  int position;
 
-  list message;
 
-
 
-  message = NULL;
 
-  found = position = 0;
 
-  while (*fault ? 0 : (found ? 0 : !!table))
 
-    {
 
-      found = (*fault ? 0 : !!(message = avm_binary_comparison (key, table->head, fault)));
 
-      position++;
 
-      table = table->tail;
 
-    }
 
-  if(found)
 
-    {
 
-      avm_dispose (message);
 
-      message = avm_character_representation (position);
 
-    }
 
-  return message;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_measurement (operand, fault)
 
-
 
-/* This returns the number of cells in a list as a binary number
 
-   represented by a list of bits lsb first, with shared_cell for 1 and
 
-   NULL for 0; also assigns the known_weight fields in all cells
 
-   visited for future reference. The algorithm works without recursion
 
-   by building a stack, starting out with just the operand on it. Then
 
-   the following operations are perfomed until the stack has only a
 
-   single item on it with a known weight, which is the answer. An
 
-   unknown weight in the top item causes its head and tail to be
 
-   pushed. A known weight on the top and an unknown weight on the one
 
-   below causes the top and the one below to be interchanged. Known
 
-   weights on both cause them to be added and popped, with the
 
-   successor of the total assigned to the one below them. There could
 
-   be an overflow if the weight is too big to fit in a counter type
 
-   (probably 64 bits). Even though a list can't have more cells than
 
-   that, it could appear to have more due to shared subtrees. In the
 
-   event of overflow, an exception is thrown. */
 
-
 
-     list operand;
 
-     int *fault;
 
-{
 
-  counter count;
 
-  list temporary, stack, result;
 
-
 
-  if (*fault = !(stack = avm_recoverable_join (avm_copied (operand), NULL)))
 
-    return avm_copied (memory_overflow);
 
-  while (stack)
 
-    {
 
-      if (stack->head)
 
-	{
 
-	  if (stack->head->known_weight)
 
-	    {
 
-	      if (stack->tail)
 
-		{
 
-		  if (stack->tail->head)
 
-		    {
 
-		      if (count = stack->tail->head->known_weight)
 
-			{
 
-			  *fault = ((stack->tail->tail->head->known_weight = 1+count+stack->head->known_weight) <= count);
 
-			  if (*fault)
 
-			    {
 
-			      stack->tail->tail->head->known_weight = 0;
 
-			      avm_dispose (stack);
 
-			      return (avm_copied (counter_overflow));
 
-			    }
 
-			  else
 
-			    {
 
-			      stack = avm_copied ((temporary = stack)->tail->tail);
 
-			      avm_dispose (temporary);
 
-			    }
 
-			}
 
-		      else
 
-			{
 
-			  temporary = stack->tail->head;
 
-			  stack->tail->head = stack->head;
 
-			  stack->head = temporary;
 
-			}
 
-		    }
 
-		  else if (*fault = !(stack->tail->tail->head->known_weight = stack->head->known_weight + 1))
 
-		    {
 
-		      stack->tail->tail->head->known_weight = 0;
 
-		      avm_dispose (stack);
 
-		      return (avm_copied (counter_overflow));
 
-		    }
 
-		  else
 
-		    {
 
-		      stack = avm_copied ((temporary = stack)->tail->tail);
 
-		      avm_dispose (temporary);
 
-		    }
 
-		}
 
-	      else
 
-		{
 
-		  count = stack->head->known_weight;
 
-		  avm_dispose (stack);
 
-		  stack = NULL;
 
-		}
 
-	    }
 
-	  else
 
-	    {
 
-	      temporary = avm_copied(stack->head->head);
 
-	      stack = avm_recoverable_join(temporary, avm_recoverable_join (avm_copied(stack->head->tail),stack));
 
-	      if (*fault = !stack)
 
-		return (avm_copied (memory_overflow));
 
-	    }
 
-	}
 
-      else if (stack->tail)
 
-	{
 
-	  if (stack->tail->head)
 
-	    {
 
-	      if (count = stack->tail->head->known_weight)
 
-		{
 
-		  if (*fault = ((stack->tail->tail->head->known_weight = 1 + count) <= count))
 
-		    {
 
-		      stack->tail->tail->head->known_weight = 0;
 
-		      avm_dispose (stack);
 
-		      return (avm_copied (counter_overflow));
 
-		    }
 
-		  else
 
-		    {
 
-		      stack = avm_copied ((temporary = stack)->tail->tail);
 
-		      avm_dispose (temporary);
 
-		    }
 
-		}
 
-	      else
 
-		{
 
-		  temporary = stack->tail->head;
 
-		  stack->tail->head = stack->head;
 
-		  stack->head = temporary;
 
-		}
 
-	    }
 
-	  else
 
-	    {
 
-	      stack->tail->tail->head->known_weight = 1;
 
-	      stack = avm_copied ((temporary = stack)->tail->tail);
 
-	      avm_dispose (temporary);
 
-	    }
 
-	}
 
-      else
 
-	{
 
-	  count = 0;
 
-	  avm_dispose (stack);
 
-	  stack = NULL;
 
-	}
 
-    }
 
-  while (count)
 
-    {
 
-      if (*fault = !(stack = avm_recoverable_join ((count & 1) ? avm_copied (shared_cell) : NULL, stack)))
 
-	return (avm_copied (memory_overflow));
 
-      count >>= 1;
 
-    }
 
-  result = NULL;
 
-  while (stack)
 
-    {
 
-      stack = (temporary = stack)->tail;
 
-      temporary->tail = result;
 
-      result = temporary;
 
-    }
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_listfuns ()
 
-
 
-     /* This initializes some static data structures. */
 
-
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_chrcodes ();
 
-  avm_initialize_compare ();
 
-  shared_cell = avm_join (NULL, NULL);
 
-  empty_size = avm_join (avm_strung ("empty size"), NULL);
 
-  missing_value = avm_join (avm_strung ("missing value"), NULL);
 
-  invalid_value = avm_join (avm_strung ("invalid value"), NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  counter_overflow = avm_join (avm_strung ("counter overflow"), NULL);
 
-  invalid_transpose = avm_join (avm_strung ("invalid transpose"), NULL);
 
-  invalid_membership = avm_join (avm_strung ("invalid membership"), NULL);
 
-  invalid_distribution = avm_join (avm_strung ("invalid distribution"), NULL);
 
-  invalid_concatenation = avm_join (avm_strung ("invalid concatenation"), NULL);
 
-}
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_listfuns ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (empty_size);
 
-  avm_dispose (shared_cell);
 
-  avm_dispose (invalid_value);
 
-  avm_dispose (missing_value);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (counter_overflow);
 
-  avm_dispose (invalid_transpose);
 
-  avm_dispose (invalid_membership);
 
-  avm_dispose (invalid_distribution);
 
-  avm_dispose (invalid_concatenation);
 
-  empty_size = NULL;
 
-  shared_cell = NULL;
 
-  missing_value = NULL;
 
-  invalid_value = NULL;
 
-  memory_overflow = NULL;
 
-  counter_overflow = NULL;
 
-  invalid_transpose = NULL;
 
-  invalid_membership = NULL;
 
-  invalid_distribution = NULL;
 
-  invalid_concatenation = NULL;
 
-}
 
-
 
-

+ 0 - 540
src/lists.c
View File 

@@ -1,540 +0,0 @@
 
-
 
-/* this file contains some basic operations on lists
 
-
 
-   Copyright (C) 2006-2010 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-*/
 
-
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-
 
-/* a cache of reusable list nodes */
 
-static list available_list = NULL;
 
-
 
-/* the number of nodes in the cache */
 
-static int available_lists = 0;
 
-
 
-/* the maximum number allowed in the cache */
 
-#define node_cache_size 0xff
 
-
 
-/* the number of allocated lists excluding the cache */
 
-static counter extant_lists = 0;
 
-
 
-/* represents (nil,nil) */
 
-static list shared_cell = NULL;
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-
 
-void
 
-avm_dispose (front)
 
-     list front;
 
-
 
-     /* This performs space efficient storage reclamation; it avoids
 
-        recursion and additional allocation by using the disposed list
 
-        as its own queue. */
 
-
 
-{
 
-  list old_front, back;
 
-
 
-  back = front;
 
-  while (front)
 
-    {
 
-      if (front->sharers)
 
-	{
 
-	  (front->sharers)--;
 
-	  front = NULL;
 
-	}
 
-      else
 
-	{
 
-	  while (front->head ? 1 : front->interpretation ? 1 : back->tail ? 1 : 0)
 
-	    {
 
-	      if (!(back->tail))
 
-		{
 
-		  if (front->head)
 
-		    {
 
-		      back->tail = front->head;
 
-		      front->head = NULL;
 
-		    }
 
-		  else
 
-		    {
 
-		      back->tail = front->interpretation;
 
-		      front->interpretation = NULL;
 
-		    }
 
-		}
 
-	      else if (!(back->tail->sharers))
 
-		back = back->tail;
 
-	      else
 
-		{
 
-		  (back->tail->sharers)--;
 
-		  back->tail = NULL;
 
-		}
 
-	    }
 
-	  front = (old_front = front)->tail;
 
-	  if (old_front->value)
 
-	    {
 
-	      free (old_front->value);
 
-	      old_front->value = NULL;
 
-	    }
 
-	  if (old_front->facilitator)
 
-	    {
 
-	      old_front->facilitator->impetus = NULL;
 
-	      old_front->facilitator = NULL;
 
-	    }
 
-	  extant_lists--;
 
-	  if (available_lists > node_cache_size)
 
-	    free (old_front);
 
-	  else
 
-	    {
 
-	      old_front->tail = available_list;
 
-	      available_list = old_front;
 
-	      available_lists++;
 
-	    }
 
-	}
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_recoverable_join (left, right)
 
-     list left;
 
-     list right;
 
-
 
-     /* This function implements the cons operation; this is where
 
-        list nodes get allocated. A cache of nodes is maintained in
 
-        available_lists so they can be quickly recycled without going
 
-        through malloc(). Performance can be tuned by varying the size
 
-        of the cache, which is in the constant node_cache_size,
 
-        defined above. The number of allocated nodes outside of the
 
-        cache is maintained in extant_lists, which is forced not to
 
-        exceed a number that can be stored in a counter, thereby
 
-        ensuring that the reference count field in a list node can
 
-        never overflow. It could never happen anyway unless the size
 
-        of a counter is smaller than that of a pointer. 
-
 
-        A later addition to this function was to compute the optional
 
-        known_weight field unconditionally so as to improve spacial
 
-        locality. It isn't needed unless the weight of a list is
 
-        computed, at which time it's assigned as a side effect if not
 
-        already present. Compilation of large module with compression
 
-        has a tendency to thrash if there are non-resident pages and
 
-        weights aren't computed in advance. */
 
-
 
-{
 
-  list result;
 
-  int lw,rw,w;
 
-
 
-  if (!++extant_lists)		/* prevents reference count overflow */
 
-    {
 
-      extant_lists--;
 
-      avm_dispose (left);
 
-      avm_dispose (right);
 
-      return NULL;
 
-    }
 
-  if (result = available_list)
 
-    {
 
-      available_list = available_list->tail;
 
-      available_lists--;
 
-    }
 
-  else if (!(result = (list) (malloc (sizeof (*result)))))
 
-    {
 
-      avm_dispose (left);
 
-      avm_dispose (right);
 
-      return NULL;
 
-    }
 
-  memset (result, 0, sizeof (*result));
 
-  result->head = left;
 
-  result->tail = right;
 
-  if ((left ? (lw = left->known_weight) : !(lw = 0)) ? (right ? (rw = right->known_weight) : !(rw = 0)) : 0)
 
-    result->known_weight = ((lw ? 1 : rw) ? (((w = lw + rw + 1) > lw) ? ((w > rw) ? w : 0) : 0) : 0);
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_join (left, right)
 
-     list left;
 
-     list right;
 
-
 
-     /* This creates a new list lst node with the given descendents or
 
-	aborts if there isn't enough space. */
 
-
 
-{
 
-  list result;
 
-
 
-  if (!(result = avm_recoverable_join (left, right)))
 
-    avm_error ("memory overflow (code 11)");
 
-  return (result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-inline list
 
-avm_copied (operand)
 
-     list operand;
 
-
 
-     /* This returns a shared copy; reference count overflows are
 
-        impossible because the number of extant list nodes is small
 
-        enough to be enumerated by a counter. */
 
-{
 
-  if (operand)
 
-    (operand->sharers)++;
 
-  return operand;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_enqueue (front, back, operand)
 
-     list *front;
 
-     list *back;
 
-     list operand;
 
-
 
-     /* This can be used only to build a new unshared list; front and
 
-        back should be initialized to NULL by the caller and not
 
-        modified or copied until after the last item is enqueued. */
 
-
 
-{
 
-  if (*back ? (*back = (*back)->tail = avm_join (NULL, NULL)) : ((*front) = (*back) = avm_join (NULL, NULL)))
 
-    (*back)->head = operand;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_recoverable_enqueue (front, back, operand, fault)
 
-     list *front;
 
-     list *back;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* This is like enqueue, but blows away the operand instead of
 
-        terminating in the event of a memory error. It's the
 
-        responsibility of the caller to check after each call that the
 
-        queue still exists, not just after the last call. */
 
-
 
-{
 
-  list new_item;
 
-
 
-  if (*fault = (*fault ? 1 : !(new_item = avm_recoverable_join (NULL, NULL))))
 
-    {
 
-      avm_dispose (operand);
 
-      avm_dispose (*front);
 
-      *front = *back = NULL;
 
-      return;
 
-    }
 
-  *back = (*back ? ((*back)->tail = new_item) : ((*front) = (*back) = new_item));
 
-  (*back)->head = operand;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-counter
 
-avm_recoverable_length (operand)
 
-     list operand;
 
-
 
-     /* This returns the length of a list but returns zero if a
 
-	counter overflows. */
 
-
 
-{
 
-  counter result;
 
-
 
-  result = 0;
 
-  while (operand)
 
-    {
 
-      if (!++result)
 
-	return 0;
 
-      operand = operand->tail;
 
-    }
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-counter
 
-avm_length (operand)
 
-     list operand;
 
-
 
-     /* This returns the length of a list, but causes an error if it
 
-        overflows. */
 
-
 
-{
 
-  counter result;
 
-
 
-  result = avm_recoverable_length (operand);
 
-  if (operand ? !result : result)
 
-    avm_error ("counter overflow (code 1)");
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-counter
 
-avm_area (operand)
 
-     list operand;
 
-
 
-     /* This returns the sum of the lengths of a list of lists but
 
-	aborts if a counter overflows. */
 
-
 
-{
 
-  counter result, new_result;
 
-
 
-  result = 0;
 
-  while (operand)
 
-    {
 
-      if ((new_result = result + avm_length (operand->head)) < result)
 
-	avm_error ("counter overflow (code 2)");
 
-      result = new_result;
 
-      operand = operand->tail;
 
-    }
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-counter
 
-avm_recoverable_area (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* This returns sum of the lengths of a list of lists but sets
 
-	the fault flag to 1 if a counter overflows. */
 
-
 
-{
 
-  counter result, new_result, head_length;
 
-
 
-  result = *fault = 0;
 
-  while (*fault ? 0 : operand)
 
-    {
 
-      if (! (*fault = (new_result = result + (head_length = avm_recoverable_length (operand->head))) < result))
 
-	*fault = (operand->head ? !head_length : 0);
 
-      result = new_result;
 
-      operand = operand->tail;
 
-    }
 
-  return (*fault ? 0 : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_natural (number)
 
-     counter number;
 
-
 
-     /* This converts a counter to a list representation with list
 
-        significant bit first. NULL represents a zero and shared_cell
 
-        represents a 1 bit. It aborts if there isn't enough memory. */
 
-
 
-{
 
-  list front_bit, back_bit;
 
-
 
-  front_bit = back_bit = NULL;
 
-  while (number)
 
-    {
 
-      avm_enqueue (&front_bit, &back_bit,(number & 1) ? avm_copied (shared_cell) : NULL);
 
-      number >>= 1;
 
-    }
 
-  return front_bit;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_recoverable_natural (number)
 
-     counter number;
 
-
 
-     /* This returns a list representation of an integer similar to
 
-        avm_natural but returns NULL if there isn't enough memory. */
 
-
 
-{
 
-  list front_bit, back_bit;
 
-  int fault;
 
-
 
-  fault = 0;
 
-  front_bit = back_bit = NULL;
 
-  while (fault ? 0 : number)
 
-    {
 
-      avm_recoverable_enqueue (&front_bit, &back_bit, (number & 1) ? avm_copied (shared_cell) : NULL, &fault);
 
-      number >>= 1;
 
-    }
 
-  return front_bit;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-counter
 
-avm_counter (number)
 
-     list number;
 
-
 
-     /* inverse of avm_natural; ignores overflow */
 
-{
 
-  counter result;
 
-  list reversal,temporary;
 
-
 
-  reversal = NULL;
 
-  while (number)
 
-    {
 
-      temporary = number->tail;
 
-      number->tail = reversal;
 
-      reversal = number;
 
-      number = temporary;
 
-    }
 
-  result = 0;
 
-  temporary = reversal;
 
-  while (reversal)
 
-    {
 
-      result <<= 1;
 
-      if (reversal->head)
 
-	result++;
 
-      reversal = reversal->tail;
 
-    }
 
-  reversal = temporary;
 
-  while (reversal)
 
-    {
 
-      temporary = reversal->tail;
 
-      reversal->tail = number;
 
-      number = reversal;
 
-      reversal = temporary;
 
-    }
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-plist (l)
 
-     list l;
 
-
 
-     /* This prints a list to standard output as a string of nested
 
-	parentheses by recursively calling itself. */
 
-{
 
-
 
-  printf ("(");
 
-  if (l)
 
-    {
 
-      plist (l->head);
 
-      printf (",");
 
-      plist (l->tail);
 
-    }
 
-  printf (")");
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_print_list (operand)
 
-     list operand;
 
-
 
-     /* This is like plist but finishes with a newline. It's useful
 
-        only for debugging; prints a list to standard output as a
 
-        string of nested parentheses; there's no check for stack
 
-        overflow */
 
-{
 
-  plist (operand);
 
-  printf ("\n");
 
-}
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_lists ()
 
-
 
-     /* This must be called before anything else in this file to
 
-	initialize static data structures. */
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  if (!(shared_cell = (list) (malloc (sizeof (*shared_cell)))))
 
-    avm_error ("memory overflow (code 12)");
 
-  extant_lists++;
 
-  if (!extant_lists)
 
-    avm_internal_error (32);
 
-  memset (shared_cell, 0, sizeof (*shared_cell));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_lists ()
 
-
 
-     /* This frees static data structures and reports memory leaks. */
 
-{
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (shared_cell);
 
-  shared_cell = NULL;
 
-  if (extant_lists)
 
-    avm_reclamation_failure ("lists", extant_lists);
 
-}

+ 0 - 542
src/lpsolve.c
View File 

@@ -1,542 +0,0 @@
 
-
 
-/* this file interfaces to linear programming routines from lp_solve
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.  
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/compare.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/lpsolve.h>
 
-#include <avm/apply.h>
 
-#if HAVE_LPSOLVE
 
-#include <lpsolve/lp_lib.h>
 
-#endif
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list bad_lpsolve_spec = NULL;
 
-static list memory_overflow = NULL;
 
-static list unrecognized_function_name = NULL;
 
-
 
-/* virtual code program equivalent to guard\<'bad lpsolve specification'>! nleq-<&hll+ nleq-<&lr*+ |=&ll */
 
-static list sorter = NULL;
 
-
 
-/* list of the floating point number zero */
 
-static list zero = NULL;
 
-
 
-/* function names as lists of lists of character representations */
 
-static list wild = NULL;
 
-static list funs = NULL;
 
-
 
-
 
-
 
-
 
-
 
-#if HAVE_LPSOLVE
 
-
 
-
 
-
 
-static void
 
-filled(lp, a, b, n, row, message, fault)
 
-     lprec *lp;
 
-     list a;
 
-     list b;
 
-     int n;
 
-     double *row;
 
-     list *message;
 
-     int *fault;
 
-
 
-     /* a is the constraint matrix in the form <<((i,j),x)..>..>,
 
-	partitioned by rows, and sorted by columns and rows. b is the
 
-	constraint vector, n is the maximum length of any row, and row
 
-	is a vector of doubles big enough to hold any row. */
 
-{
 
-  int j;
 
-  list t;
 
-  int *col;
 
-  double *y;
 
-
 
-  col = NULL;
 
-  if (*fault = (*fault ? 1 : !(col = (int *) malloc (n * sizeof(int)))))
 
-    *message = (*message ? *message : avm_copied (memory_overflow));
 
-  while (*fault ? 0 : a)
 
-    {
 
-      j = 0;
 
-      t = a->head;
 
-      a = a->tail;
 
-      while (*fault ? 0 : t)
 
-	if (!(t->head ? t->head->head : 0))       /* should have been established when sorting */
 
-	  avm_internal_error (109);
 
-	else if (*fault = (j >= n))
 
-	  *message = avm_copied (bad_lpsolve_spec);
 
-	else
 
-	  {
 
-	    col[j] = 1 + (int) avm_counter (t->head->head->tail);
 
-	    y = (double *) avm_value_of_list (t->head->tail, message, fault);
 
-	    row[j++] = *y;
 
-	    t = t->tail;
 
-	  }
 
-      if (*fault = (*fault ? 1 : !b))
 
-	*message = (*message ? *message : avm_copied (bad_lpsolve_spec));
 
-      else
 
-	y = (double *) avm_value_of_list (b->head, message, fault);
 
-      if (!(*fault = (*fault ? 1 : !(add_constraintex(lp, j, row, col, EQ, *y)))))
 
-	b = b->tail;
 
-    }
 
-  if (col)
 
-    free (col);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static lprec
 
-*problem_object(cost_vector, constraint_matrix, constraint_vector, rows, columns, message, fault)
 
-     list cost_vector;
 
-     list constraint_matrix;
 
-     list constraint_vector;
 
-     int *rows;
 
-     int *columns;
 
-     list *message;
 
-     int *fault;
 
-
 
-     /* This takes the lists specifying the problem to an lprec type
 
-	problem object. */
 
-{
 
-  list y,x;
 
-  double *row,*b;
 
-  lprec *lp;
 
-
 
-  *fault = !(cost_vector = avm_recoverable_join (avm_copied (zero), avm_copied (cost_vector)));
 
-  constraint_matrix = (*fault ? NULL : avm_recoverable_apply (avm_copied (sorter), avm_copied (constraint_matrix), fault));
 
-  *rows = avm_length (constraint_matrix);
 
-  if (*fault)
 
-    {
 
-      *message = (constraint_matrix ? constraint_matrix : avm_copied (memory_overflow));
 
-      avm_dispose (cost_vector);
 
-      return NULL;
 
-    }
 
-  lp = make_lp (0, *columns = (int) avm_length (cost_vector));
 
-  row = (double *) avm_vector_of_list (cost_vector, sizeof(double), message, fault);
 
-  if (!(*fault = (*fault ? 1 : !(lp ? !!row  : 0))))
 
-    if (!(*fault = !(set_obj_fn (lp, row))))
 
-      set_add_rowmode(lp, TRUE);
 
-  filled(lp, constraint_matrix, constraint_vector, *columns, row, message, fault);
 
-  avm_dispose (constraint_matrix);
 
-  avm_dispose (cost_vector);
 
-  if (row)
 
-    free (row);
 
-  if (!*fault)
 
-    {
 
-      set_add_rowmode (lp, FALSE);
 
-      set_verbose (lp, NEUTRAL);
 
-      set_minim (lp);
 
-      return lp;
 
-    }
 
-  if (lp)
 
-    delete_lp (lp);
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-list_of_variables (x, rows, columns, fault)
 
-     double *x;
 
-     int rows;
 
-     int columns;
 
-     int *fault;
 
-
 
-     /* extracts no more variables from x than the number of rows,
 
-	putting them in a list <(i,xi)..> ignoring the zero or nearly
 
-	zero values */
 
-{
 
-  list front, back, item, index;
 
-  int column_number, non_zeros, threshold_index;
 
-  double threshold;
 
-
 
-  column_number = 0;
 
-  front = back = item = NULL;
 
-  while (*fault ? 0 : (column_number < columns))
 
-    {
 
-      if (x[column_number] != 0.0 ? 1 : x[column_number] != -0.0)
 
-	if (!(*fault = !((index = avm_recoverable_natural (column_number)) ? 1 : !(column_number))))
 
-	  {
 
-	    item = avm_list_of_value((void *) &(x[column_number]), sizeof(double), fault);
 
-	    if (*fault)
 
-	      avm_dispose (index);
 
-	    else if (!(*fault = !(item = avm_recoverable_join (index,item))))
 
-	      {
 
-		avm_recoverable_enqueue(&front, &back, item, fault);
 
-		item = NULL;
 
-	      }
 
-	  }
 
-      column_number++;
 
-    }
 
-  if (*fault ? front : NULL)
 
-    avm_dispose (front);
 
-  return (*fault ? (item ? item : avm_copied (memory_overflow)) : front);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-solution(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* operand should represent a triple of (c,m,y), where c is a
 
-	list of cost function coefficients (with no constant term) m
 
-	is a sparse matrix in the form of a list of pairs ((i,j),a)
 
-	where i and j are row and column indices starting from 0 and a
 
-	is real, and y is a list of reals such that the problem
 
-	solution x minimizes cx subject to mx=y and all members of x
 
-	non-negative. The list of indices and values (i,xi) for
 
-	non-zero reals xi in the solution is returned. */
 
-{
 
-  list result;
 
-  lprec *lp;
 
-  double *x;
 
-  int rows,columns;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !(operand ? (operand->tail) : NULL))
 
-    return avm_copied (bad_lpsolve_spec);
 
-  result = NULL;
 
-  lp = problem_object (operand->head, operand->tail->head, operand->tail->tail, &rows, &columns, &result, fault);
 
-  if (*fault = (*fault ? 1 : !!result))
 
-    return (result ? result : avm_copied (bad_lpsolve_spec));
 
-  if (solve (lp) == OPTIMAL ? get_ptr_variables(lp, &x) : 0)
 
-    result = list_of_variables (x, rows, columns, fault);
 
-  if (lp)
 
-    delete_lp (lp);
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-i_solution(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* operand should represent a triple of (i,c,m,y), where i is a
 
-        list of column numbers indicating the integer variables, and the
 
-        remaining components are as in the solution function. */
 
-{
 
-  list result,i,cmy;
 
-  lprec *lp;
 
-  double *x;
 
-  int rows,columns;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !(operand ? ((cmy = operand->tail) ? (operand->tail->tail) : NULL) : NULL))
 
-    return avm_copied (bad_lpsolve_spec);
 
-  result = NULL;
 
-  lp = problem_object (cmy->head, cmy->tail->head, cmy->tail->tail, &rows, &columns, &result, fault);
 
-  if (*fault = (*fault ? 1 : !!result))
 
-    return (result ? result : avm_copied (bad_lpsolve_spec));
 
-  i = operand->head;
 
-  while (*fault ? 0 : !!i)
 
-    {
 
-      *fault = ! set_int (lp, 1 + (int) avm_counter (i->head), 1);
 
-      i = i->tail;
 
-    }
 
-  if (*fault)
 
-    return avm_copied (bad_lpsolve_spec);
 
-  if (solve (lp) == OPTIMAL ? get_ptr_variables(lp, &x) : 0)
 
-    result = list_of_variables (x, rows, columns, fault);
 
-  if (lp)
 
-    delete_lp (lp);
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-b_solution(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* operand should represent a triple of (b,c,m,y), where b is a
 
-        list of column numbers indicating the binary variables, and the
 
-        remaining components are as in the solution function. */
 
-{
 
-  list result,b,cmy;
 
-  lprec *lp;
 
-  double *x;
 
-  int rows,columns;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !(operand ? ((cmy = operand->tail) ? (operand->tail->tail) : NULL) : NULL))
 
-    return avm_copied (bad_lpsolve_spec);
 
-  result = NULL;
 
-  lp = problem_object (cmy->head, cmy->tail->head, cmy->tail->tail, &rows, &columns, &result, fault);
 
-  if (*fault = (*fault ? 1 : !!result))
 
-    return (result ? result : avm_copied (bad_lpsolve_spec));
 
-  b = operand->head;
 
-  while (*fault ? 0 : !!b)
 
-    {
 
-      *fault = ! set_binary (lp, 1 + (int) avm_counter (b->head), 1);
 
-      b = b->tail;
 
-    }
 
-  if (*fault)
 
-    return avm_copied (bad_lpsolve_spec);
 
-  if (solve (lp) == OPTIMAL ? get_ptr_variables(lp, &x) : 0)
 
-    result = list_of_variables (x, rows, columns, fault);
 
-  if (lp)
 
-    delete_lp (lp);
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-bi_solution(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* operand should represent a triple of ((b,i),c,m,y), where b is a
 
-        list of column numbers indicating the binary variables, and the
 
-        remaining components are as in the solution function. */
 
-{
 
-  list result,b,i,cmy;
 
-  lprec *lp;
 
-  double *x;
 
-  int rows,columns;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !(operand ? ((cmy = operand->tail) ? ((operand->tail->head) ? (operand->tail->tail) : NULL) : NULL) : NULL))
 
-    return avm_copied (bad_lpsolve_spec);
 
-  result = NULL;
 
-  lp = problem_object (cmy->head, cmy->tail->head, cmy->tail->tail, &rows, &columns, &result, fault);
 
-  if (*fault = (*fault ? 1 : !!result))
 
-    return (result ? result : avm_copied (bad_lpsolve_spec));
 
-  b = operand->head->head;
 
-  while (*fault ? 0 : !!b)
 
-    {
 
-      *fault = ! set_binary (lp, 1 + (int) avm_counter (b->head), 1);
 
-      b = b->tail;
 
-    }
 
-  i = operand->head->tail;
 
-  while (*fault ? 0 : !!i)
 
-    {
 
-      *fault = ! set_int (lp, 1 + (int) avm_counter (i->head), 1);
 
-      i = i->tail;
 
-    }
 
-  if (*fault)
 
-    return avm_copied (bad_lpsolve_spec);
 
-  if (solve (lp) == OPTIMAL ? get_ptr_variables(lp, &x) : 0)
 
-    result = list_of_variables (x, rows, columns, fault);
 
-  if (lp)
 
-    delete_lp (lp);
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-#endif
 
-
 
-
 
-
 
-
 
-list
 
-avm_have_lpsolve_call (list function_name, int *fault)
 
-
 
-/* this reports the availability of a function */
 
-
 
-{
 
-#if HAVE_LPSOLVE
 
-  list membership;
 
-  list comparison;
 
-  list result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_lpsolve ();
 
-  if (*fault)
 
-    return NULL;
 
-  comparison = avm_binary_comparison (function_name, wild, fault);
 
-  if (*fault)
 
-    return comparison;
 
-  if (comparison)
 
-    {
 
-      avm_dispose(comparison);
 
-      return avm_copied(funs);
 
-    }
 
-  if (!(membership = avm_binary_membership (function_name, funs, fault)) ? 1 : *fault)
 
-    return membership;
 
-  avm_dispose(membership);
 
-  return ((*fault = !(result = avm_recoverable_join(avm_copied(function_name),NULL))) ? avm_copied(memory_overflow) : result);
 
-#endif
 
-  return (NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_lpsolve_call (function_name, argument, fault)
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-{
 
-#if HAVE_LPSOLVE
 
-
 
-  list message;
 
-  int function_number;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (! initialized)
 
-    avm_initialize_lpsolve ();
 
-  if (!(function_number = 0xff & (function_name ? function_name->characterization : 0)))
 
-    {
 
-      message = avm_position (function_name, funs, fault);
 
-      if (*fault = (*fault ? 1 : !message))
 
-	return (message ? message : avm_copied (unrecognized_function_name));
 
-      function_number = message->characterization;
 
-      function_name->characterization = function_number;
 
-      avm_dispose (message);
 
-    }
 
-  switch (function_number)
 
-    {
 
-    case 1: return solution (argument, fault);
 
-    case 2: return i_solution (argument, fault);
 
-    case 3: return b_solution (argument, fault);
 
-    case 4: return bi_solution (argument, fault);
 
-    }
 
-#endif /* HAVE_LPSOLVE */
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_lpsolve ()
 
-
 
-     /* This initializes some static data structures. */
 
-
 
-{
 
-char *sorter_code = "wOsU{mm{A^[wl=krH[{U`>AwkMf[s<ynl[_cjlE]Zye{J<atsr`\
 
-yanSs{@yJyPjWoxKV_QlKHFAzDhv\\\\PJZv\\d[c=htKV[y_]{er@_[VNy@dL[yfOQ{mKOz>=Cv`nd\
 
-OxKV^gIPDcxf<>GJdD<Bh\\hS\\=lWJJf<czcTNvxH[yfOSGN<EzeHf@`=dAxf<PNUx<PDhRL<aNJ<";
 
-
 
-  char *funames[] = {
 
-    "stdform",
 
-    "iform",
 
-    "bform",
 
-    "biform",
 
-    NULL};            /* add more function names here up to a total of 255 */
 
-  list back;
 
-  int string_number,fault;
 
-
 
-  if (initialized)
 
-      return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_chrcodes ();
 
-  avm_initialize_apply ();
 
-  wild = avm_strung("*");
 
-  zero = avm_scanned_list ("wgfzg]ftVjBg=f]fB]\\");
 
-  bad_lpsolve_spec = avm_join (avm_strung ("bad lpsolve problem specification"), NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  unrecognized_function_name = avm_join (avm_strung ("unrecognized lpsolve function name"), NULL);
 
-  sorter = avm_scanned_list (sorter_code);
 
-  string_number = 0;
 
-  funs = back = NULL;
 
-  while (funames[string_number])
 
-      avm_enqueue (&funs, &back, avm_standard_strung (funames[string_number++]));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_lpsolve ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-
 
-  if (!initialized)
 
-      return;
 
-  initialized = 0;
 
-  avm_dispose (funs);
 
-  avm_dispose (wild);
 
-  avm_dispose (zero);
 
-  avm_dispose (sorter);
 
-  avm_dispose (bad_lpsolve_spec);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (unrecognized_function_name);
 
-  sorter = NULL;
 
-  funs = NULL;
 
-  wild = NULL;
 
-  bad_lpsolve_spec = NULL;
 
-  memory_overflow = NULL;
 
-  unrecognized_function_name = NULL;
 
-}

+ 0 - 614
src/matcon.c
View File 

@@ -1,614 +0,0 @@
 
-
 
-/* this file contains some functions for converting between lists and
 
-   arrays
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/matcon.h>
 
-
 
-#define packed_index(i,j) (upper_triangular ? (((j*(j+1))>>1)+i) : (((((n*(n+1))>>1)-((((n-j)+1)*(n-j))>>1))+i)-j))
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* representation of a true boolean */
 
-static list shared_cell = NULL;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list bad_matrix_spec = NULL;
 
-static list bad_vector_spec = NULL;
 
-static list memory_overflow = NULL;
 
-static list counter_overflow = NULL;
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-*avm_vector_of_list(operand, item_size, message, fault)
 
-     list operand;
 
-     size_t item_size;
 
-     list *message;
 
-     int *fault;
 
-
 
-     /* takes a list representing a vector of equally sized items to
 
-	a contiguous array representation */
 
-{
 
-  counter num_items,index;
 
-  char *item,*result;
 
-  char *vector;
 
-
 
-  if (*fault = (*fault ? 1 : !!(*message)))
 
-    return NULL;
 
-  result = NULL;
 
-  vector = NULL;
 
-  if (*fault = (item_size ? !(num_items = avm_length(operand)) : 1))
 
-    *message = avm_copied(bad_vector_spec);
 
-  if (*fault = (*fault ? 1 : (!operand ? 1 : (item_size != (size_t) avm_length (operand->head)))))
 
-    *message = (*message ? *message : avm_copied(bad_vector_spec));
 
-  if (*fault = (*fault ? 1 : !(vector = result = (char *) malloc(num_items * item_size))))
 
-    *message = (*message ? *message : avm_copied(memory_overflow));
 
-  index = 0;
 
-  while (*fault ? 0 : (index < num_items))
 
-    {
 
-      if (!operand)
 
-	avm_internal_error (82);
 
-      item = (char *) avm_value_of_list (operand->head, message, fault);   /* all item sizes could be verified but aren't */
 
-      if (*fault ? 0 : !item)
 
-	avm_internal_error (83);
 
-      if (!*fault)
 
-	memcpy((void *) vector,(void *) item,item_size);
 
-      vector = vector + item_size;
 
-      operand = operand->tail;
 
-      index++;
 
-    }
 
-  if (!*fault)
 
-    return result;
 
-  if (result)
 
-    free(result);
 
-  *message = (*message ? *message : avm_copied(bad_vector_spec));
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_list_of_vector(vector, num_items, item_size, fault)
 
-     void *vector;
 
-     int num_items;
 
-     size_t item_size;
 
-     int *fault;
 
-
 
-     /* takes a contiguous array of n items each of the given size to
 
-	a list representation */
 
-{
 
-  int index;
 
-  list front,back,item;
 
-  char *cursor;
 
-
 
-  index = 0;
 
-  front = back = NULL;
 
-  cursor = (char *) vector;
 
-  while (*fault ? 0 : (index++ < num_items))
 
-    {
 
-      item = avm_list_of_value((void *) cursor, item_size, fault);
 
-      if (!*fault)
 
-	avm_recoverable_enqueue(&front,&back,item,fault);
 
-      else if (front)
 
-	avm_dispose(front);
 
-      cursor = cursor + item_size;
 
-    }
 
-  return (*fault ? avm_copied(memory_overflow) : front);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-*avm_matrix_of_list(square, upper_triangular, lower_triangular, column_major, operand, item_size, message, fault)
 
-     int square;
 
-     int upper_triangular;
 
-     int lower_triangular;
 
-     int column_major;
 
-     list operand;
 
-     size_t item_size;
 
-     list *message;
 
-     int *fault;
 
-
 
-     /* This transforms a list representing a matrix as a list of rows
 
-        to an array. If the square parameter is non-zero, the operand
 
-        is checked for squareness and a fault is raised if it isn't.
 
-        If either triangular parameter is non-zero, the operand is
 
-        checked for the corresponding triangularity. Otherwise the
 
-        operand is checked for rectitude. Lower triangularity means
 
-        the row lengths form an increasing sequence of consecutive
 
-        integers, and upper triangularity has them decreasing.  Upper
 
-        and lower triangularity are mutually exclusive but independent
 
-        of squareness. A square matrix that's also triangular has the
 
-        length of the longest row equal to the number of rows. */
 
-{
 
-  list y,x;
 
-  char *result,*item;
 
-  char *matrix;
 
-  counter i,j,k,l,h,w,lpad,rpad,stride,strides;
 
-
 
-  if (*fault = (*fault ? 1 : !!(*message)))
 
-    return NULL;
 
-  *fault = !(item_size ? (operand ? (operand->head ? (item_size == avm_length(operand->head->head)) : 0) : 0) : 0);
 
-  if (*fault = (*fault ? 1 : (upper_triangular ? lower_triangular : 0)))
 
-    *message = avm_copied(bad_matrix_spec);
 
-  h = w = 0;
 
-  y = operand;
 
-  while (*fault ? NULL : y)
 
-    {
 
-      k = avm_recoverable_length(y->head);
 
-      if (*fault = ((++h) ? (k ? 0 : !!(y->head)) : 1))
 
-	*message = (*message ? *message : avm_copied(counter_overflow));
 
-      w = ((w < k) ? k : w);
 
-      y = y->tail;
 
-    }
 
-  if (*fault = (*fault ? 1 : (square ? (h != w) : 0)))
 
-    *message = (*message ? *message : avm_copied(bad_matrix_spec));
 
-  l = w * h;
 
-  matrix = (char*) (result = NULL);
 
-  if (*fault = (*fault ? 1 : (!l ? 1 : !(matrix = (char *) (result = (void *) malloc(item_size * l))))))
 
-    *message = (*message ? *message : avm_copied(memory_overflow));
 
-  stride = (column_major ? (item_size * h) : item_size);
 
-  strides = (column_major ? (item_size * (l - 1)) : 0);
 
-  x = NULL;
 
-  y = operand;
 
-  i = k = lpad = 0;
 
-  rpad = w - 1;
 
-  while (*fault ? 0 : (y ? (i < l) : 0))
 
-    {
 
-      j = 0;
 
-      x = y->head;
 
-      matrix = (upper_triangular ? (matrix + (lpad * stride)) : matrix);
 
-      while (*fault ? 0 : (x ? (i < l) : 0))
 
-	{
 
-	  item = avm_value_of_list(x->head,message,fault);  /* the item size isn't verified only to save time */
 
-	  if (!*fault)
 
-	    memcpy((void *) matrix,(void *) item,item_size);
 
-	  matrix = matrix + stride;
 
-	  x = x->tail;
 
-	  i++;
 
-	  j++;
 
-	}
 
-      matrix = (lower_triangular ? (matrix + (rpad * stride)) : matrix) - strides;
 
-      *fault = (*fault ? 1 : (j + (lower_triangular ? rpad-- : (upper_triangular ? lpad++ : 0)) != w));
 
-      y = y->tail;
 
-    }
 
-  if (!*fault)
 
-    return result;
 
-  if (result)
 
-    free (result);
 
-  *message = (*message ? *message : avm_copied(bad_matrix_spec));
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_list_of_matrix(matrix, rows, cols, item_size, fault)
 
-     void *matrix;
 
-     int rows,cols;
 
-     size_t item_size;
 
-     int *fault;
 
-
 
-     /* takes a contiguous array in row major order representing a
 
-        matrix to a list representation as a list of rows with each
 
-        row being a list of entries; can be used in conjunction with
 
-        avm_matrix_transposition, below, to transform column major
 
-        order matrices to row major order; see lapack.c for an
 
-        example */
 
-{
 
-  int index;
 
-  list front,back,item;
 
-  char *cursor;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  index = 0;
 
-  front = back = NULL;
 
-  cursor = (char *) matrix;
 
-  while (*fault ? 0 : (index < rows))
 
-    {
 
-      item = avm_list_of_vector((void *) cursor, cols, item_size, fault);
 
-      if (!*fault)
 
-	avm_recoverable_enqueue(&front,&back,item,fault);
 
-      else if (front)
 
-	avm_dispose(front);
 
-      cursor = cursor + (item_size * cols);
 
-      index++;
 
-    }
 
-  return (*fault ? avm_copied(memory_overflow) : front);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_list_of_packed_matrix(upper_triangular,operand,n,item_size,fault)
 
-     int upper_triangular;
 
-     void *operand;
 
-     int n;
 
-     size_t item_size;
 
-     int *fault;
 
-
 
-     /* inverse of the next function */
 
-{
 
-  int i,j;
 
-  list front_column,back_column,front_row,back_row,item;
 
-  char *matrix;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = (n <= 0))
 
-    return avm_copied(bad_matrix_spec);
 
-  matrix = (char *) operand;
 
-  i = 0;
 
-  item = front_row = back_row = NULL;
 
-  while (*fault ? 0 : (i < n))
 
-    {
 
-      j = (upper_triangular ? i : 0);
 
-      front_column = back_column = NULL;
 
-      while (*fault ? 0 : (j < (upper_triangular ? n : (i + 1))))
 
-	{
 
-	  item = avm_list_of_value((void *) &(matrix[packed_index(i,j) * item_size]),item_size,fault);
 
-	  if (!*fault)
 
-	    {
 
-	      avm_recoverable_enqueue(&front_column,&back_column,item,fault);
 
-	      if (*fault)
 
-		item = NULL;
 
-	    }
 
-	  else if (front_column)
 
-	    avm_dispose(front_column);
 
-	  j++;
 
-	}
 
-      if (!*fault)
 
-	avm_recoverable_enqueue(&front_row,&back_row,front_column,fault);
 
-      else
 
-	avm_dispose(front_row);
 
-      i++;
 
-    }
 
-  return (*fault ? (item ? item : avm_copied(memory_overflow)) : front_row);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-*avm_packed_matrix_of_list(upper_triangular,operand,n,item_size,message,fault)
 
-     int upper_triangular;
 
-     list operand;
 
-     int n;
 
-     size_t item_size;
 
-     list *message;
 
-     int *fault;
 
-
 
-     /* The operand is a list representing an n by n symmetric square
 
-	matrix A and the result is a packed array representation m
 
-	with redundant entries omitted the way lapack likes it. That
 
-	is, A[i,j] is stored at m[packed_index(i,j)] using the macro
 
-	defined above. One of two alternative packed representations
 
-	is selected depending on the upper_triangular parameter. The
 
-	operand must be a list of n lists, with each list representing
 
-	a row of the matrix.  Either all items of the operand can be
 
-	of length n, or their lengths can range from 1 to n in either
 
-	a strictly increasing or strictly decreasing sequence. If they
 
-	are all of length n, the upper_triangular parameter determines
 
-	not only the output representation but the choice of items
 
-	from the input that are used. (Symmetry is not checked and
 
-	unused items are ignored.)  If they form an increasing
 
-	sequence, the lower triangular representation is implied and
 
-	upper_triangular must be 0. Otherwise the upper triangular
 
-	representation is implied and upper_triangular must be 1. */
 
-
 
-{
 
-  char *matrix;
 
-  char *item,*result;
 
-  int i,j,k,square;
 
-  list row,column;
 
-
 
-  if (*fault = (*fault ? 1 : !!(*message)))
 
-    return NULL;
 
-  if (*fault = !(matrix = (char *) (result = (void *) malloc(((n*(n+1))>>1) * item_size))))
 
-    *message = avm_copied(memory_overflow);
 
-  square = (operand ? (operand->tail ? (avm_length(operand->head) == avm_length(operand->tail->head)) : 0) : 0);
 
-  i = 0;
 
-  row = operand;
 
-  while (*fault ? 0 : (i < n))
 
-    {
 
-      j = (upper_triangular ? i : 0);
 
-      column = ((*fault = !row) ? NULL : row->head);
 
-      k = i;
 
-      if (square ? upper_triangular : 0)
 
-	while (*fault ? 0 : k--)
 
-	  column = ((*fault = !column) ? NULL : column->tail);
 
-      while (*fault ? 0 : (j < (upper_triangular ? n : (i + 1))))
 
-	{
 
-	  item = ((*fault = !column) ? NULL : avm_value_of_list (column->head, message, fault));
 
-	  if (!*fault)
 
-	    {
 
-	      memcpy((void *) &(matrix[packed_index(i,j) * item_size]),(void *) item,item_size);
 
-	      column = column->tail;
 
-	    }
 
-	  j++;
 
-	}
 
-      i++;
 
-      k = n - i;
 
-      if (square ? !upper_triangular : 0)
 
-	while (*fault ? 0 : k--)
 
-	  column = ((*fault = !column) ? NULL : column->tail);
 
-      if (!(*fault = (*fault ? 1 : !!column)))
 
-	row = row->tail;
 
-    }
 
-  if (!(*fault = (*fault ? 1 : !!row)))
 
-    return result;
 
-  if (result)
 
-    free (result);
 
-  *message = (*message ? *message : avm_copied(bad_matrix_spec));
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-*avm_matrix_transposition(matrix,rows,cols,item_size)
 
-     void *matrix;
 
-     int rows;
 
-     int cols;
 
-     size_t item_size;
 
-
 
-     /* constant space transposition of a contiguous row major ordered
 
-	general rectangular matrix in place; can also be used on a
 
-	matrix in column major order by interchanging the rows and
 
-	cols parameters */
 
-{
 
-#define ALIGNMENT 16         /* power of 2 >= minimum array boundary alignment; maybe unnecessary but machine dependent */
 
-
 
-  char *cursor;
 
-  char carry[ALIGNMENT];
 
-  size_t block_size,remaining_size;
 
-  int nadir,lag,orbit,ents;
 
-
 
-  if ((rows == 1) ? 1 : (cols == 1))
 
-    return matrix;
 
-  ents = rows * cols;
 
-  cursor = (char *) matrix;
 
-  remaining_size = item_size;
 
-  block_size = ((ALIGNMENT < remaining_size) ? ALIGNMENT : remaining_size);
 
-  while (block_size)
 
-    {
 
-      nadir = 1;                                    /* first and last entries are always fixed points so aren't visited */
 
-      while (nadir + 1 < ents)
 
-	{
 
-	  memcpy(carry,&(cursor[(lag = nadir) * item_size]),block_size);
 
-	  while ((orbit = (lag / rows) + cols * (lag % rows)) > nadir)                       /* follow a complete cycle */
 
-	    {
 
-	      memcpy(&(cursor[lag * item_size]),&(cursor[orbit * item_size]),block_size);
 
-	      lag = orbit;
 
-	    }
 
-	  memcpy(&(cursor[lag * item_size]),carry,block_size);
 
-	  orbit = nadir++;
 
-	  while ((orbit < nadir) ? (nadir + 1 < ents) : 0)     /* find the next unvisited index by an exhaustive search */
 
-	    {
 
-	      orbit = nadir;
 
-	      while ((orbit = (orbit / rows) + cols * (orbit % rows)) > nadir);
 
-	      nadir = ((orbit < nadir) ? nadir + 1 : nadir);
 
-	    }
 
-	}
 
-      cursor = cursor + block_size;
 
-      remaining_size = remaining_size - block_size;
 
-      block_size = ((ALIGNMENT < remaining_size) ? ALIGNMENT : remaining_size);
 
-    }
 
-  return matrix;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-*avm_matrix_reflection(upper_triangular,matrix,n,item_size)
 
-     int upper_triangular;
 
-     void *matrix;
 
-     int n;
 
-     size_t item_size;
 
-
 
-     /* fills in the redundant entries in a symmetric square matrix;
 
-	if upper_triangular is non-zero, the upper triangle is copied
 
-	to the lower triangle, and otherwise the lower is copied to
 
-	the upper */
 
-{
 
-  int i,j,rows,cols;
 
-  char *cursor;
 
-
 
-  rows = cols = n;
 
-  cursor = (char *) matrix;
 
-  for (i = 0; i < rows; i++)
 
-    for (j = (upper_triangular ? (i + 1) : 0); j < (upper_triangular ? cols : i); j++)
 
-      memcpy(&(cursor[((j * cols) + i) * item_size]),&(cursor[((i * cols) + j) * item_size]),item_size);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-*avm_row_number_array(m,fault)
 
-     counter m;
 
-     int *fault;
 
-
 
-     /* returns an array of m lists whose ith element is the
 
-	representation of the natural number i */
 
-{
 
-  list *result;
 
-  counter i;
 
-
 
-  if (*fault = (*fault ? 1 : !(result = (list *) malloc(sizeof(list) * m))))
 
-    return NULL;
 
-  result[0] = NULL;
 
-  for (i = 1; i < m; i++)
 
-    {
 
-      if (*fault)
 
-	result[i] = NULL;
 
-      else 
-	result[i] = avm_recoverable_join((i & 1) ? avm_copied (shared_cell) : NULL,avm_copied(result[i >> 1]));
 
-      *fault = (*fault ? 1 : !(result[i]));
 
-    }
 
-  if (!*fault)
 
-    return result;
 
-  for (i = 1; i < m; i++)
 
-    if (result[i])
 
-      avm_dispose (result[i]);
 
-  free (result);
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_dispose_rows(m,row_number)
 
-     counter m;
 
-     list *row_number;
 
-
 
-     /* frees a structure allocated as above */
 
-{
 
-  counter i;
 
-
 
-  if (row_number)
 
-    {
 
-      for (i = 1; i < m; i++)
 
-	avm_dispose (row_number[i]);
 
-      free (row_number);
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_matcon ()
 
-
 
-     /* This initializes some static data structures and must be
 
-	called before any other function in this file is called. */
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_listfuns ();
 
-  avm_initialize_chrcodes ();
 
-  shared_cell = avm_join (NULL, NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  counter_overflow = avm_join (avm_strung ("counter overflow"), NULL);
 
-  bad_matrix_spec = avm_join (avm_strung ("bad matrix specification"), NULL);
 
-  bad_vector_spec = avm_join (avm_strung ("bad vector specification"), NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_matcon ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (shared_cell);
 
-  avm_dispose (bad_matrix_spec);
 
-  avm_dispose (bad_vector_spec);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (counter_overflow);
 
-  shared_cell = NULL;
 
-  memory_overflow = NULL;
 
-  bad_vector_spec = NULL;
 
-  bad_matrix_spec = NULL;
 
-  counter_overflow = NULL;
 
-}
 
-

+ 0 - 609
src/mathlib.c
View File 

@@ -1,609 +0,0 @@
 
-
 
-/* this file glues external math functions into the virtual machine
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
 
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/compare.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/mathlib.h>
 
-#if HAVE_FENV
 
-#include <fenv.h>
 
-#endif
 
-#define __USE_ISOC99 1
 
-#include <math.h>
 
-#include <string.h>
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list misprint = NULL;
 
-static list empty_pair = NULL;
 
-static list memory_overflow = NULL;
 
-static list floating_point_exception = NULL;
 
-static list unrecognized_function_name = NULL;
 
-
 
-/* function names as lists of lists of character representations */
 
-static list funs = NULL;
 
-
 
-static list shared_cell = NULL;
 
-static list wild = NULL;
 
-
 
-#if HAVE_FENV
 
-
 
-typedef double (*binary_operator)(double,double);
 
-typedef double (*unary_operator)(double);
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-binary_evaluation(operator, operand, fault)
 
-     binary_operator operator;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* the operator is a C function taking a pair of doubles to a
 
-	double, and the operand is a list representing a pair of
 
-	doubles */
 
-{
 
-  list message;
 
-  double *x,*y,z;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  message = NULL;
 
-  if (*fault = !operand)
 
-    return avm_copied(empty_pair);
 
-  x = (double *) avm_value_of_list(operand->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  y = (double *) avm_value_of_list(operand->tail,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  z = (*operator)(*x,*y);
 
-  return avm_list_of_value((void *) &z,sizeof(double),fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-unary_evaluation(operator, operand, fault)
 
-     unary_operator operator;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* the operator is a C function taking a double to a double, and
 
-	the operand is a list representing a double */
 
-{
 
-  list message;
 
-  double *x,y;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  message = NULL;
 
-  x = (double *) avm_value_of_list(operand,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  y = (*operator)(*x);
 
-  return avm_list_of_value((void *) &y,sizeof(double),fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-leq(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* computes the less or equal predicate on an operand
 
-	representing a pair of doubles */
 
-{
 
-  list message;
 
-  double *x,*y;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  message = NULL;
 
-  if (*fault = !operand)
 
-    return avm_copied(empty_pair);
 
-  x = (double *) avm_value_of_list(operand->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  y = (double *) avm_value_of_list(operand->tail,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  return ((*x <= *y) ? avm_copied (shared_cell) : NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-isclass (fp_class, operand, fault)
 
-     int fp_class;
 
-     list operand;
 
-     int *fault;
 
-{
 
-  list message;
 
-  double *x;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  message = NULL;
 
-  x = (double *) avm_value_of_list (operand, &message, fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  return ((fpclassify(*x) == fp_class) ? avm_copied (shared_cell) : NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-avm_strtod (argument, fault)
 
-     list argument;
 
-     int *fault;
 
-
 
-     /* converts a list representing a character string to a list
 
-	representing a double */
 
-{
 
-  list result;
 
-  char *string;
 
-  double d;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  string = avm_standard_unstrung (argument, &result, fault);
 
-  if (*fault = (*fault ? 1 : !!result))
 
-    return result;
 
-  errno = 0;
 
-  d = strtod (string, NULL);
 
-  free (string);
 
-  return avm_list_of_value ((void *) &d, sizeof (double), fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-avm_asprintf (argument, fault)
 
-     list argument;
 
-     int *fault;
 
-
 
-     /* converts a list representing a pair of a floating point format
 
-	conversion specifier and a double to a list representing a
 
-	character string; the specifer is checked for the absense of
 
-	string conversions such as "%s", which would cause a
 
-	segfault */
 
-{
 
-  char *format;
 
-  char *output;
 
-  list result;
 
-  double *value;
 
-  int b,p,d,i,n;   /* state variables for backslash, percent, digit, index counter and string length */
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !argument)
 
-    return avm_copied (empty_pair);
 
-  result = NULL;
 
-  value = (double *) avm_value_of_list (argument->tail, &result, fault);
 
-  if (*fault = (*fault ? 1 : !!result))
 
-    return result;
 
-  format = avm_standard_unstrung (argument->head, &result, fault);
 
-  if (*fault = (*fault ? 1 : !!result))
 
-    return result;
 
-  b = p = d = i = 0;
 
-  n = strlen (format);
 
-  while (*fault ? 0 : (i < n))
 
-    {
 
-      *fault = ((d ? 1 : p) ? ((format[i] == 's') ? 1 : (format[i] == 'S')) : 0);
 
-      d = ((d ? 1 : p) ? ((format[i]=='-') ? 1 : ((format[i]=='.') ? 1 : ((format[i]>='0') ? (format[i]<='9') : 0))) : 0);
 
-      p = (b ? 0 : (format[i] == '%'));
 
-      b = (b ? 0 : (format[i] == '\\'));
 
-      i++;
 
-    }
 
-  output = NULL;
 
-  if (!(*fault = (*fault ? 1 : (asprintf (&output, format, *value) < 0))))
 
-    result = avm_recoverable_standard_strung (output, fault);
 
-  if (output)
 
-    free (output);
 
-  if (format)
 
-    free (format);
 
-  return (*fault ? (result ? result : avm_copied (misprint)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-static double
 
-sum (l,r)
 
-     double l;
 
-     double r;
 
-
 
-{
 
-  double x;
 
-
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  x = l + r;
 
-  return x;
 
-}
 
-
 
-
 
-
 
-
 
-static double
 
-difference (l,r)
 
-     double l;
 
-     double r;
 
-
 
-{
 
-  double x;
 
-
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  x = l - r;
 
-  return x;
 
-}
 
-
 
-
 
-
 
-
 
-static double
 
-inverse_difference (l,r)
 
-     double l;
 
-     double r;
 
-
 
-{
 
-  double x;
 
-
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  x = r - l;
 
-  return x;
 
-}
 
-
 
-
 
-
 
-
 
-static double
 
-product (l,r)
 
-     double l;
 
-     double r;
 
-
 
-{
 
-  double x;
 
-
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  x = l * r;
 
-  return x;
 
-}
 
-
 
-
 
-
 
-
 
-static double
 
-quotient (l,r)
 
-     double l;
 
-     double r;
 
-
 
-{
 
-  double x;
 
-
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  x = l / r;
 
-  return x;
 
-}
 
-
 
-
 
-
 
-
 
-static double
 
-inverse_quotient (l,r)
 
-     double l;
 
-     double r;
 
-
 
-{
 
-  double x;
 
-
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  x = r / l;
 
-  return x;
 
-}
 
-
 
-
 
-
 
-
 
-#endif /* HAVE_FENV */
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_have_math_call (function_name, fault)
 
-  list function_name;
 
-  int *fault;
 
-
 
-/* this reports the availability of a function */
 
-
 
-{
 
-#if HAVE_FENV
 
-  list membership;
 
-  list comparison;
 
-  list result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_math ();
 
-  if (*fault)
 
-    return NULL;
 
-  comparison = avm_binary_comparison (function_name, wild, fault);
 
-  if (*fault)
 
-    return comparison;
 
-  if (comparison)
 
-    {
 
-      avm_dispose(comparison);
 
-      return avm_copied(funs);
 
-    }
 
-  if (!(membership = avm_binary_membership (function_name, funs, fault)) ? 1 : *fault)
 
-    return membership;
 
-  avm_dispose(membership);
 
-  return ((*fault = !(result = avm_recoverable_join(avm_copied(function_name),NULL))) ? avm_copied(memory_overflow) : result);
 
-#endif
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_math_call (function_name, argument, fault)
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-
 
-     /* This figures out what function to call and calls it. */
 
-{
 
-#if HAVE_FENV
 
-  list message;
 
-  int function_number;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (! initialized)
 
-    avm_initialize_math ();
 
-  if (!(function_number = 0xff & (function_name ? function_name->characterization : 0)))
 
-    {
 
-      message = avm_position (function_name, funs, fault);
 
-      if (*fault)
 
-	return message;
 
-      if (*fault = !message)
 
-	return avm_copied (unrecognized_function_name);
 
-      function_number = message->characterization;
 
-      function_name->characterization = function_number;
 
-      avm_dispose (message);
 
-    }
 
-  switch (function_number)
 
-    {
 
-    case 1: return leq (argument, fault);
 
-    case 2: return isclass (FP_NAN, argument, fault);
 
-    case 3: return isclass (FP_INFINITE, argument, fault);
 
-    case 4: return isclass (FP_ZERO, argument, fault);
 
-    case 5: return isclass (FP_SUBNORMAL, argument, fault);
 
-    case 6: return isclass (FP_NORMAL, argument, fault);
 
-    case 7: return avm_strtod (argument, fault);
 
-    case 8: return avm_asprintf (argument, fault);
 
-    case 9: return unary_evaluation ((unary_operator) &sin, argument, fault);
 
-    case 10: return unary_evaluation ((unary_operator) &cos, argument, fault);
 
-    case 11: return unary_evaluation ((unary_operator) &tan, argument, fault);
 
-    case 12: return unary_evaluation ((unary_operator) &exp, argument, fault);
 
-    case 13: return unary_evaluation ((unary_operator) &log, argument, fault);
 
-    case 14: return unary_evaluation ((unary_operator) &sqrt, argument, fault);
 
-    case 15: return unary_evaluation ((unary_operator) &cbrt, argument, fault);
 
-    case 16: return unary_evaluation ((unary_operator) &asin, argument, fault);
 
-    case 17: return unary_evaluation ((unary_operator) &acos, argument, fault);
 
-    case 18: return unary_evaluation ((unary_operator) &atan, argument, fault);
 
-    case 19: return unary_evaluation ((unary_operator) &expm1, argument, fault);
 
-    case 20: return unary_evaluation ((unary_operator) &log1p, argument, fault);
 
-    case 21: return unary_evaluation ((unary_operator) &sinh, argument, fault);
 
-    case 22: return unary_evaluation ((unary_operator) &cosh, argument, fault);
 
-    case 23: return unary_evaluation ((unary_operator) &tanh, argument, fault);
 
-    case 24: return unary_evaluation ((unary_operator) &fabs, argument, fault);
 
-    case 25: return unary_evaluation ((unary_operator) &asinh, argument, fault);
 
-    case 26: return unary_evaluation ((unary_operator) &acosh, argument, fault);
 
-    case 27: return unary_evaluation ((unary_operator) &atanh, argument, fault);
 
-    case 28: return unary_evaluation ((unary_operator) &ceil, argument, fault);
 
-    case 29: return unary_evaluation ((unary_operator) &trunc, argument, fault);
 
-    case 30: return unary_evaluation ((unary_operator) &round, argument, fault);
 
-    case 31: return unary_evaluation ((unary_operator) &floor, argument, fault);
 
-    case 32: return unary_evaluation ((unary_operator) &ceil, argument, fault);
 
-    case 33: return binary_evaluation ((binary_operator) &sum, argument, fault);
 
-    case 34: return binary_evaluation ((binary_operator) &pow, argument, fault);
 
-    case 35: return binary_evaluation ((binary_operator) &hypot, argument, fault);
 
-    case 36: return binary_evaluation ((binary_operator) &atan2, argument, fault);
 
-    case 37: return binary_evaluation ((binary_operator) &product, argument, fault);
 
-    case 38: return binary_evaluation ((binary_operator) &quotient, argument, fault);
 
-    case 39: return binary_evaluation ((binary_operator) &remainder, argument, fault);
 
-    case 40: return binary_evaluation ((binary_operator) &nextafter, argument, fault);
 
-    case 41: return binary_evaluation ((binary_operator) &difference, argument, fault);
 
-    case 42: return binary_evaluation ((binary_operator) &inverse_quotient, argument, fault);
 
-    case 43: return binary_evaluation ((binary_operator) &inverse_difference, argument, fault);
 
-    }
 
-#endif /* HAVE_FENV */
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_math ()
 
-
 
-     /* This initializes some static data structures. */
 
-{
 
-  char *funames[] = {
 
-    "islessequal",
 
-    "isnan",
 
-    "isinfinite",
 
-    "iszero",
 
-    "isubnormal",
 
-    "isnormal",
 
-    "strtod",
 
-    "asprintf",
 
-    "sin",
 
-    "cos",
 
-    "tan",
 
-    "exp",
 
-    "log",
 
-    "sqrt",
 
-    "cbrt",
 
-    "asin",
 
-    "acos",
 
-    "atan",
 
-    "expm1",
 
-    "log1p",
 
-    "sinh",
 
-    "cosh",
 
-    "tanh",
 
-    "fabs",
 
-    "asinh",
 
-    "acosh",
 
-    "atanh",
 
-    "ceil",
 
-    "trunc",
 
-    "round",
 
-    "floor",
 
-    "ceil",
 
-    "add",
 
-    "pow",
 
-    "hypot",
 
-    "atan2",
 
-    "mul",
 
-    "div",
 
-    "remainder",
 
-    "nextafter",
 
-    "sub",
 
-    "vid",
 
-    "bus",
 
-    NULL};            /* add more function names here up to a total of 255 */
 
-  list back;
 
-  int string_number;
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_listfuns ();
 
-  avm_initialize_chrcodes ();
 
-  shared_cell = avm_join (NULL, NULL);
 
-  wild = avm_strung("*");
 
-  empty_pair = avm_join (avm_strung ("empty pair"), NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  misprint = avm_join (avm_strung ("invalid asprintf() specifier"), NULL);
 
-  floating_point_exception = avm_join (avm_strung ("floating point exception"), NULL);
 
-  unrecognized_function_name = avm_join (avm_strung ("unrecognized math function name"), NULL);
 
-  string_number = 0;
 
-  funs = back = NULL;
 
-  while (funames[string_number])
 
-    {
 
-      /* printf("%s\n",funames[string_number]); */
 
-      avm_enqueue (&funs, &back, avm_standard_strung (funames[string_number++]));
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_math ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (funs);
 
-  avm_dispose (wild);
 
-  avm_dispose (misprint);
 
-  avm_dispose (empty_pair);
 
-  avm_dispose (shared_cell);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (floating_point_exception);
 
-  avm_dispose (unrecognized_function_name);
 
-  funs = NULL;
 
-  misprint = NULL;
 
-  empty_pair = NULL;
 
-  shared_cell = NULL;
 
-  memory_overflow = NULL;
 
-  floating_point_exception = NULL;
 
-  unrecognized_function_name = NULL;
 
-}

+ 0 - 32
src/memmove.c
View File 

@@ -1,32 +0,0 @@
 
-/* memmove.c -- copy memory.
 
-   Copy LENGTH bytes from SOURCE to DEST.  Does not null-terminate.
 
-   In the public domain.
 
-   By David MacKenzie <[email protected]>.  */
 
-
 
-#if HAVE_CONFIG_H
 
-# include <config.h>
 
-#endif
 
-
 
-#ifndef MEMMOVE
 
-
 
-char *
 
-memmove (dest, source, length)
 
-     char *dest;
 
-     const char *source;
 
-     unsigned length;
 
-{
 
-  char *d0 = dest;
 
-  if (source < dest)
 
-    /* Moving from low mem to hi mem; start at end.  */
 
-    for (source += length, dest += length; length; --length)
 
-      *--dest = *--source;
 
-  else if (source != dest)
 
-    {
 
-      /* Moving from hi mem to low mem; start at beginning.  */
 
-      for (; length; --length)
 
-        *dest++ = *source++;
 
-    }
 
-  return (void *) d0;
 
-}
 
-
 
-#endif

+ 0 - 1247
src/minpack.c
View File 

@@ -1,1247 +0,0 @@
 
-
 
-/* This file interfaces to some non-linear optimization functions from
 
-   minpack. It needs the minpack c header file, which might be Debian
 
-   specific because the upstream source is in Fortran, or else the
 
-   configuration script will disable it. Best to get the header from
 
-   somewhere and try recompiling if necessary.
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/compare.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/apply.h>
 
-#include <avm/matcon.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/minpack.h>
 
-#if HAVE_MINPACK
 
-#include <math.h>
 
-#include <minpack.h>
 
-#endif
 
-
 
-/* points to a stack of function specifications */
 
-typedef struct spec_stack_node *spec_stack;
 
-
 
-/* a stack of these is needed for re-entrancy */
 
-struct spec_stack_node
 
-{
 
-  list fcn;       /* computes the function being optimized */
 
-  list jac;       /* computes the jacobian */
 
-  int fault;
 
-  list message;
 
-  double *origin;
 
-  list *row_number;
 
-  int number_of_outputs;     /* the output vector length of fcn, in case it's less than the input length */
 
-  spec_stack other_specs;
 
-};
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list minpack_error = NULL;
 
-static list memory_overflow = NULL;
 
-static list bad_minpack_spec = NULL;
 
-static list unrecognized_function_name = NULL;
 
-
 
-/* the stack of function specifications whose top is referenced globally by minpack functions */
 
-static spec_stack top = NULL;
 
-
 
-/* function names as lists of lists of character representations */
 
-static list wild = NULL;
 
-static list funs = NULL;
 
-
 
-#if HAVE_MINPACK
 
-
 
-static list avm_lmder (list, int *);
 
-static list avm_lmdif (list, int *);
 
-static list avm_lmstr (list, int *);
 
-static list avm_hybrd (list, int *);
 
-static list avm_hybrj (list, int *);
 
-
 
-/* the tightest tolerance worth trying */
 
-#define MINIMUM_TOLERANCE 1E-15
 
-
 
-/* the number of retries at bigger tolerances before giving up due to slow convergence */
 
-#define TIME_LIMIT 25
 
-
 
-/* the factor by which the tolerance is increased on each attempt */
 
-#define MAGNIFIER 4.64158883361278
 
-
 
-#define freeif(x) if (x)			\
 
-    free (x)
 
-
 
-
 
-
 
-
 
-
 
-static spec_stack
 
-new_top()
 
-
 
-     /* returns a pointer to the new top of the stack if it can be allocated */
 
-{
 
-  spec_stack next_top;
 
-
 
-  if (!(next_top = (spec_stack) malloc (sizeof(*next_top))))
 
-    return NULL;
 
-  memset (next_top, 0, sizeof(*next_top));
 
-  next_top->other_specs = top;
 
-  return (top = next_top);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-pop_spec()
 
-
 
-/* gets rid of the spec on the top of the stack */
 
-
 
-{
 
-  spec_stack previous_top;
 
-
 
-  if (!top)
 
-    avm_internal_error (2);
 
-  top = (previous_top = top)->other_specs;
 
-  free (previous_top);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-lmder_fcn(m,n,x,fvec,fjac,ldfjac,iflag)
 
-     int *m;
 
-     int *n;
 
-     double *x;
 
-     double *fvec;
 
-     double *fjac;
 
-     int *ldfjac;
 
-     int *iflag;
 
-
 
-     /* the c function to be passed to the minpack lmder function;
 
-	evaluates the function in the global variable top->fcn which
 
-	is expected to take a list of n reals to a list of m reals, or
 
-	evaluates the function in the global variable top->jac, which
 
-	expected to take a list of n reals to a matrix with m rows and
 
-	n columns */
 
-{
 
-  list operand,result,row,col;
 
-  int i,j;
 
-  double *item;
 
-
 
-  operand = (top->fault ? NULL : avm_list_of_vector((void *) x,*n,sizeof(double),&(top->fault)));
 
-  if (top->fault)
 
-    {
 
-      top->message = (top->message ? top->message : operand);
 
-      *iflag = -1;
 
-      return;
 
-    }
 
-  row = result = avm_recoverable_apply(avm_copied((*iflag == 1) ? top->fcn : top->jac),operand,&(top->fault));
 
-  if (top->fault)
 
-    {
 
-      top->message = result;
 
-      *iflag = -1;
 
-      return;
 
-    }
 
-  i = 0;
 
-  operand = NULL;
 
-  while (top->fault ? 0 : (i < *m))
 
-    {
 
-      if (*iflag == 1)
 
-	{
 
-	  item = ((top->fault = !row) ? NULL : (double *) avm_value_of_list(row->head,&operand,&(top->fault)));
 
-	  fvec[i] = ((top->fault) ? 0.0 : (*item - top->origin[i]));
 
-	}
 
-      else if (!((top->fault) = !row))
 
-	{
 
-	  j = 0;
 
-	  col = row->head;
 
-	  while ((top->fault) ? 0 : (j < *n))
 
-	    {
 
-	      item = ((top->fault = !col) ? NULL : (double *) avm_value_of_list(col->head,&operand,&(top->fault)));
 
-	      fjac[(j++ * *m) + i] = (top->fault ? 0.0 : *item);
 
-	      col = (top->fault ? col : col->tail);
 
-	    }
 
-	  top->fault = (top->fault ? 1 : !!col);
 
-	}
 
-      row = (top->fault ? row : row->tail);
 
-      i++;
 
-    }
 
-  avm_dispose (result);
 
-  if (!(top->fault = (top->fault ? 1 : !!row)))
 
-    return;
 
-  top->message = (operand ? operand : avm_copied(bad_minpack_spec));
 
-  *iflag = -1;
 
-  return;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-avm_lmder (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* the operand represents ((f,j),x,y) where f and j are functions
 
-	and x and y are lists of reals of length n and m respectively.
 
-	y is the preferred output of f, not necessarily 0, and x is
 
-	the initial estimate of the input. j is a function that takes
 
-	a list of reals to the jacobian of f represented as a list of
 
-	rows. The jacobian is a matrix whose ith row is the list of
 
-	partial derivatives of the ith output component of f with
 
-	respect to each input component. The result returned is a more
 
-	accurate estimate of the input if one is found, but is empty
 
-	otherwise. Although a different algorithm is used, this
 
-	interface is the same as that of avm_hybrj except that the
 
-	output list may be longer than the input. If the output is
 
-	shorter than the input, (i.e., m < n), this function calls
 
-	avm_hybrj instead. */
 
-{
 
-  int m;
 
-  int n;
 
-  double *x;
 
-  double *fvec;
 
-  double *fjac;
 
-  int ldfjac;
 
-  double ftol;
 
-  double xtol;
 
-  double gtol;
 
-  int maxfev;
 
-  double *diag;
 
-  int mode;
 
-  double factor;
 
-  int nprint;
 
-  int info;
 
-  int nfev;
 
-  int njev;
 
-  int *ipvt;
 
-  double *qtf;
 
-  double *wa1;
 
-  double *wa2;
 
-  double *wa3;
 
-  double *wa4;
 
-  list result;
 
-  int tries;
 
-  spec_stack top;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  if (*fault = !(operand ? (operand->head ? (operand->head->head ? (operand->head->tail ? !!(operand->tail):0):0):0):0))
 
-    return avm_copied (bad_minpack_spec);
 
-  m = (int) avm_length(operand->tail->tail);
 
-  n = (int) avm_length(operand->tail->head);
 
-  if (*fault = !(m ? n : 0))
 
-    return avm_copied (bad_minpack_spec);
 
-  if (n > m)
 
-    return avm_hybrj (operand, fault);
 
-  if (!(top = new_top()))
 
-    return avm_copied (memory_overflow);
 
-  top->fcn = operand->head->head;
 
-  top->jac = operand->head->tail;
 
-  x = (double *) avm_vector_of_list(operand->tail->head,sizeof(double),&result,fault);
 
-  fvec = (double *) malloc(sizeof(double) * m);
 
-  fjac = (double *) malloc(sizeof(double) * m * n);
 
-  ldfjac = m;
 
-  ftol = MINIMUM_TOLERANCE;
 
-  xtol = MINIMUM_TOLERANCE;
 
-  gtol = 0.0;
 
-  maxfev = 100 * (n + 1);
 
-  diag = (double *) malloc(sizeof(double) * n);
 
-  mode = 1;
 
-  factor = 100.0;
 
-  nprint = 0;
 
-  ipvt = (int *) malloc(sizeof(int) * n);
 
-  qtf = (double *) malloc(sizeof(double) * n);
 
-  wa1 = (double *) malloc(sizeof(double) * n);
 
-  wa2 = (double *) malloc(sizeof(double) * n);
 
-  wa3 = (double *) malloc(sizeof(double) * n);
 
-  wa4 = (double *) malloc(sizeof(double) * m);
 
-  top->origin = (*fault ? NULL : (double *) avm_vector_of_list(operand->tail->tail,sizeof(double),&result,fault));
 
-  if (!*fault)
 
-    *fault = !(x? (fvec? (fjac? (diag? (ipvt? (qtf? (wa1? (wa2? (wa3? (wa4 ? !!(top->origin):0):0):0):0):0):0):0):0):0):0);
 
-  top->message = NULL;
 
-  tries = info = top->fault = 0;
 
-  while (*fault ? 0 : (!((info == 1) ? 1 : ((info == 2) ? 1 : (info == 3))) ? (tries++ < TIME_LIMIT) : 0))
 
-    {
 
-      lmder_ (&lmder_fcn, &m, &n, x, fvec, fjac, &ldfjac, &ftol, &xtol, &gtol, &maxfev, diag, &mode, &factor, &nprint, &info,
 
-	      &nfev, &njev, ipvt, qtf, wa1, wa2, wa3, wa4);
 
-      if (!info)
 
-	avm_internal_error (102);
 
-      if (*fault = (top->fault ? 1 : !!(top->message)))
 
-	{
 
-	  if (result ? top->message : NULL)
 
-	    avm_dispose (top->message);
 
-	  else
 
-	    result = (top->message ? top->message : avm_copied(bad_minpack_spec));
 
-	}
 
-      ftol = ftol * MAGNIFIER;
 
-      xtol = xtol * MAGNIFIER;
 
-    }
 
-  freeif (fvec);
 
-  freeif (fjac);
 
-  freeif (diag);
 
-  freeif (ipvt);
 
-  freeif (qtf);
 
-  freeif (wa1);
 
-  freeif (wa2);
 
-  freeif (wa3);
 
-  freeif (wa4);
 
-  freeif (top->origin);
 
-  pop_spec ();
 
-  if (*fault ? 0 : ((info == 1) ? 1 : ((info == 2) ? 1 : (info == 3))))
 
-    result = avm_list_of_vector((void *) x,n,sizeof(double),fault);
 
-  freeif (x);
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-lmstr_fcn(m,n,x,fvec,fjrow,iflag)
 
-     int *m;
 
-     int *n;
 
-     double *x;
 
-     double *fvec;
 
-     double *fjrow;
 
-     int *iflag;
 
-
 
-     /* the c function to be passed to the minpack lmstr function;
 
-	evaluates the function in the global variable top->fcn, which
 
-	is expected to take a list of n reals to a list of m reals, or
 
-	evaluates the function in the global variable top->jac, which
 
-	is expected to take a pair (i,<x1..xn>) of a natural in the
 
-	range 0..m-1 and a list of n reals to a list of n reals; also
 
-	assumes the global variable top->row_number has been
 
-	initialized at least to size m */
 
-{
 
-  list operand,result,row;
 
-  int i;
 
-  double *item;
 
-
 
-  if (top->fault = (top->fault ? 1 : ((*iflag <= 0) ? 1 : (*iflag > (*m + 1)))))
 
-    {
 
-      top->message = (top->message ? top->message : avm_copied(minpack_error));
 
-      *iflag = -1;
 
-      return;
 
-    }
 
-  operand = avm_list_of_vector((void *) x,*n,sizeof(double),&(top->fault));
 
-  if (top->fault ? 0 : (*iflag > 1))
 
-    operand = avm_recoverable_join(avm_copied(top->row_number[(*iflag) - 2]),operand);
 
-  if (top->fault = (top->fault ? 1 : !operand))
 
-    {
 
-      top->message = (operand ? operand : avm_copied(memory_overflow));
 
-      *iflag = -1;
 
-      return;
 
-    }
 
-  row = result = avm_recoverable_apply(avm_copied((*iflag == 1) ? top->fcn : top->jac), operand, &(top->fault));
 
-  if (top->fault)
 
-    {
 
-      top->message = result;
 
-      *iflag = -1;
 
-      return;
 
-    }
 
-  i = 0;
 
-  operand = NULL;
 
-  while (top->fault ? 0 : (i < ((*iflag == 1) ? *m : *n)))
 
-    {
 
-      item = ((top->fault = !row) ? NULL : (double *) avm_value_of_list(row->head,&operand,&(top->fault)));
 
-      if (*iflag == 1)
 
-	fvec[i] = (top->fault ? 0.0 : (*item - top->origin[i]));
 
-      else
 
-	fjrow[i] = (top->fault ? 0.0 : *item);
 
-      row = (top->fault ? row : row->tail);
 
-      i++;
 
-    }
 
-  avm_dispose (result);
 
-  if (!(top->fault = (top->fault ? 1 : !!row)))
 
-    return;
 
-  top->message = (operand ? operand : avm_copied(bad_minpack_spec));
 
-  *iflag = -1;
 
-  return;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-avm_lmstr (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* the operand represents ((f,j),x,y) where f and j are functions
 
-        and x and y are lists of reals of length n and m respectively.
 
-        y is the preferred output of f, not necessarily 0, and x is
 
-        the initial estimate of the input. j is a function that takes
 
-        row number and a list of reals to the corresponding row of the
 
-        jacobian of f. The jacobian is a matrix whose ith row is the
 
-        list of partial derivatives of the ith output component of f
 
-        with respect to each input component. The result returned is a
 
-        more accurate estimate of the input if one is found, but is
 
-        empty otherwise. This interface is the same as that of lmder
 
-        except that jacobian function has a different calling
 
-        convention allowing less memory to be used, appropriately for
 
-        problems with a very large output vector and a moderate sized
 
-        input vector. It's an error for m to be less than n. */
 
-{
 
-  int m;
 
-  int n;
 
-  double *x;
 
-  double *fvec;
 
-  double *fjac;
 
-  int ldfjac;
 
-  double ftol;
 
-  double xtol;
 
-  double gtol;
 
-  int maxfev;
 
-  double *diag;
 
-  int mode;
 
-  double factor;
 
-  int nprint;
 
-  int info;
 
-  int nfev;
 
-  int njev;
 
-  int *ipvt;
 
-  double *qtf;
 
-  double *wa1;
 
-  double *wa2;
 
-  double *wa3;
 
-  double *wa4;
 
-  list result;
 
-  int tries;
 
-  int i;
 
-  spec_stack top;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  if (*fault = !(operand ? (operand->head ? (operand->head->head ? (operand->head->tail ? !!(operand->tail):0):0):0):0))
 
-    return avm_copied (bad_minpack_spec);
 
-  m = (int) avm_length(operand->tail->tail);
 
-  n = (int) avm_length(operand->tail->head);
 
-  if (*fault = !(m ? (n ? (n <= m) : 0) : 0))
 
-    return avm_copied (bad_minpack_spec);
 
-  if (!(top = new_top()))
 
-    return avm_copied (memory_overflow);
 
-  top->fcn = operand->head->head;
 
-  top->jac = operand->head->tail;
 
-  x = (double *) avm_vector_of_list(operand->tail->head,sizeof(double),&result,fault);
 
-  fvec = (double *) malloc(sizeof(double) * m);
 
-  fjac = (double *) malloc(sizeof(double) * m * n);
 
-  ldfjac = m;
 
-  ftol = MINIMUM_TOLERANCE;
 
-  xtol = MINIMUM_TOLERANCE;
 
-  gtol = 0.0;
 
-  maxfev = 100 * (n + 1);
 
-  diag = (double *) malloc(sizeof(double) * n);
 
-  mode = 1;
 
-  factor = 100.0;
 
-  nprint = 0;
 
-  ipvt = (int *) malloc(sizeof(int) * n);
 
-  qtf = (double *) malloc(sizeof(double) * n);
 
-  wa1 = (double *) malloc(sizeof(double) * n);
 
-  wa2 = (double *) malloc(sizeof(double) * n);
 
-  wa3 = (double *) malloc(sizeof(double) * n);
 
-  wa4 = (double *) malloc(sizeof(double) * m);
 
-  top->origin = (*fault ? NULL : (double *) avm_vector_of_list(operand->tail->tail,sizeof(double),&result,fault));
 
-  top->row_number = (*fault ? NULL : avm_row_number_array(m,fault));
 
-  if (!(*fault = (*fault ? 1 : !(top->origin ? top->row_number : NULL))))
 
-    *fault = !(x ? (fvec ? (fjac ? (diag ? (ipvt ? (qtf ? (wa1 ? (wa2 ? (wa3 ? !!wa4 : 0):0):0):0):0):0):0):0):0);
 
-  top->message = NULL;
 
-  tries = info = top->fault = 0;
 
-  while (*fault ? 0 : (!((info == 1) ? 1 : ((info == 2) ? 1 : (info == 3))) ? (tries++ < TIME_LIMIT) : 0))
 
-    {
 
-      top->fault = 0;
 
-      top->message = NULL;
 
-      lmstr_ (&lmstr_fcn, &m, &n, x, fvec, fjac, &ldfjac, &ftol, &xtol, &gtol, &maxfev, diag, &mode, &factor, &nprint, &info,
 
-	      &nfev, &njev, ipvt, qtf, wa1, wa2, wa3, wa4);
 
-      if (!info)
 
-	avm_internal_error (103);
 
-      if (*fault = (top->fault ? 1 : !!(top->message)))
 
-	{
 
-	  if (result ? top->message : NULL)
 
-	    avm_dispose (top->message);
 
-	  else
 
-	    result = (top->message ? top->message : avm_copied(bad_minpack_spec));
 
-	}
 
-      xtol = xtol * MAGNIFIER;
 
-      ftol = ftol * MAGNIFIER;
 
-    }
 
-  if(top->row_number)
 
-      avm_dispose_rows(m,top->row_number);
 
-  freeif (fvec);
 
-  freeif (fjac);
 
-  freeif (diag);
 
-  freeif (ipvt);
 
-  freeif (qtf);
 
-  freeif (wa1);
 
-  freeif (wa2);
 
-  freeif (wa3);
 
-  freeif (wa4);
 
-  freeif (top->origin);
 
-  pop_spec ();
 
-  if (*fault ? 0 : ((info == 1) ? 1 : ((info == 2) ? 1 : (info == 3))))
 
-    result = avm_list_of_vector((void *) x,n,sizeof(double),fault);
 
-  freeif (x);
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-lmdif_fcn(m,n,x,fvec,iflag)
 
-     int *m;
 
-     int *n;
 
-     double *x;
 
-     double *fvec;
 
-     int *iflag;
 
-
 
-     /* the c function to be passed to the minpack lmdif function;
 
-	evaluates the function in the global variable top->fcn, which is
 
-	expected to take a list of n reals to a list of m reals */
 
-{
 
-  list operand,result,row;
 
-  int i;
 
-  double *item;
 
-
 
-  operand = (top->fault ? NULL : avm_list_of_vector((void *) x,*n,sizeof(double),&(top->fault)));
 
-  if (top->fault)
 
-    {
 
-      top->message = (top->message ? top->message : operand);
 
-      *iflag = -1;
 
-      return;
 
-    }
 
-  row = result = avm_recoverable_apply(avm_copied(top->fcn),operand,&(top->fault));
 
-  if (top->fault)
 
-    {
 
-      top->message = result;
 
-      *iflag = -1;
 
-      return;
 
-    }
 
-  operand = NULL;
 
-  i = 0;
 
-  while (top->fault ? 0 : (i < *m))
 
-    {
 
-      item = ((top->fault = !row) ? NULL : (double *) avm_value_of_list(row->head,&operand,&(top->fault)));
 
-      fvec[i] = (top->fault ? 0.0 : (*item - top->origin[i]));
 
-      row = (top->fault ? row : row->tail);
 
-      i++;
 
-    }
 
-  avm_dispose (result);
 
-  if (!(top->fault = (top->fault ? 1 : !!row)))
 
-    return;
 
-  top->message = (operand ? operand : avm_copied(bad_minpack_spec));
 
-  *iflag = -1;
 
-  return;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-avm_lmdif (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* the operand represents (f,x,y) where f is a function and x and
 
-        y are lists of reals of length n and m respectively.  y is the
 
-        preferred output of f, not necessarily 0, and x is the initial
 
-        estimate of the input. The result returned is a more accurate
 
-        estimate of the input if one is found, but is empty otherwise.
 
-        This function differs from lmder because no jacobian is
 
-        specified, which may make it less efficient or less accurate.
 
-        If y is shorter than x (i.e., m < n), this function calls
 
-        avm_hybrd instead. */
 
-{
 
-  int m;
 
-  int n;
 
-  double *x;
 
-  double *fvec;
 
-  double ftol;
 
-  double xtol;
 
-  double gtol;
 
-  int maxfev;
 
-  double epsfcn;
 
-  double *diag;
 
-  int mode;
 
-  double factor;
 
-  int nprint;
 
-  int info;
 
-  int nfev;
 
-  double *fjac;
 
-  int ldfjac;
 
-  int *ipvt;
 
-  double *qtf;
 
-  double *wa1;
 
-  double *wa2;
 
-  double *wa3;
 
-  double *wa4;
 
-  list result;
 
-  int tries;
 
-  spec_stack top;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  if (*fault = !(operand ? (operand->head ? !!(operand->tail) : 0) : 0))
 
-    return avm_copied (bad_minpack_spec);
 
-  m = (int) avm_length(operand->tail->tail);
 
-  n = (int) avm_length(operand->tail->head);
 
-  if (*fault = !(m ? n : 0))
 
-    return avm_copied (bad_minpack_spec);
 
-  if (n > m)
 
-    return avm_hybrd (operand, fault);
 
-  if (!(top = new_top()))
 
-    return avm_copied (memory_overflow);
 
-  top->fcn = operand->head;
 
-  x = (double *) avm_vector_of_list(operand->tail->head,sizeof(double),&result,fault);
 
-  fvec = (double *) malloc(sizeof(double) * m);
 
-  ftol = MINIMUM_TOLERANCE;
 
-  xtol = MINIMUM_TOLERANCE;
 
-  gtol = 0.0;
 
-  maxfev = 100 * (n + 1);
 
-  epsfcn = 0.0;
 
-  diag = (double *) malloc(sizeof(double) * n);
 
-  mode = 1;
 
-  factor = 100.0;
 
-  nprint = 0;
 
-  fjac = (double *) malloc(sizeof(double) * n * m);
 
-  ldfjac = m;
 
-  ipvt = (int *) malloc(sizeof(int) * n);
 
-  qtf = (double *) malloc(sizeof(double) * n);
 
-  wa1 = (double *) malloc(sizeof(double) * n);
 
-  wa2 = (double *) malloc(sizeof(double) * n);
 
-  wa3 = (double *) malloc(sizeof(double) * n);
 
-  wa4 = (double *) malloc(sizeof(double) * m);
 
-  top->origin = (*fault ? NULL : (double *) avm_vector_of_list(operand->tail->tail,sizeof(double),&result,fault));
 
-  if (!*fault)
 
-    *fault = !(x? (fvec? (diag? (fjac? (ipvt? (qtf? (wa1? (wa2? (wa3? (wa4? !!(top->origin):0):0):0):0):0):0):0):0):0):0);
 
-  top->message = NULL;
 
-  tries = info = top->fault = 0;
 
-  while (*fault ? 0 : (!((info == 1) ? 1 : ((info == 2) ? 1 : (info == 3))) ? (tries++ < TIME_LIMIT) : 0))
 
-    {
 
-      lmdif_ (&lmdif_fcn, &m, &n, x, fvec, &ftol, &xtol, &gtol, &maxfev, &epsfcn,diag, &mode, &factor, &nprint, &info, &nfev,
 
-	      fjac, &ldfjac, ipvt, qtf, wa1, wa2, wa3, wa4);
 
-      if (!info)
 
-	avm_internal_error (104);
 
-      if (*fault = (top->fault ? 1 : !!(top->message)))
 
-	{
 
-	  if (result ? top->message : NULL)
 
-	    avm_dispose (top->message);
 
-	  else
 
-	    result = (top->message ? top->message : avm_copied(bad_minpack_spec));
 
-	}
 
-      xtol = xtol * MAGNIFIER;
 
-      ftol = ftol * MAGNIFIER;
 
-    }
 
-  freeif (fvec);
 
-  freeif (fjac);
 
-  freeif (diag);
 
-  freeif (ipvt);
 
-  freeif (qtf);
 
-  freeif (wa1);
 
-  freeif (wa2);
 
-  freeif (wa3);
 
-  freeif (wa4);
 
-  freeif (top->origin);
 
-  pop_spec ();
 
-  if (*fault ? 0 : ((info == 1) ? 1 : ((info == 2) ? 1 : (info == 3))))
 
-    result = avm_list_of_vector((void *) x,n,sizeof(double),fault);
 
-  freeif (x);
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-hybrd_fcn(n,x,fvec,iflag)
 
-     int *n;
 
-     double *x;
 
-     double *fvec;
 
-     int *iflag;
 
-
 
-     /* the c function to be passed to the minpack hybrd function;
 
-	evaluates the function described by the global variable
 
-	top->fcn, which is expected to take a list of n reals to a
 
-	list of at most n reals, and passes the difference between
 
-	that result and the global variable top->origin to minpack. If
 
-	the output length is less than n, the vector passed to minpack
 
-	is padded with zeros. The global variable
 
-	top->number_of_outputs must match the actual output list
 
-	length. */
 
-{
 
-  list operand,result,row;
 
-  int i;
 
-  double *item;
 
-
 
-  operand = (top->fault ? NULL : avm_list_of_vector((void *) x,*n,sizeof(double),&(top->fault)));
 
-  if (top->fault)
 
-    {
 
-      top->message = (top->message ? top->message : operand);
 
-      *iflag = -1;
 
-      return;
 
-    }
 
-  row = result = avm_recoverable_apply(avm_copied(top->fcn),operand,&(top->fault));
 
-  if (top->fault)
 
-    {
 
-      top->message = result;
 
-      *iflag = -1;
 
-      return;
 
-    }
 
-  operand = NULL;
 
-  i = 0;
 
-  while (top->fault ? 0 : (i < top->number_of_outputs))
 
-    {
 
-      item = ((top->fault = !row) ? NULL : (double *) avm_value_of_list(row->head,&operand,&(top->fault)));
 
-      fvec[i] = (top->fault ? 0.0 : (*item - top->origin[i]));
 
-      row = (top->fault ? row : row->tail);
 
-      i++;
 
-    }
 
-  avm_dispose (result);
 
-  while (i < *n)
 
-    fvec[i++] = 0.0;
 
-  if (!(top->fault = (top->fault ? 1 : !!row)))
 
-    return;
 
-  top->message = (operand ? operand : avm_copied(bad_minpack_spec));
 
-  *iflag = -1;
 
-  return;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-avm_hybrd (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* the operand represents (f,x,y) where f is a function and x and
 
-	y are lists of reals. y is the preferred output of f, not
 
-	necessarily 0, and x is the initial estimate of the input. The
 
-	result returned is a more accurate estimate of the input
 
-	consistent with the given output if one is found, but is empty
 
-	otherwise. If the output list is longer than the input list,
 
-	avm_lmdif is called instead, and if it's shorter, it's
 
-	padded automatically. */
 
-{
 
-  int n;
 
-  double *x;
 
-  double *fvec;
 
-  double xtol;
 
-  int maxfev;
 
-  int ml;
 
-  int mu;
 
-  double epsfcn;
 
-  double *diag;
 
-  int mode;
 
-  double factor;
 
-  int nprint;
 
-  int info;
 
-  int nfev;
 
-  double *fjac;
 
-  int ldfjac;
 
-  double *r;
 
-  int lr;
 
-  double *qtf;
 
-  double *wa1;
 
-  double *wa2;
 
-  double *wa3;
 
-  double *wa4;
 
-  list result;
 
-  int tries;
 
-  spec_stack top;
 
-  int number_of_outputs;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  if (*fault = !(operand ? (operand->head ? operand->tail : NULL) : NULL))
 
-    return avm_copied (bad_minpack_spec);
 
-  n = (int) avm_length (operand->tail->head);
 
-  if (n < (number_of_outputs = (int) avm_length (operand->tail->tail)))
 
-    return avm_lmdif (operand, fault);
 
-  if (!(top = new_top()))
 
-    return avm_copied (memory_overflow);
 
-  top->number_of_outputs = number_of_outputs;
 
-  top->fcn = operand->head;
 
-  x = (double *) avm_vector_of_list(operand->tail->head,sizeof(double),&result,fault);
 
-  fvec = (double *) malloc(sizeof(double) * n);
 
-  xtol = MINIMUM_TOLERANCE;
 
-  maxfev = 200 * (n + 1);
 
-  ml = n - 1;
 
-  mu = n - 1;
 
-  epsfcn = 0.0;
 
-  diag = (double *) malloc(sizeof(double) * n);
 
-  mode = 1;
 
-  factor = 100.0;
 
-  nprint = 0;
 
-  ldfjac = n;
 
-  fjac = (double *) malloc(sizeof(double) * ldfjac * n);
 
-  lr = (n * (n + 1)) / 2;
 
-  r = (double *) malloc(sizeof(double) * lr);
 
-  qtf = (double *) malloc(sizeof(double) * n);
 
-  wa1 = (double *) malloc(sizeof(double) * n);
 
-  wa2 = (double *) malloc(sizeof(double) * n);
 
-  wa3 = (double *) malloc(sizeof(double) * n);
 
-  wa4 = (double *) malloc(sizeof(double) * n);
 
-  top->origin = (*fault ? NULL : (double *) avm_vector_of_list(operand->tail->tail,sizeof(double),&result,fault));
 
-  if (!*fault)
 
-    *fault = !(x? (fvec? (diag? (fjac? (r? (qtf? (wa1? (wa2? (wa3? (wa4? !!(top->origin):0):0):0):0):0):0):0):0):0):0);
 
-  top->message = NULL;
 
-  tries = info = top->fault = 0;
 
-  while (*fault ? 0 : ((info != 1) ? (tries++ < TIME_LIMIT) : 0))
 
-    {
 
-      hybrd_ (&hybrd_fcn, &n, x, fvec, &xtol, &maxfev, &ml, &mu, &epsfcn, diag, &mode, &factor, &nprint, &info, &nfev, fjac,
 
-	      &ldfjac, r, &lr, qtf, wa1, wa2, wa3, wa4);
 
-      if (!info)
 
-	avm_internal_error (100);
 
-      if (*fault = (top->fault ? 1 : !!(top->message)))
 
-	{
 
-	  if (result ? top->message : NULL)
 
-	    avm_dispose (top->message);
 
-	  else
 
-	    result = (top->message ? top->message : avm_copied(bad_minpack_spec));
 
-	}
 
-      xtol = xtol * MAGNIFIER;
 
-    }
 
-  freeif (fvec);
 
-  freeif (diag);
 
-  freeif (fjac);
 
-  freeif (r);
 
-  freeif (qtf);
 
-  freeif (wa1);
 
-  freeif (wa2);
 
-  freeif (wa3);
 
-  freeif (wa4);
 
-  freeif (top->origin);
 
-  pop_spec ();
 
-  if (*fault ? 0 : (info == 1))
 
-    result = avm_list_of_vector((void *) x,n,sizeof(double),fault);
 
-  freeif (x);
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-hybrj_fcn(n,x,fvec,fjac,ldfjac,iflag)
 
-     int *n;
 
-     double *x;
 
-     double *fvec;
 
-     double *fjac;
 
-     int *ldfjac;
 
-     int *iflag;
 
-
 
-     /* the c function to be passed to the minpack hybrj function;
 
-	evaluates the function described by the global variable
 
-	top->fcn, which is expected to take a list of n reals to a
 
-	list of at most n reals, or evaluates the function described
 
-	by the global variable top->jac, which is expected to take a
 
-	list of n reals to list of n lists of at most n reals. If the
 
-	actual output length is less than n, it must match the global
 
-	variable top->number_of_outputs, and the arrays passed to
 
-	minpack are padded with zeros. */
 
-{
 
-  list operand,result,row,col;
 
-  int i,j;
 
-  double *item;
 
-
 
-  operand = (top->fault ? NULL : avm_list_of_vector((void *) x,*n,sizeof(double),&(top->fault)));
 
-  if (top->fault)
 
-    {
 
-      top->message = (top->message ? top->message : operand);
 
-      *iflag = -1;
 
-      return;
 
-    }
 
-  row = result = avm_recoverable_apply(avm_copied((*iflag == 1) ? top->fcn : top->jac), operand, &(top->fault));
 
-  if (top->fault)
 
-    {
 
-      top->message = result;
 
-      *iflag = -1;
 
-      return;
 
-    }
 
-  i = 0;
 
-  operand = NULL;
 
-  while (top->fault ? 0 : (i < top->number_of_outputs))
 
-    {
 
-      if (*iflag == 1)
 
-	{
 
-	  item = ((top->fault = !row) ? NULL : (double *) avm_value_of_list(row->head, &operand, &(top->fault)));
 
-	  fvec[i] = (top->fault ? 0.0 : (*item - top->origin[i]));
 
-	}
 
-      else if (!(top->fault = !row))
 
-	{
 
-	  j = 0;
 
-	  col = row->head;
 
-	  while (top->fault ? 0 : (j < *n))
 
-	    {
 
-	      item = ((top->fault = !col) ? NULL : (double *) avm_value_of_list(col->head, &operand, &(top->fault)));
 
-	      fjac[(j++ * *n) + i] = (top->fault ? 0.0 : *item);
 
-	      col = (top->fault ? col : col->tail);
 
-	    }
 
-	  top->fault = (top->fault ? 1 : !!col);
 
-	}
 
-      row = (top->fault ? row : row->tail);
 
-      i++;
 
-    }
 
-  while (i < *n)
 
-    {
 
-      if (*iflag == 1)
 
-	fvec[i] = 0.0;
 
-      else
 
-	{
 
-	  j = 0;
 
-	  while (j < *n)
 
-	    fjac[(j++ * *n) + i] = 0.0;
 
-	}
 
-      i++;
 
-    }
 
-  avm_dispose (result);
 
-  if (!(top->fault = (top->fault ? 1 : !!row)))
 
-    return;
 
-  top->message = (operand ? operand : avm_copied (bad_minpack_spec));
 
-  *iflag = -1;
 
-  return;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-avm_hybrj (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* the operand represents ((f,j),x,y) where f and j are functions
 
-	and x and y are lists of reals of length n. y is the preferred
 
-	output of f, not necessarily 0, and x is the initial estimate
 
-	of the input. j is a function that takes a list of reals to
 
-	the jacobian of f represented as a list of rows. The jacobian
 
-	is a matrix whose ith row is the list of partial derivatives
 
-	of the ith output component of f with respect to each input
 
-	component. The result returned is a more accurate estimate of
 
-	the input if one is found, but is empty otherwise. If the
 
-	output list is longer than the input list, avm_lmder is called
 
-	instead, and if it's shorter it's automatically padded. */
 
-{
 
-  int n;
 
-  double *x;
 
-  double *fvec;
 
-  double *fjac;
 
-  int ldfjac;
 
-  double xtol;
 
-  int maxfev;
 
-  double *diag;
 
-  int mode;
 
-  double factor;
 
-  int nprint;
 
-  int info;
 
-  int nfev;
 
-  int njev;
 
-  double *r;
 
-  int lr;
 
-  double *qtf;
 
-  double *wa1;
 
-  double *wa2;
 
-  double *wa3;
 
-  double *wa4;
 
-  list result;
 
-  int tries;
 
-  spec_stack top;
 
-  int number_of_outputs;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  if (*fault = !(operand ? (operand->head ? (operand->head->head ? (operand->head->tail ? !!(operand->tail):0):0):0):0))
 
-    return avm_copied (bad_minpack_spec);
 
-  n = (int) avm_length(operand->tail->head);
 
-  if (n < (number_of_outputs = (int) avm_length (operand->tail->tail)))
 
-    return avm_lmder (operand, fault);
 
-  if (!(top = new_top()))
 
-    return avm_copied (memory_overflow);
 
-  top->fcn = operand->head->head;
 
-  top->jac = operand->head->tail;
 
-  top->number_of_outputs = number_of_outputs;
 
-  x = (double *) avm_vector_of_list(operand->tail->head,sizeof(double),&result,fault);
 
-  fvec = (double *) malloc(sizeof(double) * n);
 
-  fjac = (double *) malloc(sizeof(double) * n * n);
 
-  ldfjac = n;
 
-  xtol = MINIMUM_TOLERANCE;
 
-  maxfev = 200 * (n + 1);
 
-  diag = (double *) malloc(sizeof(double) * n);
 
-  mode = 1;
 
-  factor = 100.0;
 
-  nprint = 0;
 
-  lr = (n * (n + 1))/2;
 
-  r = (double *) malloc(sizeof(double) * lr);
 
-  qtf = (double *) malloc(sizeof(double) * n);
 
-  wa1 = (double *) malloc(sizeof(double) * n);
 
-  wa2 = (double *) malloc(sizeof(double) * n);
 
-  wa3 = (double *) malloc(sizeof(double) * n);
 
-  wa4 = (double *) malloc(sizeof(double) * n);
 
-  top->origin = (*fault ? NULL : (double *) avm_vector_of_list(operand->tail->tail,sizeof(double),&result,fault));
 
-  if (!*fault)
 
-    *fault = !(x? (fvec? (diag? (fjac? (r? (qtf? (wa1? (wa2? (wa3? (wa4? !!(top->origin):0):0):0):0):0):0):0):0):0):0);
 
-  top->message = NULL;
 
-  tries = info = top->fault = 0;
 
-  while (*fault ? 0 : ((info != 1) ? (tries++ < TIME_LIMIT) : 0))
 
-    {
 
-      hybrj_ (&hybrj_fcn, &n, x, fvec, fjac, &ldfjac, &xtol, &maxfev, diag, &mode, &factor, &nprint, &info, &nfev, &njev, r,
 
-              &lr, qtf, wa1, wa2, wa3, wa4);
 
-      if (!info)
 
-	avm_internal_error (101);
 
-      if (*fault = (top->fault ? 1 : !!(top->message)))
 
-	{
 
-	  if (result ? top->message : NULL)
 
-	    avm_dispose (top->message);
 
-	  else
 
-	    result = (top->message ? top->message : avm_copied(bad_minpack_spec));
 
-	}
 
-      xtol = xtol * MAGNIFIER;
 
-    }
 
-  freeif (fvec);
 
-  freeif (diag);
 
-  freeif (fjac);
 
-  freeif (r);
 
-  freeif (qtf);
 
-  freeif (wa1);
 
-  freeif (wa2);
 
-  freeif (wa3);
 
-  freeif (wa4);
 
-  freeif (top->origin);
 
-  pop_spec ();
 
-  if (*fault ? 0 : (info == 1))
 
-    result = avm_list_of_vector((void *) x,n,sizeof(double),fault);
 
-  freeif (x);
 
-  return (*fault ? (result ? result : avm_copied(memory_overflow)) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-#endif
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_have_minpack_call (function_name, fault)
 
-     list function_name;
 
-     int *fault;
 
-
 
-     /* this reports the availability of a function */
 
-{
 
-#if HAVE_MINPACK
 
-  list membership;
 
-  list comparison;
 
-  list result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_minpack ();
 
-  if (*fault)
 
-    return NULL;
 
-  comparison = avm_binary_comparison (function_name, wild, fault);
 
-  if (*fault)
 
-    return comparison;
 
-  if (comparison)
 
-    {
 
-      avm_dispose(comparison);
 
-      return avm_copied(funs);
 
-    }
 
-  if (!(membership = avm_binary_membership (function_name, funs, fault)) ? 1 : *fault)
 
-    return membership;
 
-  avm_dispose(membership);
 
-  return ((*fault = !(result = avm_recoverable_join(avm_copied(function_name),NULL))) ? avm_copied(memory_overflow) : result);
 
-#endif
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_minpack_call (function_name, argument, fault)
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-{
 
-#if HAVE_MINPACK
 
-  list message;
 
-  int function_number;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (! initialized)
 
-    avm_initialize_minpack ();
 
-  if (!(function_number = 0xff & (function_name ? function_name->characterization : 0)))
 
-    {
 
-      message = avm_position (function_name, funs, fault);
 
-      if (*fault)
 
-	return message;
 
-      if (*fault = !message)
 
-	return avm_copied (unrecognized_function_name);
 
-      function_number = message->characterization;
 
-      function_name->characterization = function_number;
 
-      avm_dispose (message);
 
-    }
 
-  switch (function_number)
 
-    {
 
-    case 1: return avm_lmder (argument, fault);
 
-    case 2: return avm_lmstr (argument, fault);
 
-    case 3: return avm_lmdif (argument, fault);
 
-    case 4: return avm_hybrd (argument, fault);
 
-    case 5: return avm_hybrj (argument, fault);
 
-    }
 
-#endif /* HAVE_MINPACK */
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_minpack ()
 
-
 
-     /* This initializes some static data structures. */
 
-{
 
-  char *funames[] = {
 
-    "lmder",
 
-    "lmstr",
 
-    "lmdif",
 
-    "hybrd",
 
-    "hybrj",
 
-    NULL};            /* add more function names here up to a total of 255 */
 
-  list back;
 
-  int string_number;
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_matcon ();
 
-  avm_initialize_chrcodes ();
 
-  wild = avm_strung("*");
 
-  minpack_error = avm_join (avm_strung ("minpack error"), NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  bad_minpack_spec = avm_join (avm_strung ("bad minpack specification"), NULL);
 
-  unrecognized_function_name = avm_join (avm_strung ("unrecognized minpack function name"), NULL);
 
-  string_number = 0;
 
-  funs = back = NULL;
 
-  while (funames[string_number])
 
-    avm_enqueue (&funs, &back, avm_standard_strung (funames[string_number++]));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_minpack ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-  counter unreclaimed;
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (funs);
 
-  avm_dispose (wild);
 
-  avm_dispose (minpack_error);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (bad_minpack_spec);
 
-  avm_dispose (unrecognized_function_name);
 
-  funs = NULL;
 
-  wild = NULL;
 
-  minpack_error = NULL;
 
-  memory_overflow = NULL;
 
-  bad_minpack_spec = NULL;
 
-  unrecognized_function_name = NULL;
 
-  unreclaimed = 0;
 
-  while (top)
 
-    {
 
-      unreclaimed++;
 
-      top = top->other_specs;
 
-    }
 
-  if (unreclaimed)
 
-    avm_reclamation_failure ("spec stacks", unreclaimed);
 
-}

+ 0 - 1534
src/mpfr.c
View File 

@@ -1,1534 +0,0 @@
 
-
 
-/* this file interfaces to arbitrary precision math routines in libmpfr
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/compare.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/mpfr.h>
 
-#include <time.h>
 
-
 
-#ifndef HAVE_MEMMOVE
 
-extern void 
-*memmove(char *dest, const char *source, unsigned length)
 
-#endif
 
-
 
-#define DEFAULT_PREC 160   /* used by the dbl2mp function */
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list shared_cell = NULL;
 
-static list mpfr_error = NULL;
 
-static list bad_mpfr_spec = NULL;
 
-static list mpfr_overflow = NULL;
 
-static list memory_overflow = NULL;
 
-static list inf_string = NULL;
 
-static list ninf_string = NULL;
 
-static list nan_string = NULL;
 
-static list unrecognized_function_name = NULL;
 
-
 
-/* function names as lists of lists of character representations */
 
-static list wild = NULL;
 
-static list funs = NULL;
 
-
 
-/* kinds of numbers */
 
-static list unsigned_nan = NULL;
 
-static list negative_inf = NULL;
 
-static list negative_zero = NULL;
 
-static list negative_regular = NULL;
 
-static list positive_inf = NULL;
 
-static list positive_zero = NULL;
 
-static list positive_regular = NULL;
 
-
 
-#if HAVE_MPFR
 
-#if HAVE_GMP
 
-
 
-static gmp_randstate_t state;
 
-
 
-typedef int (*mpfr_mutator)(mpfr_t);
 
-typedef int (*mpfr_unary_operator)(mpfr_t,mpfr_t,mp_rnd_t);
 
-typedef int (*mpfr_binary_operator)(mpfr_t,mpfr_t,mpfr_t,mp_rnd_t);
 
-typedef int (*mpfr_unary_predicate)(mpfr_t);
 
-typedef int (*mpfr_binary_predicate)(mpfr_t,mpfr_t);
 
-typedef int (*mpfr_binary_ui)(mpfr_t,mpfr_t,unsigned long,mp_rnd_t);
 
-typedef int (*mpfr_constant)(mpfr_t,mp_rnd_t);
 
-
 
-#endif
 
-#endif
 
-
 
-
 
-avm_mpfr_ptr
 
-avm_mpfr_of_list(operand, message, fault)
 
-     list operand;
 
-     list *message;
 
-     int *fault;
 
-
 
-     /* This function is analogous to the avm_value_of_list function
 
-        in listfuns.c but is specific to lists representing mpfr
 
-        numbers. The operand is required to be in the form
 
-        ((prec,(sign,kind)),((esign,exponent),mantissa)), where sign
 
-        and esign are boolean, mantissa is a list of characters, and
 
-        the others are naturals as lists of booleans lsb first. The
 
-        value field of the mantissa caches the array of limbs used in
 
-        the mpfr representation and the value field of the whole
 
-        operand caches the record referenced by the avm_mpfr_ptr,
 
-        whose mantissa field must point to the array referenced by the
 
-        value field of the operand's mantissa. The caches need not be
 
-        initialized on entry (i.e., they can be NULL pointers) but
 
-        they will be initialized to the results generated by this
 
-        function as a side effect. */
 
-{
 
-#if HAVE_MPFR
 
-  int kind;
 
-  mp_prec_t prec;
 
-  mp_exp_t exponent;
 
-  void *mantissa;
 
-  avm_mpfr_ptr x;
 
-
 
-  *message = NULL;
 
-  exponent = prec = kind = 0;
 
-  *fault = ! (operand?(operand->head?(operand->head->tail?(operand->tail?operand->tail->head:NULL):NULL):NULL):NULL);
 
-  if (*fault ? NULL : operand->value)
 
-    {
 
-      *fault = !(operand->tail->tail->value);
 
-      if (!*fault)
 
-	*fault = (((void *) operand->tail->tail->value) != mpfr_custom_get_mantissa(*((avm_mpfr_ptr) operand->value)));
 
-      if (!*fault)
 
-	return ((avm_mpfr_ptr) operand->value);
 
-    }
 
-  if (!*fault)
 
-    {
 
-      prec = (mp_prec_t) avm_counter(operand->head->head);
 
-      kind = (int) avm_counter(operand->head->tail->tail);
 
-      if (operand->head->tail->head)
 
-	{
 
-	  kind = -kind;
 
-	  *fault = (operand->head->tail->head->head ? 1 : !!(operand->head->tail->head->tail));
 
-	}
 
-      exponent = (mp_exp_t) avm_counter(operand->tail->head->tail);
 
-      if (*fault ? NULL : operand->tail->head->head)
 
-	{
 
-	  exponent = -exponent;
 
-	  *fault = (operand->tail->head->head->head ? 1 : !!(operand->tail->head->head->tail));
 
-	}
 
-      *fault = (*fault ? 1 : (((prec < MPFR_PREC_MIN) ? 1 : (prec > MPFR_PREC_MAX))));
 
-    }
 
-  if (!*fault)
 
-    mantissa = (void *) avm_value_of_list(operand->tail->tail,message,fault);
 
-  if (*fault)
 
-    {
 
-      *message = (*message ? *message : avm_copied(bad_mpfr_spec));
 
-      return NULL;
 
-    }
 
-  x = (avm_mpfr_ptr) malloc(sizeof(mpfr_t));
 
-  if (*fault = !x)
 
-    {
 
-      *message = avm_copied(memory_overflow);
 
-      return NULL;
 
-    }
 
-  mpfr_custom_init_set(*x, kind, exponent, prec, mantissa);
 
-  operand->value = (void *) x;
 
-  return x;
 
-#else
 
-  *message = avm_copied(mpfr_error);
 
-  *fault = 1;
 
-  return NULL;
 
-#endif
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_list_of_mpfr(x, fault)
 
-     avm_mpfr_ptr x;
 
-     int *fault;
 
-
 
-     /* This function is analogous to the avm_list_of_value function
 
-	in listfuns.c but is specific to lists representing mpfr
 
-	numbers. The list it returns is in the form
 
-	((prec,(sign,kind)),((esign,exponent),mantissa)) as specified
 
-	above, with caches initialized. */
 
-{
 
-#if HAVE_MPFR
 
-  mp_prec_t prec;
 
-  mp_exp_t exponent;
 
-  void *mantissa;
 
-  list prec_sign_kind,esign_exponent,result;
 
-
 
-  mantissa = mpfr_custom_get_mantissa(*x);
 
-  if (*fault = !mantissa)
 
-    return avm_copied(bad_mpfr_spec);
 
-  prec = mpfr_get_prec(*x);
 
-  prec_sign_kind = NULL;
 
-  switch (mpfr_custom_get_kind(*x))
 
-    {
 
-    case MPFR_NAN_KIND:
 
-      prec_sign_kind = avm_recoverable_join(avm_natural((counter) prec),avm_copied(unsigned_nan));
 
-      break;
 
-    case MPFR_INF_KIND:
 
-      prec_sign_kind = avm_recoverable_join(avm_natural((counter) prec),avm_copied(positive_inf));
 
-      break;
 
-    case MPFR_ZERO_KIND:
 
-      prec_sign_kind = avm_recoverable_join(avm_natural((counter) prec),avm_copied(positive_zero));
 
-      break;
 
-    case MPFR_REGULAR_KIND:
 
-      prec_sign_kind = avm_recoverable_join(avm_natural((counter) prec),avm_copied(positive_regular));
 
-      break;
 
-    case -MPFR_INF_KIND:
 
-      prec_sign_kind = avm_recoverable_join(avm_natural((counter) prec),avm_copied(negative_inf));
 
-      break;
 
-    case -MPFR_ZERO_KIND:
 
-      prec_sign_kind = avm_recoverable_join(avm_natural((counter) prec),avm_copied(negative_zero));
 
-      break;
 
-    case -MPFR_REGULAR_KIND:
 
-      prec_sign_kind = avm_recoverable_join(avm_natural((counter) prec),avm_copied(negative_regular));
 
-      break;
 
-    default:
 
-      *fault = 1;
 
-    }
 
-  if (*fault ? 1 : (*fault = (prec < MPFR_PREC_MIN ? 1 : (prec > MPFR_PREC_MAX))))
 
-    {
 
-      avm_dispose(prec_sign_kind);
 
-      return avm_copied(bad_mpfr_spec);
 
-    }
 
-  if (*fault = ! (prec_sign_kind ? prec_sign_kind->head : NULL))
 
-    {
 
-      avm_dispose(prec_sign_kind);
 
-      free(mantissa);
 
-      free(x);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  exponent = mpfr_custom_get_exp(*x);
 
-  if (exponent == 0)
 
-    esign_exponent = avm_copied(shared_cell);
 
-  else
 
-    {
 
-      if (exponent < 0)
 
-	esign_exponent = avm_recoverable_join(avm_copied(shared_cell),avm_natural((counter) -exponent));
 
-      else
 
-	esign_exponent = avm_recoverable_join(NULL,avm_natural((counter) exponent));
 
-      *fault = ! (esign_exponent ? esign_exponent->tail : NULL);
 
-    }
 
-  result = (*fault ? NULL : avm_list_of_value((void *) mantissa,mpfr_custom_get_size(prec),fault));
 
-  if (*fault = (*fault ? 1 : !result))
 
-    {
 
-      avm_dispose(prec_sign_kind);
 
-      avm_dispose(esign_exponent);
 
-      free(mantissa);
 
-      free(*x);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  result->discontiguous = 1;
 
-  result = avm_recoverable_join(prec_sign_kind,avm_recoverable_join(esign_exponent,result));
 
-  if (*fault = ! (result ? result->tail : NULL))
 
-    {
 
-      avm_dispose(result);
 
-      free(mantissa);
 
-      free(*x);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  result->tail->discontiguous = 1;
 
-  result->discontiguous = 1;
 
-  mpfr_custom_move(*x,(void *) result->tail->tail->value);
 
-  result->value = (void *) x;
 
-  free(mantissa);
 
-  return result;
 
-#else
 
-  *fault = 1;
 
-  return avm_copied(mpfr_error);
 
-#endif
 
-}
 
-
 
-
 
-
 
-#if HAVE_MPFR
 
-
 
-
 
-static list
 
-unary_evaluation(operator, operand, fault)
 
-     mpfr_unary_operator operator;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* performs a unary operation on mpfr numbers */
 
-{
 
-  avm_mpfr_ptr x;
 
-  avm_mpfr_ptr y;
 
-  list message;
 
-  mp_prec_t prec;
 
-  void *mantissa;
 
-
 
-  message = NULL;
 
-  x = avm_mpfr_of_list(operand,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  if (!x)
 
-    avm_internal_error(61);
 
-  prec = mpfr_get_prec(*x);
 
-  if (*fault = ! (mantissa = (void *) malloc(mpfr_custom_get_size(prec))))
 
-    return avm_copied(memory_overflow);
 
-  if (*fault = !(y = (avm_mpfr_ptr) malloc(sizeof(mpfr_t))))
 
-    {
 
-      free(mantissa);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  mpfr_custom_init(mantissa,prec);
 
-  mpfr_custom_init_set(*y,MPFR_NAN_KIND,0,prec,mantissa);
 
-  (*operator)(*y,*x,GMP_RNDN);
 
-  return avm_list_of_mpfr(y,fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-binary_ui_evaluation(operator, operand, fault)
 
-     mpfr_binary_ui operator;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* performs a binary operation on mpfr numbers with integers */
 
-{
 
-  avm_mpfr_ptr x;
 
-  unsigned long y;
 
-  avm_mpfr_ptr z;
 
-  list message;
 
-  mp_prec_t prec;
 
-  void *mantissa;
 
-
 
-  message = NULL;
 
-  if (*fault = !operand)
 
-    return avm_copied(bad_mpfr_spec);
 
-  x = avm_mpfr_of_list(operand->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  if (!x)
 
-    avm_internal_error(63);
 
-  y = (unsigned long) avm_counter(operand->tail);
 
-  prec = mpfr_get_prec(*x);
 
-  if (*fault = ! (mantissa = (void *) malloc(mpfr_custom_get_size(prec))))
 
-    return avm_copied(memory_overflow);
 
-  if (*fault = !(z = (avm_mpfr_ptr) malloc(sizeof(mpfr_t))))
 
-    {
 
-      free(mantissa);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  mpfr_custom_init(mantissa,prec);
 
-  mpfr_custom_init_set(*z,MPFR_NAN_KIND,0,prec,mantissa);
 
-  (*operator)(*z,*x,y,GMP_RNDN);
 
-  return avm_list_of_mpfr(z,fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-binary_evaluation(operator, operand, fault)
 
-     mpfr_binary_operator operator;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* This performs a binary operation on mpfr numbers. The
 
-	precision of the result is the higher of the two input
 
-	precisions. Although mathematically it makes more sense for it
 
-	to be the lower precision, this convention is more convenient
 
-	for functions with embedded constants (e.g., a function that
 
-	adds 1 to everything) because they can be used on arguments of
 
-	any precision without needing different versions. */
 
-{
 
-  avm_mpfr_ptr x,y,z;
 
-  list message;
 
-  mp_prec_t x_prec,y_prec,prec;
 
-  void *mantissa;
 
-
 
-  message = NULL;
 
-  if (*fault = !operand)
 
-    return avm_copied(bad_mpfr_spec);
 
-  x = avm_mpfr_of_list(operand->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  y = avm_mpfr_of_list(operand->tail,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  if (x ? !y : 1)
 
-    avm_internal_error(62);
 
-  x_prec = mpfr_get_prec(*x);
 
-  y_prec = mpfr_get_prec(*y);
 
-  prec = ((x_prec < y_prec) ? y_prec : x_prec);
 
-  if (*fault = ! (mantissa = (void *) malloc(mpfr_custom_get_size(prec))))
 
-    return avm_copied(memory_overflow);
 
-  if (*fault = !(z = (avm_mpfr_ptr) malloc(sizeof(*z))))
 
-    {
 
-      free(mantissa);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  mpfr_custom_init(mantissa,prec);
 
-  mpfr_custom_init_set(*z,MPFR_NAN_KIND,0,prec,mantissa);
 
-  (*operator)(*z,*x,*y,GMP_RNDN);
 
-  return avm_list_of_mpfr(z,fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-vid_evaluation(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* special case of binary evaluation for the inverse quotient,
 
-	which isn't defined in the mpfr library */
 
-{
 
-  avm_mpfr_ptr x,y,z;
 
-  list message;
 
-  mp_prec_t x_prec,y_prec,prec;
 
-  void *mantissa;
 
-
 
-  message = NULL;
 
-  if (*fault = !operand)
 
-    return avm_copied(bad_mpfr_spec);
 
-  x = avm_mpfr_of_list(operand->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  y = avm_mpfr_of_list(operand->tail,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  if (x ? !y : 1)
 
-    avm_internal_error(106);
 
-  x_prec = mpfr_get_prec(*x);
 
-  y_prec = mpfr_get_prec(*y);
 
-  prec = ((x_prec < y_prec) ? y_prec : x_prec);
 
-  if (*fault = ! (mantissa = (void *) malloc(mpfr_custom_get_size(prec))))
 
-    return avm_copied(memory_overflow);
 
-  if (*fault = !(z = (avm_mpfr_ptr) malloc(sizeof(*z))))
 
-    {
 
-      free(mantissa);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  mpfr_custom_init(mantissa,prec);
 
-  mpfr_custom_init_set(*z,MPFR_NAN_KIND,0,prec,mantissa);
 
-  mpfr_div(*z,*y,*x,GMP_RNDN);
 
-  return avm_list_of_mpfr(z,fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-bus_evaluation(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* special case of binary evaluation for the inverse difference,
 
-	which isn't defined in the mpfr library */
 
-{
 
-  avm_mpfr_ptr x,y,z;
 
-  list message;
 
-  mp_prec_t x_prec,y_prec,prec;
 
-  void *mantissa;
 
-
 
-  message = NULL;
 
-  if (*fault = !operand)
 
-    return avm_copied(bad_mpfr_spec);
 
-  x = avm_mpfr_of_list(operand->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  y = avm_mpfr_of_list(operand->tail,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  if (x ? !y : 1)
 
-    avm_internal_error(108);
 
-  x_prec = mpfr_get_prec(*x);
 
-  y_prec = mpfr_get_prec(*y);
 
-  prec = ((x_prec < y_prec) ? y_prec : x_prec);
 
-  if (*fault = ! (mantissa = (void *) malloc(mpfr_custom_get_size(prec))))
 
-    return avm_copied(memory_overflow);
 
-  if (*fault = !(z = (avm_mpfr_ptr) malloc(sizeof(*z))))
 
-    {
 
-      free(mantissa);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  mpfr_custom_init(mantissa,prec);
 
-  mpfr_custom_init_set(*z,MPFR_NAN_KIND,0,prec,mantissa);
 
-  mpfr_sub(*z,*y,*x,GMP_RNDN);
 
-  return avm_list_of_mpfr(z,fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-unary_predicate_evaluation(operator, operand, fault)
 
-     mpfr_unary_predicate operator;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* evaluates a unary predicate on mpfr numbers */
 
-{
 
-  avm_mpfr_ptr x;
 
-  list message;
 
-
 
-  message = NULL;
 
-  x = avm_mpfr_of_list(operand,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  return ((*operator)(*x) ? avm_copied(shared_cell) : NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-binary_predicate_evaluation(operator, operand, fault)
 
-     mpfr_binary_predicate operator;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* evaluates a binary predicate on mpfr numbers */
 
-{
 
-  avm_mpfr_ptr x,y;
 
-  list message;
 
-
 
-  message = NULL;
 
-  if (*fault = !operand)
 
-    return avm_copied(bad_mpfr_spec);
 
-  x = avm_mpfr_of_list(operand->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  y = avm_mpfr_of_list(operand->tail,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  return ((*operator)(*x,*y) ? avm_copied(shared_cell) : NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-constant_evaluation(operator, operand, fault)
 
-     mpfr_constant operator;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* returns a list representing an mpfr constant evaluated to a
 
-	specified precision */
 
-{
 
-  avm_mpfr_ptr y;
 
-  list message;
 
-  mp_prec_t prec;
 
-  void *mantissa;
 
-
 
-  prec = (mp_prec_t) avm_counter(operand);
 
-  if (*fault = (prec < MPFR_PREC_MIN ? 1 : (prec > MPFR_PREC_MAX)))
 
-    return avm_copied(bad_mpfr_spec);
 
-  if (*fault = ! (mantissa = (void *) malloc(mpfr_custom_get_size(prec))))
 
-    return avm_copied(memory_overflow);
 
-  if (*fault = !(y = (avm_mpfr_ptr) malloc(sizeof(*y))))
 
-    {
 
-      free(mantissa);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  mpfr_custom_init(mantissa,prec);
 
-  mpfr_custom_init_set(*y,MPFR_NAN_KIND,0,prec,mantissa);
 
-  (*operator)(*y,GMP_RNDN);
 
-  return avm_list_of_mpfr(y,fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-infinity(direction, operand, fault)
 
-     int direction;
 
-     list operand;
 
-     int *fault;
 
-{
 
-  avm_mpfr_ptr y;
 
-  list message;
 
-  mp_prec_t prec;
 
-  void *mantissa;
 
-
 
-  prec = (mp_prec_t) avm_counter(operand);
 
-  if (*fault = (prec < MPFR_PREC_MIN ? 1 : (prec > MPFR_PREC_MAX)))
 
-    return avm_copied(bad_mpfr_spec);
 
-  if (*fault = ! (mantissa = (void *) malloc(mpfr_custom_get_size(prec))))
 
-    return avm_copied(memory_overflow);
 
-  if (*fault = !(y = (avm_mpfr_ptr) malloc(sizeof(*y))))
 
-    {
 
-      free(mantissa);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  mpfr_custom_init(mantissa,prec);
 
-  mpfr_custom_init_set(*y,MPFR_NAN_KIND,0,prec,mantissa);
 
-  mpfr_set_inf(*y,direction);
 
-  return avm_list_of_mpfr(y,fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-nan(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-{
 
-  avm_mpfr_ptr y;
 
-  list message;
 
-  mp_prec_t prec;
 
-  void *mantissa;
 
-
 
-  prec = (mp_prec_t) avm_counter(operand);
 
-  if (*fault = (prec < MPFR_PREC_MIN ? 1 : (prec > MPFR_PREC_MAX)))
 
-    return avm_copied(bad_mpfr_spec);
 
-  if (*fault = ! (mantissa = (void *) malloc(mpfr_custom_get_size(prec))))
 
-    return avm_copied(memory_overflow);
 
-  if (*fault = !(y = (avm_mpfr_ptr) malloc(sizeof(*y))))
 
-    {
 
-      free(mantissa);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  mpfr_custom_init(mantissa,prec);
 
-  mpfr_custom_init_set(*y,MPFR_NAN_KIND,0,prec,mantissa);
 
-  mpfr_set_nan(*y);
 
-  return avm_list_of_mpfr(y,fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-precision(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* returns the precision of an mpfr number as a natural */
 
-{
 
-  if (*fault = !(operand ? operand->head : NULL))
 
-    return avm_copied(bad_mpfr_spec);
 
-  return avm_copied (operand->head->head);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-sin_cos(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* returns the mpfr sin_cos function of an argument, currently
 
-	the only mpfr function that returns a pair of values */
 
-{
 
-  avm_mpfr_ptr x,y,z;
 
-  list message;
 
-  mp_prec_t prec;
 
-  void *x_mantissa;
 
-  void *y_mantissa;
 
-  list x_list,y_list,result;
 
-
 
-  message = NULL;
 
-  z = avm_mpfr_of_list(operand,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  if (!z)
 
-    avm_internal_error(64);
 
-  prec = mpfr_get_prec(*z);
 
-  if (*fault = ! (x_mantissa = (void *) malloc(mpfr_custom_get_size(prec))))
 
-    return avm_copied(memory_overflow);
 
-  if (*fault = !(x = (avm_mpfr_ptr) malloc(sizeof(*x))))
 
-    {
 
-      free(x_mantissa);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  if (*fault = ! (y_mantissa = (void *) malloc(mpfr_custom_get_size(prec))))
 
-    return avm_copied(memory_overflow);
 
-  if (*fault = !(y = (avm_mpfr_ptr) malloc(sizeof(*y))))
 
-    {
 
-      free(x);
 
-      free(x_mantissa);
 
-      free(y_mantissa);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  mpfr_custom_init(x_mantissa,prec);
 
-  mpfr_custom_init(y_mantissa,prec);
 
-  mpfr_custom_init_set(*x,MPFR_NAN_KIND,0,prec,x_mantissa);
 
-  mpfr_custom_init_set(*y,MPFR_NAN_KIND,0,prec,y_mantissa);
 
-  mpfr_sin_cos(*y,*x,*z,GMP_RNDN);
 
-  x_list = avm_list_of_mpfr(x,fault);
 
-  if (*fault)
 
-    {
 
-      free(y);
 
-      free(y_mantissa);
 
-      return x_list;
 
-    }
 
-  y_list = avm_list_of_mpfr(y,fault);
 
-  if (*fault)
 
-    {
 
-      avm_dispose(x_list);
 
-      return y_list;
 
-    }
 
-  result = avm_recoverable_join(y_list,x_list);
 
-  return ((*fault = !result) ? avm_copied(memory_overflow) : result);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-mutator_evaluation(operator, operand, fault)
 
-     mpfr_mutator operator;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* implements a non-destructive interface to mpfr functions with
 
-	no rounding mode parameter that modify their argument in place
 
-	(e.g., nextabove and nextbelow) */
 
-{
 
-  avm_mpfr_ptr x;
 
-  avm_mpfr_ptr y;
 
-  list message;
 
-  mp_prec_t prec;
 
-  void *mantissa;
 
-
 
-  message = NULL;
 
-  x = avm_mpfr_of_list(operand,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  if (!x)
 
-    avm_internal_error(65);
 
-  prec = mpfr_get_prec(*x);
 
-  if (*fault = ! (mantissa = (void *) malloc(mpfr_custom_get_size(prec))))
 
-    return avm_copied(memory_overflow);
 
-  if (*fault = !(y = (avm_mpfr_ptr) malloc(sizeof(mpfr_t))))
 
-    {
 
-      free(mantissa);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  mpfr_custom_init(mantissa,prec);
 
-  mpfr_custom_init_set(*y,MPFR_NAN_KIND,0,prec,mantissa);
 
-  mpfr_set(*y,*x,GMP_RNDN);
 
-  (*operator)(*y);
 
-  return avm_list_of_mpfr(y,fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-grow(direction, operand, fault)
 
-     int direction;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* returns a copy of the operand with different precision */
 
-{
 
-  avm_mpfr_ptr x,y;
 
-  list message;
 
-  mp_prec_t prec,x_prec;
 
-  void *mantissa;
 
-  int growth;
 
-
 
-  message = NULL;
 
-  if (*fault = !operand)
 
-    return avm_copied(bad_mpfr_spec);
 
-  x = avm_mpfr_of_list(operand->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  if (!x)
 
-    avm_internal_error(66);
 
-  growth = (int) avm_counter(operand->tail);
 
-  if (*fault = (operand->tail ? !growth : 0))
 
-    return avm_copied(memory_overflow);
 
-  x_prec = mpfr_get_prec(*x);
 
-  if (direction > 0)
 
-    {
 
-      prec = x_prec + growth;
 
-      prec = ((prec > MPFR_PREC_MAX) ? MPFR_PREC_MAX : prec);
 
-      prec = ((prec < x_prec) ? MPFR_PREC_MAX : prec);
 
-    }
 
-  else
 
-    {
 
-      prec = x_prec - growth;
 
-      prec = ((prec < MPFR_PREC_MIN) ? MPFR_PREC_MIN : prec);
 
-      prec = ((prec > x_prec) ? MPFR_PREC_MIN : prec);
 
-    }
 
-  if (*fault = ! (mantissa = (void *) malloc(mpfr_custom_get_size(prec))))
 
-    return avm_copied(memory_overflow);
 
-  memset (mantissa, 0, mpfr_custom_get_size (prec));
 
-  if (*fault = !(y = (avm_mpfr_ptr) malloc(sizeof(*y))))
 
-    {
 
-      free(mantissa);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  mpfr_custom_init(mantissa,prec);
 
-  mpfr_custom_init_set(*y,MPFR_ZERO_KIND,0,prec,mantissa);
 
-  mpfr_set(*y,*x,GMP_RNDN);
 
-  return avm_list_of_mpfr(y,fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-dbl2mp(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* conversion from IEEE double precision to mpfr format with a
 
-	specified precision; the operand should represent a double precision number;
 
-	the precision of the result is a hard coded constant DEFAULT_PREC */
 
-{
 
-  avm_mpfr_ptr y;
 
-  double *x;
 
-  list message;
 
-  void *mantissa;
 
-
 
-  if (*fault = !operand)
 
-    return avm_copied(bad_mpfr_spec);
 
-  message = NULL;
 
-  x = (double *) avm_value_of_list(operand,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return avm_copied(message);
 
-  if (*fault = ! (mantissa = (void *) malloc(mpfr_custom_get_size(DEFAULT_PREC))))
 
-    return avm_copied(memory_overflow);
 
-  if (*fault = !(y = (avm_mpfr_ptr) malloc(sizeof(*y))))
 
-    {
 
-      free(mantissa);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  mpfr_custom_init(mantissa,DEFAULT_PREC);
 
-  mpfr_custom_init_set(*y,MPFR_NAN_KIND,0,DEFAULT_PREC,mantissa);
 
-  mpfr_set_d(*y,*x,GMP_RNDN);
 
-  return avm_list_of_mpfr(y,fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-mp2dbl(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* converts an mpfr number to a double */
 
-{
 
-  avm_mpfr_ptr x;
 
-  double y;
 
-  list message;
 
-
 
-  message = NULL;
 
-  x = avm_mpfr_of_list(operand, &message, fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  if (!x)
 
-    avm_internal_error(68);
 
-  y = mpfr_get_d(*x,GMP_RNDN);
 
-  return avm_list_of_value((void *) &y,sizeof(double),fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-str2mp(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* operand should be of the form (prec,string) */
 
-{
 
-  char *string;
 
-  list message;
 
-  avm_mpfr_ptr y;
 
-  mpfr_prec_t prec;
 
-  void *mantissa;
 
-
 
-  if (*fault = !operand)
 
-    return avm_copied(bad_mpfr_spec);
 
-  message = NULL;
 
-  string = avm_standard_unstrung (operand->tail, &message, fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  avm_dispose(message);
 
-  prec = (mp_prec_t) avm_counter(operand->head);
 
-  if (prec < MPFR_PREC_MIN)
 
-    prec = MPFR_PREC_MIN;
 
-  if (*fault = (prec > MPFR_PREC_MAX))
 
-    {
 
-      free(string);
 
-      return avm_copied(bad_mpfr_spec);
 
-    }
 
-  if (*fault = ! (mantissa = (void *) malloc(mpfr_custom_get_size(prec))))
 
-    {
 
-      free(string);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  if (*fault = !(y = (avm_mpfr_ptr) malloc(sizeof(*y))))
 
-    {
 
-      free(mantissa);
 
-      free(string);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  mpfr_custom_init(mantissa,prec);
 
-  mpfr_custom_init_set(*y,MPFR_NAN_KIND,0,prec,mantissa);
 
-  if (*fault = (mpfr_set_str(*y,string,0,GMP_RNDN) != 0))
 
-    {
 
-      free(string);
 
-      free(mantissa);
 
-      free(y);
 
-      return avm_copied(bad_mpfr_spec);
 
-    }
 
-  free(string);
 
-  return avm_list_of_mpfr(y,fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-mp2str(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* converts an mpfr number to a string in standard exponential
 
-        notation, with sufficiently many digits to express the
 
-        precision */
 
-{
 
-  avm_mpfr_ptr x;
 
-  list message;
 
-  size_t n;
 
-  char *str;
 
-  mp_exp_t exponent;
 
-  char exp_str[81];
 
-  list result;
 
-
 
-  message = NULL;
 
-  x = avm_mpfr_of_list(operand,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  if (!x)
 
-    avm_internal_error(69);
 
-  if (mpfr_nan_p(*x))
 
-    return avm_copied(nan_string);
 
-  else if (mpfr_inf_p(*x))
 
-    {
 
-      if (mpfr_sgn(*x) > 0)
 
-	return avm_copied(inf_string);
 
-      else
 
-	return avm_copied(ninf_string);
 
-    }
 
-  n = 2 + ((mpfr_get_prec(*x) * 3) / 10);
 
-  n = (n > 2 ? n : 3);
 
-  if (*fault = ! (str = (char *) malloc(n + 84)))
 
-    return avm_copied(memory_overflow);
 
-  if (*fault = (mpfr_get_str(str,&exponent,10,n,*x,GMP_RNDN) != str))
 
-    {
 
-      free(str);
 
-      return avm_copied(mpfr_error);
 
-    }
 
-  if (str[0] == '-')
 
-    {
 
-      memmove(&str[3],&str[2],strlen(str) - 1);
 
-      str[2] = '.';
 
-    }
 
-  else
 
-    {
 
-      memmove(&str[2],&str[1],strlen(str));
 
-      str[1] = '.';
 
-    }
 
-  exp_str[0] = 'E';
 
-  exp_str[1] = '+';
 
-  if ((exponent - 1 > 9) ? 1 : (exponent - 1 < -9))
 
-    snprintf(&exp_str[(exponent < 0) ? 1 : 2],80,"%ld",exponent - 1);
 
-  else if (exponent > 0)
 
-    snprintf(&exp_str[2],80,"0%ld",exponent - 1);
 
-  else if (mpfr_zero_p(*x))
 
-    {
 
-      exp_str[2] = '0';
 
-      exp_str[3] = '0';
 
-      exp_str[4] = '\0';
 
-    }
 
-  else 
-    {
 
-      exp_str[1] = '-';
 
-      exp_str[2] = '0';
 
-      snprintf(&exp_str[3],80,"%ld",1 - exponent);
 
-    }
 
-  strncat(str,exp_str,81);
 
-  result = avm_recoverable_strung(str,fault);
 
-  free(str);
 
-  if (*fault = (*fault ? 1 : !result))
 
-    {
 
-      avm_dispose(result);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-nat2mp(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* The operand represents a natural number as a list of bits lsb
 
-	first. The result is a list representing an mpfr number of the
 
-	implied precision. */
 
-{
 
-  avm_mpfr_ptr y;
 
-  list temporary,reversal;
 
-  mp_prec_t prec;
 
-  void *mantissa;
 
-
 
-  prec = (mp_prec_t) avm_recoverable_length (operand);
 
-  if (*fault = (operand ? !prec : 0))
 
-    return avm_copied (mpfr_overflow);
 
-  if (prec < MPFR_PREC_MIN)
 
-    prec = MPFR_PREC_MIN;
 
-  if (*fault = (prec > MPFR_PREC_MAX))
 
-    return avm_copied(mpfr_overflow);
 
-  if (*fault = ! (mantissa = (void *) malloc(mpfr_custom_get_size(prec))))
 
-    return avm_copied(memory_overflow);
 
-  if (*fault = !(y = (avm_mpfr_ptr) malloc(sizeof(*y))))
 
-    {
 
-      free(mantissa);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  mpfr_custom_init(mantissa,prec);
 
-  mpfr_custom_init_set(*y,MPFR_ZERO_KIND,0,prec,mantissa);
 
-  reversal = NULL;
 
-  while (operand)
 
-    {
 
-      operand = (temporary = operand)->tail;
 
-      temporary->tail = reversal;
 
-      reversal = temporary;
 
-    }
 
-  while (reversal)
 
-    {
 
-      mpfr_mul_ui (*y, *y, 2, GMP_RNDN);
 
-      if (reversal->head)
 
-	mpfr_add_ui (*y, *y, 1, GMP_RNDN);
 
-      reversal = (temporary = reversal)->tail;
 
-      temporary->tail = operand;
 
-      operand = temporary;
 
-    }
 
-  return avm_list_of_mpfr(y,fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-#if HAVE_GMP
 
-
 
-
 
-static list
 
-approximately_equal(operand, fault)
 
-     list operand;
 
-     int* fault;
 
-
 
-     /* operand should be of the form (prec,x,y), where prec is a
 
-	natural. The result is a true list if x and y have the same
 
-	exponent and agree in the most significant prec bits. */
 
-{
 
-  unsigned long prec;
 
-  avm_mpfr_ptr x,y;
 
-  list message;
 
-
 
-  if (*fault = ! (operand ? operand->tail : NULL))
 
-    return avm_copied(bad_mpfr_spec);
 
-  prec = (unsigned long) avm_counter(operand->head);
 
-  message = NULL;
 
-  x = avm_mpfr_of_list(operand->tail->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  y = avm_mpfr_of_list(operand->tail->tail,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  return (mpfr_eq(*x,*y,prec) ? avm_copied(shared_cell) : NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-urandomb(operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* the operand is a natural specifying the precision */
 
-{
 
-  avm_mpfr_ptr y;
 
-  list message;
 
-  mp_prec_t prec;
 
-  void *mantissa;
 
-
 
-  prec = (mp_prec_t) avm_counter(operand);
 
-  if (*fault = (prec < MPFR_PREC_MIN ? 1 : (prec > MPFR_PREC_MAX)))
 
-    return avm_copied(bad_mpfr_spec);
 
-  if (*fault = ! (mantissa = (void *) malloc(mpfr_custom_get_size(prec))))
 
-    return avm_copied(memory_overflow);
 
-  if (*fault = !(y = (avm_mpfr_ptr) malloc(sizeof(*y))))
 
-    {
 
-      free(mantissa);
 
-      return avm_copied(memory_overflow);
 
-    }
 
-  mpfr_custom_init(mantissa,prec);
 
-  mpfr_custom_init_set(*y,MPFR_NAN_KIND,0,prec,mantissa);
 
-  mpfr_urandomb(*y,state);
 
-  return avm_list_of_mpfr(y,fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-#endif /* HAVE_GMP */
 
-#endif /* HAVE_MPFR */
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_have_mpfr_call (function_name,fault)
 
-     list function_name;
 
-     int *fault;
 
-
 
-/* this reports the availability of a function */
 
-{
 
-#if HAVE_MPFR
 
-  list membership;
 
-  list comparison;
 
-  list result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_mpfr ();
 
-  if (*fault)
 
-    return NULL;
 
-  comparison = avm_binary_comparison (function_name, wild, fault);
 
-  if (*fault)
 
-    return comparison;
 
-  if (comparison)
 
-    {
 
-      avm_dispose(comparison);
 
-      return avm_copied(funs);
 
-    }
 
-  if (!(membership = avm_binary_membership (function_name, funs, fault)) ? 1 : *fault)
 
-    return membership;
 
-  avm_dispose(membership);
 
-  return ((*fault = !(result = avm_recoverable_join(avm_copied(function_name),NULL))) ? avm_copied(memory_overflow) : result);
 
-#endif
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_mpfr_call (function_name, argument, fault)
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-{
 
-#if HAVE_MPFR
 
-  list message;
 
-  int function_number;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (! initialized)
 
-    avm_initialize_mpfr ();
 
-  if (!(function_number = 0xff & (function_name ? function_name->characterization : 0)))
 
-    {
 
-      message = avm_position (function_name, funs, fault);
 
-      if (*fault = (*fault ? 1 : !message))
 
-	return (message ? message : avm_copied (unrecognized_function_name));
 
-      function_number = message->characterization;
 
-      function_name->characterization = function_number;
 
-      avm_dispose (message);
 
-    }
 
-  switch (function_number)
 
-    {
 
-    case  1: return binary_evaluation((mpfr_binary_operator) &mpfr_add, argument, fault);
 
-    case  2: return binary_evaluation((mpfr_binary_operator) &mpfr_sub, argument, fault);
 
-    case  3: return binary_evaluation((mpfr_binary_operator) &mpfr_mul, argument, fault);
 
-    case  4: return binary_evaluation((mpfr_binary_operator) &mpfr_div, argument, fault);
 
-    case  5: return binary_evaluation((mpfr_binary_operator) &mpfr_pow, argument, fault);
 
-    case  6: return binary_evaluation((mpfr_binary_operator) &mpfr_atan2, argument, fault);
 
-    case  7: return binary_evaluation((mpfr_binary_operator) &mpfr_hypot, argument, fault);
 
-    case  8: return binary_evaluation((mpfr_binary_operator) &mpfr_min, argument, fault);
 
-    case  9: return binary_evaluation((mpfr_binary_operator) &mpfr_max, argument, fault);
 
-    case 10: return unary_evaluation((mpfr_unary_operator) &mpfr_sqrt, argument, fault);
 
-    case 11: return unary_evaluation((mpfr_unary_operator) &mpfr_sqr, argument, fault);
 
-    case 12: return unary_evaluation((mpfr_unary_operator) &mpfr_cbrt, argument, fault);
 
-    case 13: return unary_evaluation((mpfr_unary_operator) &mpfr_neg, argument, fault);
 
-    case 14: return unary_evaluation((mpfr_unary_operator) &mpfr_abs, argument, fault);
 
-    case 15: return unary_evaluation((mpfr_unary_operator) &mpfr_log, argument, fault);
 
-    case 16: return unary_evaluation((mpfr_unary_operator) &mpfr_log2, argument, fault);
 
-    case 17: return unary_evaluation((mpfr_unary_operator) &mpfr_log10, argument, fault);
 
-    case 18: return unary_evaluation((mpfr_unary_operator) &mpfr_exp, argument, fault);
 
-    case 19: return unary_evaluation((mpfr_unary_operator) &mpfr_exp2, argument, fault);
 
-    case 20: return unary_evaluation((mpfr_unary_operator) &mpfr_exp10, argument, fault);
 
-    case 21: return unary_evaluation((mpfr_unary_operator) &mpfr_cos, argument, fault);
 
-    case 22: return unary_evaluation((mpfr_unary_operator) &mpfr_sin, argument, fault);
 
-    case 23: return unary_evaluation((mpfr_unary_operator) &mpfr_tan, argument, fault);
 
-    case 24: return unary_evaluation((mpfr_unary_operator) &mpfr_acos, argument, fault);
 
-    case 25: return unary_evaluation((mpfr_unary_operator) &mpfr_asin, argument, fault);
 
-    case 26: return unary_evaluation((mpfr_unary_operator) &mpfr_atan, argument, fault);
 
-    case 27: return unary_evaluation((mpfr_unary_operator) &mpfr_cosh, argument, fault);
 
-    case 28: return unary_evaluation((mpfr_unary_operator) &mpfr_sinh, argument, fault);
 
-    case 29: return unary_evaluation((mpfr_unary_operator) &mpfr_tanh, argument, fault);
 
-    case 30: return unary_evaluation((mpfr_unary_operator) &mpfr_acosh, argument, fault);
 
-    case 31: return unary_evaluation((mpfr_unary_operator) &mpfr_asinh, argument, fault);
 
-    case 32: return unary_evaluation((mpfr_unary_operator) &mpfr_atanh, argument, fault);
 
-    case 33: return unary_evaluation((mpfr_unary_operator) &mpfr_log1p, argument, fault);
 
-    case 34: return unary_evaluation((mpfr_unary_operator) &mpfr_expm1, argument, fault);
 
-    case 35: return unary_evaluation((mpfr_unary_operator) &mpfr_eint, argument, fault);
 
-    case 36: return unary_evaluation((mpfr_unary_operator) &mpfr_gamma, argument, fault);
 
-    case 37: return unary_evaluation((mpfr_unary_operator) &mpfr_lngamma, argument, fault);
 
-    case 38: return unary_evaluation((mpfr_unary_operator) &mpfr_erf, argument, fault);
 
-    case 39: return unary_evaluation((mpfr_unary_operator) &mpfr_erfc, argument, fault);
 
-    case 40: return unary_evaluation((mpfr_unary_operator) &mpfr_ceil, argument, fault);
 
-    case 41: return unary_evaluation((mpfr_unary_operator) &mpfr_floor, argument, fault);
 
-    case 42: return unary_evaluation((mpfr_unary_operator) &mpfr_round, argument, fault);
 
-    case 43: return unary_evaluation((mpfr_unary_operator) &mpfr_trunc, argument, fault);
 
-    case 44: return unary_evaluation((mpfr_unary_operator) &mpfr_frac, argument, fault);
 
-    case 45: return binary_ui_evaluation((mpfr_binary_ui) &mpfr_root, argument, fault);
 
-    case 46: return binary_ui_evaluation((mpfr_binary_ui) &mpfr_pow_ui, argument, fault);
 
-    case 47: return binary_ui_evaluation((mpfr_binary_ui) &mpfr_mul_2ui, argument, fault);
 
-    case 48: return binary_ui_evaluation((mpfr_binary_ui) &mpfr_div_2ui, argument, fault);
 
-    case 49: return binary_predicate_evaluation((mpfr_binary_predicate) &mpfr_equal_p, argument, fault);
 
-    case 50: return binary_predicate_evaluation((mpfr_binary_predicate) &mpfr_cmp_abs, argument, fault);
 
-    case 51: return binary_predicate_evaluation((mpfr_binary_predicate) &mpfr_greater_p, argument, fault);
 
-    case 52: return binary_predicate_evaluation((mpfr_binary_predicate) &mpfr_greaterequal_p, argument, fault);
 
-    case 53: return binary_predicate_evaluation((mpfr_binary_predicate) &mpfr_less_p, argument, fault);
 
-    case 54: return binary_predicate_evaluation((mpfr_binary_predicate) &mpfr_lessequal_p, argument, fault);
 
-    case 55: return binary_predicate_evaluation((mpfr_binary_predicate) &mpfr_lessgreater_p, argument, fault);
 
-    case 56: return unary_predicate_evaluation((mpfr_unary_predicate) &mpfr_nan_p, argument, fault);
 
-    case 57: return unary_predicate_evaluation((mpfr_unary_predicate) &mpfr_inf_p, argument, fault);
 
-    case 58: return unary_predicate_evaluation((mpfr_unary_predicate) &mpfr_number_p, argument, fault);
 
-    case 59: return unary_predicate_evaluation((mpfr_unary_predicate) &mpfr_zero_p, argument, fault);
 
-    case 60: return unary_predicate_evaluation((mpfr_unary_predicate) &mpfr_integer_p, argument, fault);
 
-    case 61: return constant_evaluation((mpfr_constant) &mpfr_const_log2, argument, fault);
 
-    case 62: return constant_evaluation((mpfr_constant) &mpfr_const_pi, argument, fault);
 
-    case 63: return constant_evaluation((mpfr_constant) &mpfr_const_catalan, argument, fault);
 
-    case 64: return precision(argument,fault);
 
-    case 65: return sin_cos(argument,fault);
 
-    case 66: return mutator_evaluation((mpfr_mutator) mpfr_nextabove, argument, fault);
 
-    case 67: return mutator_evaluation((mpfr_mutator) mpfr_nextbelow, argument, fault);
 
-    case 68: return grow(1, argument, fault);
 
-    case 69: return grow(-1, argument, fault);
 
-    case 70: return dbl2mp(argument, fault);
 
-    case 71: return mp2dbl(argument, fault);
 
-    case 72: return str2mp(argument, fault);
 
-    case 73: return mp2str(argument, fault);
 
-    case 74: return infinity(1, argument, fault);
 
-    case 75: return infinity(-1, argument, fault);
 
-    case 76: return nan(argument, fault);
 
-    case 77: return vid_evaluation(argument, fault);
 
-    case 78: return bus_evaluation(argument, fault);
 
-    case 79: return nat2mp(argument, fault);
 
-#if HAVE_GMP
 
-    case 80: return approximately_equal(argument, fault);
 
-    case 81: return urandomb(argument, fault);
 
-#endif 
-    }
 
-#endif /* HAVE_MPFR */
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_mpfr ()
 
-
 
-     /* This initializes some static data structures. */
 
-
 
-{
 
-  char *funames[] = {
 
-    "add",            /* binary */
 
-    "sub",
 
-    "mul",
 
-    "div",
 
-    "pow",
 
-    "atan2",
 
-    "hypot",
 
-    "min",
 
-    "max",
 
-    "sqrt",            /* unary */
 
-    "sqr",
 
-    "cbrt",
 
-    "neg",
 
-    "abs",
 
-    "log",
 
-    "log2",
 
-    "log10",
 
-    "exp",
 
-    "exp2",
 
-    "exp10",
 
-    "cos",
 
-    "sin",
 
-    "tan",
 
-    "acos",
 
-    "asin",
 
-    "atan",
 
-    "cosh",
 
-    "sinh",
 
-    "tanh",
 
-    "acosh",
 
-    "asinh",
 
-    "atanh",
 
-    "log1p",
 
-    "expm1",
 
-    "eint",
 
-    "gamma",
 
-    "lngamma",
 
-    "erf",
 
-    "erfc",
 
-    "ceil",
 
-    "floor",
 
-    "round",
 
-    "trunc",
 
-    "frac",
 
-    "root",           /* binary ui */
 
-    "pow_ui",
 
-    "mul_2ui",
 
-    "div_2ui",
 
-    "equal_p",            /* binary predicate */
 
-    "unequal_abs",
 
-    "greater_p",
 
-    "greaterequal_p",
 
-    "less_p",
 
-    "lessequal_p",
 
-    "lessgreater_p",
 
-    "nan_p",          /* unary predicate */
 
-    "inf_p",
 
-    "number_p",
 
-    "zero_p",
 
-    "integer_p",
 
-    "const_log2",     /* constants */
 
-    "pi",
 
-    "const_catalan",
 
-    "prec",           /* other */
 
-    "sin_cos",
 
-    "nextabove",
 
-    "nextbelow",
 
-    "grow",
 
-    "shrink",
 
-    "dbl2mp",
 
-    "mp2dbl",
 
-    "str2mp",
 
-    "mp2str",
 
-    "inf",
 
-    "ninf",
 
-    "nan",
 
-    "vid",
 
-    "bus",
 
-    "nat2mp",
 
-#if HAVE_GMP
 
-    "eq",
 
-    "urandomb",
 
-#endif
 
-    NULL};
 
-  list back;
 
-  int string_number;
 
-  unsigned long seed;
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_chrcodes ();
 
-  wild = avm_strung("*");
 
-  shared_cell = avm_join (NULL,NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  mpfr_error = avm_join (avm_strung ("mpfr error"), NULL);
 
-  bad_mpfr_spec = avm_join (avm_strung ("bad mpfr specification"), NULL);
 
-  mpfr_overflow = avm_join (avm_strung ("mpfr overflow"), NULL);
 
-  unrecognized_function_name = avm_join (avm_strung ("unrecognized mpfr function name"), NULL);
 
-  unsigned_nan = avm_copied(shared_cell);
 
-#if HAVE_MPFR
 
-  negative_inf = avm_join(avm_copied(shared_cell),avm_natural(MPFR_INF_KIND));
 
-  negative_zero = avm_join(avm_copied(shared_cell),avm_natural(MPFR_ZERO_KIND));
 
-  negative_regular = avm_join(avm_copied(shared_cell),avm_natural(MPFR_REGULAR_KIND));
 
-  positive_inf = avm_join(NULL,avm_natural(MPFR_INF_KIND));
 
-  positive_zero = avm_join(NULL,avm_natural(MPFR_ZERO_KIND));
 
-  positive_regular = avm_join(NULL,avm_natural(MPFR_REGULAR_KIND));
 
-#endif
 
-  inf_string = avm_strung("inf");
 
-  ninf_string = avm_strung("-inf");
 
-  nan_string = avm_strung("nan");
 
-  string_number = 0;
 
-  funs = back = NULL;
 
-  while (funames[string_number])
 
-    avm_enqueue (&funs, &back, avm_standard_strung (funames[string_number++]));
 
-#if HAVE_GMP
 
-#if HAVE_MPFR
 
-  gmp_randinit_default(state);
 
-  seed = time(0);
 
-  gmp_randseed_ui(state,seed);
 
-#endif
 
-#endif
 
-}
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_mpfr ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (funs);
 
-  avm_dispose (wild);
 
-  avm_dispose (shared_cell);
 
-  avm_dispose (mpfr_error);
 
-  avm_dispose (bad_mpfr_spec);
 
-  avm_dispose (mpfr_overflow);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (unrecognized_function_name);
 
-  avm_dispose (unsigned_nan);
 
-#if HAVE_MPFR
 
-  avm_dispose (negative_inf);
 
-  avm_dispose (negative_zero);
 
-  avm_dispose (negative_regular);
 
-  avm_dispose (positive_inf);
 
-  avm_dispose (positive_zero);
 
-  avm_dispose (positive_regular);
 
-#endif
 
-  avm_dispose(inf_string);
 
-  avm_dispose(ninf_string);
 
-  avm_dispose(nan_string);
 
-  inf_string = NULL;
 
-  ninf_string = NULL;
 
-  nan_string = NULL;
 
-  unsigned_nan = NULL;
 
-  negative_inf = NULL;
 
-  negative_zero = NULL;
 
-  negative_regular = NULL;
 
-  positive_inf = NULL;
 
-  positive_zero = NULL;
 
-  positive_regular = NULL;
 
-  funs = NULL;
 
-  wild = NULL;
 
-  shared_cell = NULL;
 
-  mpfr_error = NULL;
 
-  memory_overflow = NULL;
 
-  unrecognized_function_name = NULL;
 
-}

+ 0 - 961
src/mtwist.c
View File 

@@ -1,961 +0,0 @@
 
-/* This file provides uniform random number generation and some
 
-   related functions using the Mersenne twistor algorithm. The
 
-   original code from mt19937.c, copyright (C) 1997 Makoto Matsumoto
 
-   and Takuji Nishimura, has been adapted by using the current time as
 
-   a seed and getting it to interface appropriately with avram. The
 
-   additional code is copyright (C) 2006 Dennis Furey, and pertains
 
-   mainly to fast random access to lists representing probability mass
 
-   functions.
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.  
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/compare.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/mtwist.h>
 
-#include <avm/matcon.h>
 
-#if HAVE_FENV
 
-#include <fenv.h>
 
-#endif
 
-#define __USE_ISOC99 1
 
-#include <math.h>
 
-#include <time.h>
 
-
 
-/* pointer to a shortcut into a list representing a probability mass function */
 
-typedef struct p_data *point;
 
-
 
-/* shortcut into a list representing a probability mass function */
 
-struct p_data
 
-{
 
-  int index;             /* the position in the list */
 
-  list entry;            /* the address of the point within its list */
 
-  double cu_prob;        /* the sum of the probabilities of all points up to this one */
 
-};
 
-
 
-/* pointer to a header for an array of entry points */
 
-typedef struct gt_data *guide_table;
 
-
 
-/* header for an array of entry points */
 
-struct gt_data
 
-{
 
-  int npts;                   /* always a power of two */
 
-  double norm;                /* in case it doesn't sum to 1 */
 
-  point points;
 
-  int signature;              /* identifies the function that tabulated it */
 
-  guide_table other_tables;
 
-};
 
-
 
-/* stores shortcuts into lists that might be used again */
 
-static guide_table guide_tables = NULL;
 
-
 
-/* the number of extant guide tables */
 
-static int num_tables = 0;
 
-
 
-/* the number of guide tables allowed simultaneously, must be at least 2 */
 
-#define MAX_TABLES 16
 
-
 
-/* the maximum number of points in a guide table, must be a power of two > 1 */
 
-#define MAX_POINTS 65536
 
-
 
-/* period parameters */
 
-#define N 624
 
-#define M 397
 
-
 
-/* the array for the state vector  */
 
-static unsigned long mt[N];
 
-
 
-/* mti==N+1 means mt[N] is not initialized */
 
-static int mti = N + 1;
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* truth */
 
-static list shared_cell = NULL;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list memory_overflow = NULL;
 
-static list empty_list_draw = NULL;
 
-static list bad_mtwist_spec = NULL;
 
-static list unrecognized_function_name = NULL;
 
-
 
-/* function names as lists of lists of character representations */
 
-static list wild = NULL;
 
-static list funs = NULL;
 
-
 
-
 
-
 
-
 
-
 
-
 
-static inline counter
 
-genat ()
 
-
 
-/* Copyright (C) 1997 Makoto Matsumoto and Takuji Nishimura. Any
 
-   feedback is very welcome. For any question, comments, see
 
-   http://www.math.keio.ac.jp/matumoto/emt.html or email
 
-   [email protected]  */
 
-{
 
-/* Period parameters */  
-#define MATRIX_A 0x9908b0df   /* constant vector a */
 
-#define UPPER_MASK 0x80000000 /* most significant w-r bits */
 
-#define LOWER_MASK 0x7fffffff /* least significant r bits */
 
-
 
-/* Tempering parameters */   
-#define TEMPERING_MASK_B 0x9d2c5680
 
-#define TEMPERING_MASK_C 0xefc60000
 
-#define TEMPERING_SHIFT_U(y)  (y >> 11)
 
-#define TEMPERING_SHIFT_S(y)  (y << 7)
 
-#define TEMPERING_SHIFT_T(y)  (y << 15)
 
-#define TEMPERING_SHIFT_L(y)  (y >> 18)
 
-
 
-  unsigned long y;
 
-  static unsigned long mag01[2]={0x0, MATRIX_A};
 
-  int kk;
 
-
 
-  if (mti >= N)
 
-    {
 
-      for (kk=0; kk<N-M; kk++)
 
-	{
 
-	  y = (mt[kk] & UPPER_MASK) | (mt[kk+1] & LOWER_MASK);
 
-	  mt[kk] = mt[kk+M] ^ (y >> 1) ^ mag01[y & 0x1];
 
-	}
 
-      for (; kk<N-1; kk++)
 
-	{
 
-	  y = (mt[kk] & UPPER_MASK) | (mt[kk+1] & LOWER_MASK);
 
-	  mt[kk] = mt[kk+(M-N)] ^ (y >> 1) ^ mag01[y & 0x1];
 
-	}
 
-      y = (mt[N-1] & UPPER_MASK) | (mt[0] & LOWER_MASK);
 
-      mt[N-1] = mt[M-1] ^ (y >> 1) ^ mag01[y & 0x1];
 
-      mti = 0;
 
-    }
 
-  y = mt[mti++];
 
-  y ^= TEMPERING_SHIFT_U(y);
 
-  y ^= TEMPERING_SHIFT_S(y) & TEMPERING_MASK_B;
 
-  y ^= TEMPERING_SHIFT_T(y) & TEMPERING_MASK_C;
 
-  y ^= TEMPERING_SHIFT_L(y);
 
-  return (counter) y;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static double
 
-genrand ()
 
-
 
-/* A C-program for MT19937: Real number version genrand() generates
 
-   one pseudorandom real number (double) which is uniformly
 
-   distributed on [0,1]-interval, for each call. sgenrand(seed) set
 
-   initial values to the working area of 624 words. Before genrand(),
 
-   sgenrand(seed) must be called once. (seed is any 32-bit integer
 
-   except for 0).  Integer generator is obtained by modifying two
 
-   lines.  Coded by Takuji Nishimura, considering the suggestions by
 
-   Topher Cooper and Marc Rieffel in July-Aug. 1997.  */
 
-{
 
-  return ((double) genat ()) / (unsigned long) 0xffffffff;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static guide_table
 
-existing_table (signature, operand)
 
-     int signature;
 
-     list operand;
 
-
 
-     /* This returns an existing table matching the operand if
 
-	found. */
 
-{
 
-  guide_table result;
 
-
 
-  result = guide_tables;
 
-  if (operand)
 
-    while (result)
 
-      {
 
-	if ((result->signature == signature) ? (result->points[0].entry == operand) : 0)
 
-	  return result;
 
-	result = result->other_tables;
 
-      }
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-lose_newest_table ()
 
-
 
-/* This gets rid of the newest table, which better exist. */
 
-
 
-{
 
-  int i;
 
-  guide_table new;
 
-
 
-  if (!(guide_tables ? num_tables : 0))
 
-    avm_internal_error (53);
 
-  num_tables--;
 
-  for (i = 0; i < guide_tables->npts; i++)
 
-    avm_dispose (guide_tables->points[i].entry);
 
-  free (guide_tables->points);
 
-  guide_tables = (new = guide_tables)->other_tables;
 
-  free (new);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-lose_oldest_table ()
 
-
 
-/* This gets rid of the oldest table, which better exist and not be
 
-   the newest. */
 
-
 
-{
 
-  guide_table penultimate;
 
-  int i;
 
-
 
-  if (!(guide_tables ? (guide_tables->other_tables ? (num_tables > 1) : 0) : 0))
 
-    avm_internal_error (57);
 
-  num_tables--;
 
-  penultimate = guide_tables;
 
-  while (penultimate->other_tables->other_tables)
 
-    penultimate = penultimate->other_tables;
 
-  for (i = 0; i < penultimate->other_tables->npts; i++)
 
-    avm_dispose (penultimate->other_tables->points[i].entry);
 
-  free (penultimate->other_tables->points);
 
-  free (penultimate->other_tables);
 
-  penultimate->other_tables = NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static guide_table
 
-new_table (signature, length)
 
-     int signature;
 
-     counter length;
 
-
 
-     /* This creates a new table for the given length if possible and
 
-	frees an old one if the cache is full. The number of points in
 
-	the table is the largest power of 2 not greater than the given
 
-	length that there's room to allocate. */
 
-{
 
-  int i;
 
-  int npts;
 
-  guide_table new;
 
-
 
-  if (num_tables == MAX_TABLES)
 
-    lose_oldest_table ();
 
-  if (length > MAX_POINTS)
 
-    npts = MAX_POINTS;
 
-  else
 
-    {
 
-      npts = 1;
 
-      while (npts <= length)
 
-	npts <<= 1;
 
-      npts >>= 1;
 
-    }
 
-  if (!(new = (guide_table) malloc (sizeof(*new))))
 
-    return NULL;
 
-  memset (new, 0, sizeof(*new));
 
-  while ((new->points = (point) malloc (npts * sizeof(*(new->points)))) ? 0 : (npts > 2))
 
-    npts >>= 1;
 
-  if (!(new->points))
 
-    {
 
-      free (new);
 
-      return NULL;
 
-    }
 
-  num_tables++;
 
-  new->npts = npts;
 
-  new->signature = signature;
 
-  memset (new->points, 0, new->npts * sizeof(*(new->points)));
 
-  new->other_tables = guide_tables;
 
-  return (guide_tables = new);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static point
 
-starting_point_by_index (table, target)
 
-     guide_table table;
 
-     int target;
 
-
 
-     /* This binary searches the table for the point with the maximum
 
-	index not greater than the target. */
 
-{
 
-  int pivot;
 
-  int bit;
 
-
 
-  if (!table)
 
-    return NULL;
 
-  if (!(table->points))
 
-    avm_internal_error (33);
 
-  bit = pivot = (table->npts >> 1);
 
-  while (bit)
 
-    {
 
-      if (table->points[pivot].index > target)
 
-	pivot -= bit;
 
-      else if (table->points[pivot].index == target)
 
-	bit = 0;
 
-      pivot |= (bit >>= 1);
 
-    }
 
-  if ((table->points[pivot].index > target) ? pivot : 0)
 
-    pivot--;
 
-  return &(table->points[pivot]);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static point
 
-starting_point_by_probability (table, target)
 
-     guide_table table;
 
-     double target;
 
-
 
-     /* This binary searches the table for a point with a cumulative
 
-	probability close to the target. The result will always have a
 
-	cumulative probability less than or equal to the target unless
 
-	the target is less than the smallest cumulative probability in
 
-	the table. */
 
-{
 
-  int pivot;
 
-  int bit;
 
-
 
-  if (!table)
 
-    return NULL;
 
-  if (!(table->points))
 
-    avm_internal_error (6);
 
-  bit = pivot = (table->npts >> 1);
 
-  while (bit)
 
-    {
 
-      if (table->points[pivot].cu_prob > target)
 
-	pivot -= bit;
 
-      else if (table->points[pivot].cu_prob == target)
 
-	bit = 0;
 
-      pivot |= (bit >>= 1);
 
-    }
 
-  if ((table->points[pivot].cu_prob > target) ? pivot : 0)
 
-    pivot--;
 
-  return &(table->points[pivot]);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-bern (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* This returns true if a standard uniform draw is less than a
 
-	given probability (i.e., a Bernoulli distribution). The
 
-	default is 1/2. */
 
-{
 
-  double *p;
 
-  list result;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  if (!operand)
 
-    return ((genat () & 1) ? avm_copied (shared_cell) : NULL);
 
-  p = (double *) avm_value_of_list (operand, &result, fault);
 
-  if (*fault)
 
-    return (result ? result : avm_copied (bad_mtwist_spec));
 
-  if (fpclassify(*p) == FP_ZERO)
 
-    return NULL;
 
-  if (*fault = (*fault ? 1 : (result ? 1 : (!p ? 1 : ((fpclassify(*p) != FP_NORMAL) ? 1 : ((*p < 0.0) ? 1 : (*p > 1.0)))))))
 
-    return (result ? result : avm_copied (bad_mtwist_spec));
 
-  return ((genrand () < *p) ? avm_copied (shared_cell) : NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-u_cont (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* This returns a draw from a continuous uniform distribution
 
-	over the range of zero to the operand. The default is 1. */
 
-{
 
-  double *range;
 
-  double draw;
 
-  list result;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (!operand)
 
-    {
 
-      draw = genrand ();
 
-      return avm_list_of_value ((void *) &draw, sizeof (double), fault);
 
-    }
 
-  result = NULL;
 
-  range = (double *) avm_value_of_list(operand, &result, fault);
 
-  if (*fault = (*fault ? 1 : (!!result ? 1 : (!range ? 1 : (fpclassify(*range) != FP_NORMAL)))))
 
-    return (result ? result : avm_copied (bad_mtwist_spec));
 
-  draw = *range * genrand ();
 
-  return avm_list_of_value ((void *) &draw, sizeof (double), fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-u_disc (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* This returns a draw from a discrete uniform distribution over
 
-	the range of zero to the operand - 1, or over the full 64 bit
 
-	range if the operand is 0. */
 
-{
 
-  counter modulus,width,random;
 
-  list result;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (!operand)
 
-    {
 
-      modulus = (genat() << 32) + genat();
 
-      if (!modulus)
 
-	return NULL;
 
-      if (*fault = !(result = avm_natural (modulus)))
 
-	return avm_copied (memory_overflow);
 
-      return result;
 
-    }
 
-  result = NULL;
 
-  width = avm_counter (operand);
 
-  random = ((width <= 0xffffffff) ? genat () : ((genat() << 32) + genat()));
 
-  if (modulus = (width ? (random % width) : random))
 
-    if (*fault = !(result = avm_natural (modulus)))
 
-      return avm_copied (memory_overflow);
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-u_path (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* This returns a non-empty singly branched list of the given
 
-	depth. */
 
-{
 
-  counter modulus,depth,width,random;
 
-  list result;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !operand)
 
-    return avm_copied (bad_mtwist_spec);
 
-  result = avm_copied (shared_cell);
 
-  random = (((width = avm_counter (operand->tail)) ? (width <= 0xffffffff) : 0) ? genat() : ((genat() << 32) + genat()));
 
-  modulus = (width ? (random % width) : random);
 
-  if (!(depth = avm_counter (operand->head)))
 
-    return result;
 
-  while (*fault ? 0 : depth--)
 
-    {
 
-      *fault = !(result = ((modulus & 1) ? avm_recoverable_join (NULL, result) : avm_recoverable_join (result, NULL)));
 
-      modulus >>= 1;
 
-    }
 
-  if (*fault)
 
-    return avm_copied (memory_overflow);
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-u_enum (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* This returns a randomly chosen item of the operand list. */
 
-{
 
-  int target;
 
-  counter length;
 
-  guide_table table;
 
-  int index,item_number,i;
 
-  point starting_point;
 
-
 
-#define U_ENUM 0
 
-
 
-  if (*fault = (*fault ? 1 : !operand))
 
-    return avm_copied (empty_list_draw);
 
-  length = avm_recoverable_length (operand);
 
-  if (!(table = existing_table (U_ENUM, operand)))
 
-    if (table = new_table (U_ENUM, length))
 
-      {
 
-	item_number = 0;
 
-	for (i = 0; i < table->npts; i++)
 
-	  {
 
-	    if (!operand)
 
-	      avm_internal_error (42);
 
-	    table->points[i].index = item_number;
 
-	    table->points[i].entry = avm_copied (operand);
 
-	    while (operand ? ((((float) item_number) / (float) length) < (((float) (i + 1)) / (float) table->npts)) : 0)
 
-	      {
 
-		operand = operand->tail;
 
-		item_number++;
 
-	      }
 
-	  }
 
-      }
 
-  index = 0;
 
-  if (starting_point = starting_point_by_index (table, target = (int) genat () % length))
 
-    {
 
-      index = starting_point->index;
 
-      operand = starting_point->entry;
 
-    }
 
-  while (index++ < target)
 
-    {
 
-      if (!operand)
 
-	avm_internal_error (3);
 
-      operand = operand->tail;
 
-    }
 
-  if (!operand)
 
-    avm_internal_error (4);
 
-  return avm_copied (operand->head);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static guide_table
 
-w_table (disc, operand, result, fault)
 
-     int disc;
 
-     list operand;
 
-     list *result;
 
-     int *fault;
 
-
 
-     /* This initializes a guide table with cumulative probabilities
 
-	based on the operand for the w_disc or w_enum functions. A
 
-	non-zero value of disc causes the items of the operand to be
 
-	interpreted as probabilities (per the w_disc function), and a
 
-	zero value cause their right sides to be interpreted as
 
-	probabilities (per the w_enum function). The validity of the
 
-	probabilities is checked as a side effect, so that subsequent
 
-	draws using the table don't have to check them. */
 
-{
 
-  guide_table table;
 
-  counter length;
 
-  double *p;
 
-  int item_number;
 
-  double subtotal;
 
-  int i;
 
-
 
-#define W_SIG 1
 
-
 
-  if (table = existing_table (W_SIG + disc, operand))
 
-    return table;
 
-  if (*fault = (*fault ? 1 : !!(*result)))
 
-    return NULL;
 
-  if (*fault = !(operand ? (disc ? 1 : !!(operand->head)) : 0))
 
-    *result = avm_copied (empty_list_draw);
 
-  if (*fault = (*fault ? 1 : !(table = new_table (W_SIG + disc, length = (int) avm_length (operand)))))
 
-    *result = (*result ? *result : avm_copied (memory_overflow));
 
-  if (*fault)
 
-    return NULL;
 
-  p = (double *) avm_value_of_list (disc ? operand->head : operand->head->tail, result, fault);
 
-  if (!*fault)
 
-    *fault = !(!*result ? (p ? ((fpclassify(*p) == FP_NORMAL) ? (*p >= 0.0) : 0) : 0) : 0);
 
-  subtotal = (*fault ? 0.0 : *p);
 
-  item_number = 0;
 
-  for (i = 0; i < table->npts; i++)
 
-    {
 
-      table->points[i].cu_prob = subtotal;
 
-      table->points[i].index = item_number;
 
-      table->points[i].entry = (*fault ? NULL : avm_copied (operand));
 
-      if (i + 1 < table->npts)
 
-	while (operand ? ((((float) item_number) / (float) length) < (((float) (i + 1)) / (float) table->npts)) : 0)
 
-	  {
 
-	    *fault = (*fault ? 1 : !((operand = operand->tail) ? (disc ? 1 : !!(operand->head)) : 0));
 
-	    p = (*fault ? NULL : (double *) avm_value_of_list (disc ? operand->head : operand->head->tail, result, fault));
 
-	    if (!*fault)
 
-	      *fault = !(!*result ? (p ? ((fpclassify(*p) == FP_NORMAL) ? (*p >= 0.0) : 0) : 0) : 0);
 
-	    subtotal += (*fault ? 0.0 : *p);
 
-	    item_number++;
 
-	  }
 
-    }
 
-  while (*fault ? 0 : (operand = operand->tail))
 
-    {
 
-      *fault = (disc ? 0 : !(operand->head));
 
-      p = (*fault ? NULL : (double *) avm_value_of_list (disc ? operand->head : operand->head->tail, result, fault));
 
-      if (!*fault)
 
-	*fault = !(!*result ? (p ? ((fpclassify(*p) == FP_NORMAL) ? (*p >= 0.0) : 0) : 0) : 0);
 
-      subtotal += (*fault ? 0.0 : *p);
 
-    }
 
-  table->norm = subtotal;
 
-  if (!*fault)
 
-    return table;
 
-  lose_newest_table ();
 
-  *result = (*result ? *result : avm_copied (bad_mtwist_spec));
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-w_disc (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* The operand is a list of probabilities describing a discrete
 
-	distribution from which a draw is returned as a natural
 
-	number. Internal errors are reported because the operand
 
-	should be validated by the time the table is built. */
 
-{
 
-  double subtotal;
 
-  double target;
 
-  double *p;
 
-  list result;
 
-  guide_table table;
 
-  point starting_point;
 
-  int index;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  table = w_table (1, operand, &result, fault);
 
-  if (*fault = (*fault ? 1 : (result ? 1 : !table)))
 
-    return (result ? result : avm_copied (bad_mtwist_spec));
 
-  if (!(starting_point = starting_point_by_probability (table, target = (genrand () * table->norm))))
 
-    avm_internal_error (52);
 
-  index = starting_point->index;
 
-  operand = starting_point->entry;
 
-  subtotal = starting_point->cu_prob;
 
-  while ((subtotal < target) ? operand : NULL)
 
-    {
 
-      *fault = !(operand = operand->tail);
 
-      p = (*fault ? NULL : (double *) avm_value_of_list (operand->head, &result, fault));
 
-      if (*fault ? 1 : (result ? 1 : !p))
 
-	avm_internal_error (51);
 
-      subtotal += *p;
 
-      index++;
 
-    }
 
-  if (!index)
 
-    return NULL;
 
-  if (*fault = !(result = avm_recoverable_natural (index)))
 
-    return avm_copied (memory_overflow);
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-w_enum (operand, fault)
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* The operand is a list of <(x,p)..> with p being the
 
-	probability of drawing x. The result is an x drawn from the
 
-	list consistently with the probabilities. Internal errors are
 
-	reported because the operand should have been validated by the
 
-	time the table is built. */
 
-{
 
-  double subtotal;
 
-  double target;
 
-  double *p;
 
-  list result;
 
-  guide_table table;
 
-  point starting_point;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  result = NULL;
 
-  table = w_table (0, operand, &result, fault);
 
-  if (*fault = (*fault ? 1 : (result ? 1 : !table)))
 
-    return (result ? result : avm_copied (bad_mtwist_spec));
 
-  if (!(starting_point = starting_point_by_probability (table, target = (genrand () * table->norm))))
 
-    avm_internal_error (58);
 
-  operand = starting_point->entry;
 
-  subtotal = starting_point->cu_prob;
 
-  while ((subtotal < target) ? operand : NULL)
 
-    {
 
-      *fault = !((operand = operand->tail) ? operand->head : NULL);
 
-      p = (*fault ? NULL : (double *) avm_value_of_list (operand->head->tail, &result, fault));
 
-      if (*fault ? 1 : (result ? 1 : !p))
 
-	avm_internal_error (59);
 
-      subtotal += *p;
 
-    }
 
-  if (!(operand ? operand->head : NULL))
 
-    avm_internal_error (67);
 
-  return avm_copied (operand->head->head);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_have_mtwist_call (function_name, fault)
 
-     list function_name;
 
-     int *fault;
 
-
 
-/* this reports the availability of a function */
 
-
 
-{
 
-#if HAVE_FENV
 
-  list membership;
 
-  list comparison;
 
-  list result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_mtwist ();
 
-  if (*fault)
 
-    return NULL;
 
-  comparison = avm_binary_comparison (function_name, wild, fault);
 
-  if (*fault)
 
-    return comparison;
 
-  if (comparison)
 
-    {
 
-      avm_dispose(comparison);
 
-      return avm_copied(funs);
 
-    }
 
-  if (!(membership = avm_binary_membership (function_name, funs, fault)) ? 1 : *fault)
 
-    return membership;
 
-  avm_dispose(membership);
 
-  return ((*fault = !(result = avm_recoverable_join(avm_copied(function_name),NULL))) ? avm_copied(memory_overflow) : result);
 
-#endif
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_mtwist_call (function_name, argument, fault)
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-
 
-     /* This figures out what function to call and calls it. */
 
-{
 
-#if HAVE_FENV
 
-  list message;
 
-  int function_number;
 
-
 
-  if (! initialized)
 
-    avm_initialize_mtwist ();
 
-  if (!(function_number = 0xff & (function_name ? function_name->characterization : 0)))
 
-    {
 
-      message = avm_position (function_name, funs, fault);
 
-      if (*fault)
 
-	return message;
 
-      if (*fault = !message)
 
-	return avm_copied (unrecognized_function_name);
 
-      function_number = message->characterization;
 
-      function_name->characterization = function_number;
 
-      avm_dispose (message);
 
-    }
 
-  message = NULL;
 
-  switch (function_number)
 
-    {
 
-    case 1: return bern (argument, fault);
 
-    case 2: return u_cont (argument, fault);
 
-    case 3: return u_disc (argument, fault);
 
-    case 4: return u_enum (argument, fault);
 
-    case 5: return w_disc (argument, fault);
 
-    case 6: return w_enum (argument, fault);
 
-    case 7: return u_path (argument, fault);
 
-    }
 
-#endif /* HAVE_FENV */
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_mtwist ()
 
-
 
-     /* This initializes some static data structures. */
 
-
 
-{
 
-  char *funames[] = {
 
-    "bern",
 
-    "u_cont",
 
-    "u_disc",
 
-    "u_enum",
 
-    "w_disc",
 
-    "w_enum",
 
-    "u_path",
 
-    NULL};            /* add more function names here up to a total of 255 */
 
-  list back;
 
-  int string_number;
 
-  unsigned long seed;	
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_matcon ();
 
-  avm_initialize_listfuns ();
 
-  avm_initialize_chrcodes ();
 
-  shared_cell = avm_join (NULL, NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  empty_list_draw = avm_join (avm_strung ("draw from empty list"), NULL);
 
-  bad_mtwist_spec = avm_join (avm_strung ("bad mtwist specification"), NULL);
 
-  unrecognized_function_name = avm_join (avm_strung ("unrecognized mtwist function name"), NULL);
 
-  string_number = 0;
 
-  wild = avm_strung("*");
 
-  funs = back = NULL;
 
-  while (funames[string_number])
 
-    avm_enqueue (&funs, &back, avm_standard_strung (funames[string_number++]));
 
-#if HAVE_FENV
 
-  /* setting initial seeds to mt[N] using         */
 
-  /* the generator Line 25 of Table 1 in          */
 
-  /* [KNUTH 1981, The Art of Computer Programming */
 
-  /*    Vol. 2 (2nd Ed.), pp102]                  */
 
-  seed = time(0);
 
-  mt[0]= seed & 0xffffffff;
 
-  for (mti=1; mti<N; mti++)
 
-    mt[mti] = (69069 * mt[mti-1]) & 0xffffffff;
 
-#endif /* HAVE_FENV */
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_mtwist ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-  guide_table old;
 
-  counter i;
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (funs);
 
-  avm_dispose (wild);
 
-  avm_dispose (shared_cell);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (empty_list_draw);
 
-  avm_dispose (bad_mtwist_spec);
 
-  avm_dispose (unrecognized_function_name);
 
-  while (guide_tables)
 
-    lose_newest_table ();
 
-  funs = NULL;
 
-  wild = NULL;
 
-  empty_list_draw = NULL;
 
-  memory_overflow = NULL;
 
-  bad_mtwist_spec = NULL;
 
-  unrecognized_function_name = NULL;
 
-}

+ 0 - 612
src/mwrap.c
View File 

@@ -1,612 +0,0 @@
 
-
 
-/* This file contains some routines to intercept calls to malloc and
 
-   to inhibit output operations to compensate for badly designed
 
-   external libraries.
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
 
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/mwrap.h>
 
-#include <unistd.h>
 
-#include <fcntl.h>
 
-#if HAVE_MALLOC
 
-#include <malloc.h>
 
-#endif
 
-
 
-/* points to a list of blocks of memory */
 
-typedef struct memory_node *areas;
 
-
 
-struct memory_node
 
-{
 
-  void *first_area;
 
-  size_t size;
 
-  areas other_areas;
 
-};
 
-
 
-
 
-/* points to a stack of jump buffers */
 
-typedef struct jump_stack_node *jump_stack;
 
-
 
-struct jump_stack_node
 
-{
 
-  jmp_buf *latest_jump;
 
-  jump_stack other_jumps;
 
-};
 
-
 
-
 
-/* a non-zero value means static variables have been initialized */
 
-static int initialized = 0;
 
-
 
-/* a non-zero value means messages can be printed to stdout */
 
-static int stderr_on = 1;
 
-
 
-/* a non-zero value means messages can be printed to stderr */
 
-static int stdout_on = 1;
 
-
 
-/* file handles */
 
-static int offline_stdout = 0;
 
-static int offline_stderr = 0;
 
-
 
-/* causes error messages to be printed */
 
-static int debug_mode = 0;
 
-
 
-/* non-zero if memory management is active */
 
-static int management_mode = 0;
 
-
 
-/* records all memory allocated while the wrapper is active */
 
-static areas managed_memory;
 
-
 
-/* temporary storage for the malloc and free hooks provided by libc */
 
-static void *real_malloc;
 
-static void *real_realloc;
 
-static void *real_free;
 
-
 
-/* stack of destinations for long jumps in case of allocation failures */
 
-static jump_stack jumps = NULL;
 
-
 
-/* the number of jmp_bufs that tried to be created but couldn't */
 
-static counter jump_stack_overflow = 0;
 
-
 
-/* used for temporary storage by the avm_setjmp () macro */
 
-jmp_buf *_avm_mwrap_client;
 
-
 
-
 
-#if !HAVE_SETJMP
 
-
 
-int
 
-setjmp (_avm_mwrap_client)
 
-     jmp_buf _avm_mwrap_client;
 
-
 
-     /* replacement function that does nothing if the host platform
 
-	doesn't have setjmp */
 
-{
 
-  return 0;
 
-}
 
-
 
-#endif
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-*malloc_wrapper (size, caller)
 
-     size_t size;
 
-     const void *caller;
 
-
 
-/* This works around library functions that don't recover gracefully
 
-   from insufficient memory. Any time a function calls malloc, the
 
-   call gets redirected here. If there's insufficient memory, it
 
-   doesn't return to the caller but jumps back to whatever function
 
-   has initialized the jmp_buf _avm_mwrap_client. This function also
 
-   makes a list of all memory areas allocated while it's active so
 
-   they can be freed reliably. */
 
-{
 
-  void *creation;
 
-  areas insertion;
 
-
 
-#if HAVE_MALLOC
 
-  avm_dont_manage_memory ();
 
-  if (!(insertion = malloc(sizeof(*insertion))))
 
-    {
 
-#if HAVE_SETJMP
 
-      if (jumps ? (jumps->latest_jump ? !jump_stack_overflow : 0) : 0)
 
-	{
 
-	  avm_free_managed_memory ();
 
-	  longjmp (*(jumps->latest_jump), -1);
 
-	}
 
-#endif
 
-      avm_manage_memory ();                   /* can't escape so the caller better know what to do with a NULL pointer */
 
-      return NULL;
 
-    }
 
-  if (!(creation = malloc (size)))
 
-    {
 
-      free (insertion);
 
-#if HAVE_SETJMP
 
-      if (jumps ? (jumps->latest_jump ? !jump_stack_overflow : 0) : 0)
 
-	{
 
-	  avm_free_managed_memory ();
 
-	  longjmp (*(jumps->latest_jump), -1);
 
-	}
 
-#endif
 
-      avm_manage_memory ();
 
-      return NULL;
 
-    }
 
-  insertion->first_area = creation;
 
-  insertion->size = size;
 
-  insertion->other_areas = managed_memory;
 
-  managed_memory = insertion;
 
-  if (debug_mode)
 
-    printf ("malloc (%u) returns %p\n", (unsigned int) size, creation);
 
-  avm_manage_memory ();
 
-  return creation;
 
-#endif
 
-  avm_internal_error (29);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-free_wrapper (ptr, caller)
 
-     void *ptr;
 
-     const void *caller;
 
-
 
-/* This intercepts calls to free by library functions. If it's freeing
 
-   something that was allocated by the library, the area is removed
 
-   from the list of managed memory. If it tries to free something that
 
-   wasn't allocated, that's a bug in the library which may have
 
-   corrupted the rest of memory so the program is terminated. */
 
-{
 
-  areas deletion,predecessor;
 
-
 
-#if HAVE_MALLOC
 
-  avm_dont_manage_memory ();
 
-  if (debug_mode)
 
-    printf ("freeing pointer %p\n", ptr);
 
-  if (!ptr)
 
-    {                           /* in case anyone feels the need to free null pointers */
 
-      avm_manage_memory ();
 
-      return;
 
-    }
 
-  if (managed_memory ? (managed_memory->first_area == ptr) : 0)
 
-    {
 
-      deletion = managed_memory;
 
-      managed_memory = managed_memory->other_areas;
 
-    }
 
-  else
 
-    {
 
-      predecessor = managed_memory;
 
-      while (predecessor ? (predecessor->other_areas ? (predecessor->other_areas->first_area != ptr) : 0) : 0)
 
-	predecessor = predecessor->other_areas;
 
-      if (!(predecessor ? (predecessor->other_areas ? (predecessor->other_areas->first_area == ptr) : 0) : 0))
 
-	avm_internal_error (70);
 
-      deletion = predecessor->other_areas;
 
-      predecessor->other_areas = deletion->other_areas;
 
-    }
 
-  free (deletion->first_area);
 
-  free (deletion);
 
-  avm_manage_memory ();
 
-  return;
 
-#endif
 
-  avm_internal_error (30);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static void
 
-*realloc_wrapper (ptr, size, caller)
 
-     void *ptr;
 
-     size_t size;
 
-     const void *caller;
 
-{
 
-  void *new_address;
 
-  areas location;
 
-
 
-#if HAVE_MALLOC
 
-  avm_dont_manage_memory ();
 
-  if (!(new_address = realloc (ptr,size)))
 
-    {
 
-#if HAVE_SETJMP
 
-      if (jumps ? (jumps->latest_jump ? !jump_stack_overflow : 0) : 0)
 
-	{
 
-	  avm_free_managed_memory ();
 
-	  longjmp (*(jumps->latest_jump), -1);
 
-	}
 
-#endif
 
-      avm_manage_memory ();
 
-      return NULL;
 
-    }
 
-  if (debug_mode)
 
-    printf ("realloc (%p,%u) returns %p\n", (unsigned int) ptr, size, new_address);
 
-  if (new_address != ptr)
 
-    {
 
-      location = managed_memory;
 
-      while (location ? (location->first_area != ptr) : 0)
 
-	location = location->other_areas;
 
-      if (!location)
 
-	avm_internal_error(78);
 
-      location->first_area = new_address;
 
-      location->size = size;
 
-    }
 
-  avm_manage_memory ();
 
-  return new_address;
 
-#endif
 
-  avm_internal_error (31);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-jmp_buf 
-*avm_new_jmp_buf()
 
-
 
-/* pushes a jump buffer onto the stack and returns its address, or
 
-   else increments stack overflow */
 
-{
 
-  jump_stack new_top;
 
-  int saved_management_mode;
 
-
 
-#if HAVE_SETJMP
 
-  if (jump_stack_overflow ? jump_stack_overflow++ : 0)
 
-    return NULL;
 
-  if (saved_management_mode = management_mode)
 
-    avm_dont_manage_memory ();
 
-  if (new_top = (jump_stack) malloc (sizeof(*new_top)))
 
-    {
 
-      if (new_top->latest_jump = (jmp_buf *) malloc(sizeof(jmp_buf)))
 
-	{
 
-	  new_top->other_jumps = jumps;
 
-	  jumps = new_top;
 
-	  if (management_mode = saved_management_mode)
 
-	    avm_manage_memory ();
 
-	  return jumps->latest_jump;
 
-	}
 
-      free (new_top);
 
-    }
 
-  jump_stack_overflow++;
 
-  if (management_mode = saved_management_mode)
 
-    avm_manage_memory ();
 
-#endif
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_setnonjmp ()
 
-
 
-/* This pushes an empty jump buffer so that jumps will be inhibited
 
-   rather than falling through to the one below. Failure is not an
 
-   option, so if there's insufficient memory, it bumps the
 
-   jump_stack_overflow, which will have the same effect as a
 
-   non-destination in the wrapper functions. In that case, no further
 
-   real or non-destinations will be pushable until after all the
 
-   overflows have been cleared, but more non-destinations can still be
 
-   simulated by overflows. */
 
-{
 
-  jump_stack new_top;
 
-  int saved_management_mode;
 
-
 
-#if HAVE_SETJMP
 
-  if (jump_stack_overflow ? jump_stack_overflow++ : 0)
 
-    return;
 
-  if (saved_management_mode = management_mode)
 
-    avm_dont_manage_memory ();
 
-  if (new_top = (jump_stack) malloc (sizeof(*new_top)))
 
-    {
 
-      new_top->latest_jump = NULL;
 
-      new_top->other_jumps = jumps;
 
-      jumps = new_top;
 
-      if (management_mode = saved_management_mode)
 
-	avm_manage_memory ();
 
-      return;
 
-    }
 
-  jump_stack_overflow++;
 
-  if (management_mode = saved_management_mode)
 
-    avm_manage_memory ();
 
-#endif
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_clearjmp ()
 
-
 
-/* decrements stack_overflow if it's positive, otherwise pops a jump
 
-   buffer or place holder from the stack */
 
-{
 
-  int saved_management_mode;
 
-  jump_stack deletion;
 
-
 
-#if HAVE_SETJMP
 
-  if (jump_stack_overflow ? jump_stack_overflow-- : 0)
 
-    return;
 
-  if (saved_management_mode = management_mode)
 
-    avm_dont_manage_memory ();
 
-  if (!jumps)
 
-    avm_internal_error (1);
 
-  jumps = (deletion = jumps)->other_jumps;
 
-  if (deletion->latest_jump)
 
-    free (deletion->latest_jump);
 
-  free (deletion);
 
-  if (management_mode = saved_management_mode)
 
-    avm_manage_memory ();
 
-#endif
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_debug_memory ()
 
-
 
-/* causes error messages to be printed during memory management */
 
-{
 
-  debug_mode = 1;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_dont_debug_memory ()
 
-
 
-/* stops error messages from being printed during memory management */
 
-{
 
-  debug_mode = 0;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-inline void
 
-avm_manage_memory ()
 
-
 
-/* redirects calls to malloc and free to the wrappers defined above */
 
-{
 
-  management_mode = 1;
 
-#if HAVE_MALLOC
 
-  __malloc_hook = malloc_wrapper;
 
-  __realloc_hook = realloc_wrapper;
 
-  __free_hook = free_wrapper;
 
-#endif
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-inline void
 
-avm_dont_manage_memory ()
 
-
 
-/* cancels redirection */
 
-{
 
-  management_mode = 0;
 
-#if HAVE_MALLOC
 
-  __malloc_hook = real_malloc;
 
-  __realloc_hook = real_realloc;
 
-  __free_hook = real_free;
 
-#endif
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_free_managed_memory ()
 
-
 
-/* this frees all the memory in the list of allocated areas and also
 
-   cancels redirection */
 
-{
 
-  areas previous;
 
-
 
-  avm_dont_manage_memory ();
 
-  while (managed_memory)
 
-    {
 
-      managed_memory = (previous = managed_memory)->other_areas;
 
-      free(previous->first_area);
 
-      free(previous);
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-inline void
 
-avm_turn_off_stdout ()
 
-
 
-/* temporarily disable stdout */
 
-{
 
-  if (!stdout_on)
 
-    return;
 
-  stdout_on = 0;
 
-  offline_stdout = dup (STDOUT_FILENO);
 
-  fclose (stdout);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-inline void
 
-avm_turn_on_stdout ()
 
-
 
-/* restore stdout if it was off */
 
-{
 
-  if (stdout_on)
 
-    return;
 
-  stdout_on = 1;
 
-  dup2 (offline_stdout, STDOUT_FILENO);
 
-  stdout = fdopen(STDOUT_FILENO,"w");    /* fixme: how to do this on non-GNU systems where stdout is a macro */
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_turn_off_stderr ()
 
-
 
-/* temporarily disable stderr */
 
-{
 
-  if (!stderr_on)
 
-    return;
 
-  stderr_on = 0;
 
-  offline_stderr = dup (STDERR_FILENO);
 
-  fclose (stderr);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_turn_on_stderr ()
 
-
 
-/* restore stderr if it was off */
 
-{
 
-  if (stderr_on)
 
-    return;
 
-  stderr_on = 1;
 
-  dup2 (offline_stderr, STDERR_FILENO);
 
-  stderr = fdopen(STDERR_FILENO,"w");    /* fixme: how to do this on non-GNU systems where stderr is a macro */
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_mwrap ()
 
-
 
-     /* This initializes some static data structures. */
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-#if HAVE_MALLOC
 
-  real_free = __free_hook;
 
-  real_malloc = __malloc_hook;
 
-  real_realloc = __realloc_hook;
 
-#endif
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_mwrap ()
 
-
 
-/* this checks for memory leaks */
 
-
 
-{
 
-  counter unreclaimed;
 
-
 
-  if (!initialized)
 
-    return;
 
-  if (!stdout_on)
 
-    avm_turn_on_stdout ();
 
-  if (!stderr_on)
 
-    avm_turn_on_stderr ();
 
-  avm_dont_manage_memory ();
 
-  unreclaimed = initialized = 0;
 
-  while (managed_memory)
 
-    {
 
-      if (debug_mode)
 
-	printf("%d bytes unreclaimed at pointer %p\n", managed_memory->size, managed_memory->first_area);
 
-      unreclaimed = unreclaimed + managed_memory->size;
 
-      managed_memory = managed_memory->other_areas;
 
-    }
 
-  if (unreclaimed)
 
-    avm_reclamation_failure ("managed memory bytes", unreclaimed);
 
-  unreclaimed = 0;
 
-  while (jumps)
 
-    {
 
-      unreclaimed++;
 
-      jumps = jumps->other_jumps;
 
-    }
 
-  if (unreclaimed)
 
-    avm_reclamation_failure ("jump buffers", unreclaimed);
 
-}

+ 0 - 133
src/portals.c
View File 

@@ -1,133 +0,0 @@
 
-
 
-/* memory management for portal and port pair types
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/branches.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/ports.h>
 
-#include <avm/portals.h>
 
-
 
-/* a pointer to an internal cache of port pair structures used for
 
-   fast allocation */
 
-static portal available_portal = NULL;
 
-
 
-/* the total number of allocated portals at any given time, excluding
 
-   those in the cache */
 
-static counter extant_portals = 0;
 
-
 
-/* the number of portals in the cache */
 
-static counter available_portals = 0;
 
-
 
-/* non-zero implies static variable are initialized */
 
-static int initialized = 0;
 
-
 
-/* the limit to the number of portals allowed in the cache; can be
 
-   changed arbitrarily for performance tuning */
 
-#define portal_cache_size 0xff
 
-
 
-
 
-
 
-portal
 
-avm_new_portal (alters)
 
-     portal alters;
 
-
 
-     /* This allocates a new port pair node and initializes the alters
 
-        field with the parameter, effectively inserting the new one
 
-        into a list of them. It returns a NULL pointer if
 
-        unsuccessful. The local cache is used for improved
 
-        performance. */
 
-
 
-{
 
-  portal result;
 
-
 
-  if (result = available_portal)
 
-    {
 
-      available_portal = available_portal->alters;
 
-      available_portals--;
 
-    }
 
-  else
 
-    result = (portal) (malloc (sizeof (*result)));
 
-  if (result)
 
-    {
 
-      extant_portals++;
 
-      memset (result, 0, sizeof (*result));
 
-      result->alters = alters;
 
-    }
 
-  return (result);
 
-}
 
-
 
-
 
-
 
-
 
-void
 
-avm_seal (fate)
 
-     portal fate;
 
-
 
-     /* This frees the memory associated with a portal, or leaves it
 
-        in the cache for future use. It must be non-null or an
 
-        internal error results. */
 
-{
 
-  extant_portals--;
 
-  if (!fate)
 
-    avm_internal_error (27);
 
-  if (available_portals > portal_cache_size)
 
-    free (fate);
 
-  else
 
-    {
 
-      fate->alters = available_portal;
 
-      available_portal = fate;
 
-      available_portals++;
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_portals ()
 
-
 
-     /* This initializes some static data structures in modules used
 
-	by this one. */
 
-
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_ports ();
 
-}
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_portals ()
 
-
 
-     /* This frees up the cache and reports a memory leak if appropriate. */
 
-
 
-{
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  if (extant_portals)
 
-    avm_reclamation_failure ("portals", extant_portals);
 
-}

+ 0 - 133
src/ports.c
View File 

@@ -1,133 +0,0 @@
 
-
 
-/* memory management for ports and packets
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-
 
-*/
 
-
 
-#include <avm/error.h>
 
-#include <avm/ports.h>
 
-
 
-
 
-/* a pointer to a fast local cache of reusable packets */
 
-static port available_port = NULL;
 
-
 
-/* the number of packets currently in the cache */
 
-static counter available_ports = 0;
 
-
 
-/* the total number of allocated packets excluding those in the cache */
 
-static counter extant_ports = 0;
 
-
 
-/* a non-zero value means static variables have been initialized */
 
-static int initialized = 0;
 
-
 
-/* the maximum number of packets allowed in the cache simultaneously */
 
-#define port_cache_size 0xff
 
-
 
-
 
-
 
-
 
-port
 
-avm_newport (errors, parent, predicating)
 
-     counter errors;
 
-     port parent;
 
-     int predicating;
 
-
 
-     /* This attempts to create storage for a new port, initializing
 
-        the given fields as shown if successful, and returning
 
-        @code{NULL} otherwise. It interacts with the cache for better
 
-        performance. All uninitialized fields are filled with
 
-        zeros. */
 
-{
 
-  port result;
 
-
 
-  if (result = available_port)
 
-    {
 
-      available_port = available_port->parent;
 
-      available_ports--;
 
-    }
 
-  else
 
-    result = (port) (malloc (sizeof (*result)));
 
-  if (result)
 
-    {
 
-      extant_ports++;
 
-      memset (result, 0, sizeof (*result));
 
-      result->predicating = predicating;
 
-      result->errors = errors;
 
-      result->parent = parent;
 
-    }
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_sever (appendage)
 
-     port appendage;
 
-
 
-     /* This frees the memory associated with a given port, or stores
 
-	it in the cache if possible. */
 
-
 
-{
 
-
 
-  extant_ports--;
 
-  if (!appendage)
 
-    avm_internal_error (28);
 
-  if (available_ports > port_cache_size)
 
-    free (appendage);
 
-  else
 
-    {
 
-      appendage->parent = available_port;
 
-      available_port = appendage;
 
-      available_ports++;
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_ports ()
 
-
 
-     /* This initializes some local static data structures in the
 
-	lists module if they haven't been done already. */
 
-
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-}
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_ports ()
 
-
 
-     /* This detects and reports memory leaks by unreclaimed ports. */
 
-
 
-{
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  if (extant_ports)
 
-    avm_reclamation_failure ("ports", extant_ports);
 
-}

+ 0 - 224
src/profile.c
View File 

@@ -1,224 +0,0 @@
 
-
 
-/* profiling operations
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.  
-*/
 
-
 
-#include <avm/error.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/compare.h>
 
-#include <avm/profile.h>
 
-
 
-/* a data base of profile statistics, with one item for each profiled code fragment */
 
-static score board = NULL;
 
-
 
-/* non-zero means local variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* represents (nil,nil) */
 
-static list shared_cell = NULL;
 
-
 
-/* an error message represented as a list of lists of character representations */
 
-static list memory_overflow = NULL;
 
-
 
-
 
-
 
-
 
-score
 
-avm_entries (team, message, fault)
 
-     list team;
 
-     list *message;
 
-     int *fault;
 
-
 
-     /* This looks up an entry in the score board whose team is given,
 
-        or creates it if there isn't one, and returns the pointer to
 
-        it; also increments the number of calls to the one looked
 
-        up. */
 
-
 
-{
 
-  list temporary;
 
-  score opened;
 
-  int found;
 
-
 
-  opened = board;
 
-  found = *fault = 0;
 
-  *message = NULL;
 
-  while (!!opened & !*fault & !found)
 
-    {
 
-      if (found = ((*message = avm_binary_comparison (team, opened->team, fault)) ? !*fault : 0))
 
-	{
 
-	  avm_dispose (*message);
 
-	  (opened->calls)++;
 
-	  *message = NULL;
 
-	}
 
-      else if (!*fault)
 
-	opened = opened->league;
 
-    }
 
-  if (!*fault & !found)
 
-    {
 
-      if (*fault = !(opened = (score) (malloc (sizeof (*opened)))))
 
-	*message = avm_copied (memory_overflow);
 
-      else
 
-	{
 
-	  memset (opened, 0, sizeof (*opened));
 
-	  opened->team = avm_copied (team);
 
-	  opened->league = board;
 
-	  board = opened;
 
-	}
 
-    }
 
-  return (*fault ? NULL : opened);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_tally (filename)
 
-     char *filename;
 
-
 
-     /* This outputs profile information to the file in a bare bones
 
-	format suitable for major embellishments. */
 
-
 
-{
 
-  FILE *pro_file;
 
-  int ioerror;
 
-  list name;
 
-  score old,reversed_board,temporary;
 
-  double total,average,percentage;
 
-  counter calls,reductions;
 
-  int warned;
 
-  int datum;
 
-
 
-  if (!initialized)
 
-    avm_initialize_profile ();
 
-  total = 0.0;
 
-  old = board;
 
-  warned = 0;
 
-  while (old)
 
-    {
 
-      total = total + (double) (old->reductions);
 
-      old = old->league;
 
-    }
 
-  reversed_board = NULL;
 
-  while (board)
 
-    {
 
-      temporary = board;
 
-      board = board->league;
 
-      temporary->league = reversed_board;
 
-      reversed_board = temporary;
 
-    }
 
-  board = reversed_board; /* display in order of invocation */
 
-  if (board ? board->league : 0) /* except for the unprofiled */
 
-    {
 
-      old = board;
 
-      temporary = board;
 
-      board = board->league;
 
-      while (temporary ? temporary->league : 0)
 
-	temporary = temporary->league;
 
-      old->league = NULL;
 
-      temporary->league = old;
 
-    }
 
-  if (board ? board->league : 0)
 
-    {
 
-      if (ioerror = !(pro_file = fopen (filename, "w")))
 
-	avm_non_fatal_io_error ("can't write", filename, errno);
 
-      else
 
-	{
 
-	  ioerror = fprintf(pro_file, "\n%12s  %12s  %12s  %12s\n\n","invocations","reductions", "average", "percentage");
 
-	  if (ioerror = (ioerror == EOF))
 
-	    avm_non_fatal_io_error ("can't write to", filename, errno);
 
-	  while (!!board & !ioerror)
 
-	    {
 
-	      ioerror = (EOF == fprintf(pro_file, "%12u  ",calls = board->calls + 1));
 
-	      ioerror = (ioerror ? 1 : (EOF == fprintf(pro_file, "%12u  ",reductions = board->reductions)));
 
-	      average = ((double) reductions) / ((double) calls);
 
-	      percentage = 100.0 * (((double) reductions) / total);
 
-	      ioerror = (ioerror ? 1 : (EOF == fprintf(pro_file, "%12.1f  ",average)));
 
-	      ioerror = (ioerror ? 1 : (EOF == fprintf(pro_file, "%12.3f  ",percentage)));
 
-	      name = board->team;
 
-	      while (!ioerror & !!name)
 
-		{
 
-		  if (ioerror = ((datum = avm_character_code (name->head)) < 0))
 
-		    {
 
-                      if(warned ? 0 : ++warned)
 
-			avm_warning ("invalid profile identifier");
 
-		    }
 
-		  else if (ioerror = (putc (datum, pro_file) != datum))
 
-		    avm_non_fatal_io_error ("can't write to", filename,errno);
 
-		  name = name->tail;
 
-		}
 
-	      if (ioerror = (putc ('\n', pro_file) != '\n'))
 
-		avm_non_fatal_io_error ("can't write to", filename, errno);
 
-	      avm_dispose (board->team);
 
-	      board = (old = board)->league;
 
-	      free (old);
 
-	    }
 
-	  if (EOF == fprintf (pro_file, "\n%.0f reductions in total\n\n", total))
 
-	    avm_non_fatal_io_error ("can't write to", filename, errno);
 
-	  if (fclose (pro_file))
 
-	    avm_non_fatal_io_error ("can't close", filename, errno);
 
-	}
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_profile ()
 
-
 
-     /* This initializes static data, which includes a global table of
 
-	profile statistics. */
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_chrcodes ();
 
-  avm_initialize_compare ();
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_profile ()
 
-
 
-     /* This frees static data. */
 
-{
 
-  score old;
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (memory_overflow);
 
-  memory_overflow = NULL;
 
-  while (board)
 
-    {
 
-      avm_dispose (board->team);
 
-      board = (old = board)->league;
 
-      free (old);
 
-    }
 
-}

+ 0 - 413
src/rawio.c
View File 

@@ -1,413 +0,0 @@
 
-
 
-/* functions for shifting data between lists in memory and raw format files
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.  
-*/
 
-
 
-#include <netdb.h>
 
-#include <stdint.h>
 
-#include <errno.h>
 
-#include <poll.h>
 
-#include <netinet/in.h>
 
-#include <sys/socket.h>
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/branches.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/rawio.h>
 
-#if HAVE_GCRYPT
 
-#include <gcrypt.h>
 
-#endif
 
-
 
-
 
-/* This is number of characters between line breaks in raw
 
-   output. Feel free to change it. */
 
-
 
-#define file_width 79
 
-#define WORD_SIZE 8       /* for binary transfers; at most sizeof char */
 
-#define PACKET_SIZE 1024
 
-#define OFFSET 0          /* can be set to 60 with a WORD_SIZE of 6 to match printable format */
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-#if HAVE_GCRYPT
 
-static gcry_md_hd_t hash_context;
 
-#endif
 
-
 
-
 
-static int
 
-sent_bit (repository, bit, filename, spool, spoke, column)
 
-     FILE *repository;
 
-     int bit;
 
-     char *filename;
 
-     int *spool;
 
-     int *spoke;
 
-     int *column;
 
-
 
-     /* This puts a bit into a file, using a byte to spool them
 
-        between calls. This has to be called a bunch of times at the
 
-        end of the data in order to ensure that any unwritten bits get
 
-        flushed. */
 
-{
 
-  int ioerror;
 
-
 
-  ioerror = 0;
 
-  (*spool) = ((*spool) << 1) + bit;
 
-  if (((*spoke)++) == 5)
 
-    {
 
-      (*spool) += 60;
 
-      if (ioerror = (putc (*spool, repository) != (*spool)))
 
-	avm_non_fatal_io_error ("can't write to", filename, errno);
 
-      else if (++(*column) == file_width)
 
-	{
 
-	  if (ioerror = (putc ('\n', repository) != '\n'))
 
-	    avm_non_fatal_io_error ("can't write to", filename, errno);
 
-	  *column = 0;
 
-	}
 
-      *spool = *spoke = 0;
 
-    }
 
-  return !ioerror;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-static int
 
-received_bit (object, filename, spoke, spool)
 
-     FILE *object;
 
-     char *filename;
 
-     int *spoke;
 
-     int *spool;
 
-
 
-     /* This gets the next bit from the file, dealing with the hassle
 
-        of unpacking them from characters. */
 
-{
 
-  int last_character;
 
-
 
-  if (!((*spoke)--))
 
-    {
 
-      do
 
-	{
 
-	  (*spool) = getc (object);
 
-	  if ((*spool) == '#')
 
-	    {
 
-	      do
 
-		{
 
-		  last_character = *spool;
 
-		  (*spool) = getc (object);
 
-		}
 
-	      while ((*spool) == EOF ? 0 : (*spool) == '\n' ? (last_character == '\\') : 1);
 
-	    }
 
-	}
 
-      while ((*spool) == EOF ? 0 : ((*spool) == '\n' ? 1 : 0));
 
-      if ((*spool) == EOF ? 1 : (*spool) < 60 ? 1 : ((*spool) = (*spool) - 60) & 0xffc0)
 
-	avm_fatal_io_error ("invalid raw file format in", filename, 0);
 
-      (*spoke) = 5;
 
-    }
 
-  return (((*spool) >> (*spoke)) & 1);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_send_list (repository, operand, filename)
 
-     FILE *repository;
 
-     list operand;
 
-     char *filename;
 
-
 
-     /* This puts a list into a raw format file. */
 
-
 
-{
 
-  list front, queue, old;
 
-  int spool, spoke, column;
 
-
 
-  if (!initialized)
 
-    avm_initialize_rawio ();	/* if the caller didn't do what it should */
 
-  front = queue = NULL;
 
-  spool = spoke = column = 0;
 
-  avm_enqueue (&front, &queue, avm_copied (operand));
 
-  while (front ? sent_bit (repository, front->head ? 1 : 0, filename, &spool, &spoke, &column) : 0)
 
-    {
 
-      if (front->head)
 
-	{
 
-	  avm_enqueue (&front, &queue, avm_copied (front->head->head));
 
-	  avm_enqueue (&front, &queue, avm_copied (front->head->tail));
 
-	}
 
-      front = avm_copied ((old = front)->tail);
 
-      avm_dispose (old);
 
-    }
 
-  while (spoke ? sent_bit (repository, 0, filename, &spool, &spoke, &column) : 0);
 
-  if (front)
 
-    avm_dispose (front);
 
-  else if (putc ('\n', repository) != '\n')
 
-    avm_non_fatal_io_error ("can't write to", filename, errno);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_recoverable_send_list (sockfd, operand, crc, timeout, closed, fault)
 
-     int sockfd;
 
-     list operand;
 
-     char **crc;
 
-     int *timeout;
 
-     int *closed;
 
-     int *fault;
 
-
 
-     /* differs from avm_send_list by using a socket descriptor rather
 
-        than a file, using binary rather than printable characters,
 
-        and setting the fault parameter rather than aborting or
 
-        writing an error message in the event of a fault; also
 
-        computes a 32 bit cyclic redundancy check, which should be
 
-        freed by the caller */
 
-
 
-{
 
-  char packet_buffer[PACKET_SIZE];
 
-  char *cursor;
 
-  list front, back, old;
 
-  int words, bits, next_bit, sent, last_packet_size;
 
-
 
-#if HAVE_GCRYPT
 
-  if (!initialized)
 
-    avm_initialize_rawio ();
 
-  gcry_md_reset (hash_context);
 
-  front = back = NULL;
 
-  *closed = *timeout = words = bits = (int) (*(cursor = packet_buffer) = 0);
 
-  avm_recoverable_enqueue (&front, &back, avm_copied (operand), fault);
 
-  while (*fault ? NULL : *timeout ? NULL: front)
 
-    {
 
-      if (next_bit = (front->head ? 1 : 0))
 
-	{
 
-	  avm_recoverable_enqueue (&front, &back, avm_copied (front->head->head), fault);
 
-	  avm_recoverable_enqueue (&front, &back, avm_copied (front->head->tail), fault);
 
-	}
 
-      if (!*fault)
 
-	{
 
-	  front = avm_copied ((old = front)->tail);
 
-	  avm_dispose (old);
 
-	  if (bits++ == WORD_SIZE)
 
-	    {
 
-	      bits = 1;
 
-	      (*(cursor++)) += OFFSET;
 
-	      if (words++ == PACKET_SIZE)
 
-		{
 
-		  words = sent = 0;
 
-		  gcry_md_write (hash_context, packet_buffer, PACKET_SIZE);
 
-		  while ((*timeout = (*timeout ? 1 : (sent < 0))) ? 0 : ((words += sent) < PACKET_SIZE))
 
-		    {
 
-		      sent = send (sockfd, &(packet_buffer[words]), PACKET_SIZE - words, MSG_NOSIGNAL | MSG_MORE);
 
-		      *timeout = !sent;
 
-		    }
 
-		  *closed = (!*timeout ? 0 : !sent ? 1 : (errno == ENOTCONN) ? 1 : (errno == ECONNREFUSED));
 
-		  words = (int) ((*(cursor = packet_buffer)) = 0);
 
-		}
 
-	    }
 
-	  (*cursor) = ((*cursor) << 1) | next_bit;
 
-	}
 
-    }
 
-  avm_dispose (front);
 
-  (*cursor) = ((*cursor) << (WORD_SIZE - bits)) + OFFSET;
 
-  if (last_packet_size = words + (bits ? 1 : 0))
 
-    gcry_md_write (hash_context, packet_buffer, last_packet_size);
 
-  if (!(*crc = strdup (gcry_md_read (hash_context, GCRY_MD_CRC32_RFC1510))))
 
-    *fault = 1;
 
-  words = sent = 0;
 
-  if (*fault ? 0 : !(*timeout))
 
-    while ((*timeout = (*timeout ? 1 : (sent < 0))) ? 0 : ((words += sent) < last_packet_size))
 
-      *timeout = !(sent = send (sockfd, &(packet_buffer[words]), last_packet_size - words, MSG_NOSIGNAL));
 
-  *closed = (*closed ? 1 : !*timeout ? 0 : (sent == 0) ? 1 : (errno == ENOTCONN) ? 1 : (errno == ECONNREFUSED));
 
-  return;
 
-#endif
 
-  avm_error ("I need avram built with libgcrypt.");
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_recoverable_received_list (sockfd, crc, timeout, closed, fault)
 
-     int sockfd;
 
-     char **crc;
 
-     int *timeout;
 
-     int *closed;
 
-     int *fault;
 
-
 
-     /* like received_list but using sockets and not aborting; also
 
-        checks for the absence of spurious trailing input and computes
 
-        a 32 bit crc, which should be freed by the caller */
 
-{
 
-  struct pollfd fds;
 
-  list result;
 
-  char packet_buffer[PACKET_SIZE];
 
-  char *cursor;
 
-  branch_queue front,back;
 
-  int bits,words,received,last_packet_size;
 
-
 
-#if HAVE_GCRYPT
 
-  if (!initialized)
 
-    avm_initialize_rawio ();
 
-  gcry_md_reset (hash_context);
 
-  front = back = NULL;
 
-  words = bits = 0;
 
-  cursor = packet_buffer;
 
-  avm_recoverable_anticipate (&front, &back, &result, fault);
 
-  *closed = *timeout = (*fault ? 0 : ((received = recv (sockfd, packet_buffer, PACKET_SIZE, MSG_NOSIGNAL)) <= 0));
 
-  gcry_md_write (hash_context, packet_buffer, received);
 
-  (*cursor) -= OFFSET;
 
-  while (*fault ? NULL : *timeout ? NULL : front)
 
-    {
 
-      if (bits++ == WORD_SIZE)
 
-	{
 
-	  bits = 1;
 
-	  cursor++;
 
-	  if (++words == received)
 
-	    {
 
-              cursor = packet_buffer;
 
-	      *timeout = ((received = recv (sockfd, packet_buffer, PACKET_SIZE, MSG_NOSIGNAL)) <= 0);
 
-	      gcry_md_write (hash_context, packet_buffer, received);
 
-	      *closed = (!*timeout ? 0 : (received == 0) ? 1 : (errno == ENOTCONN) ? 1 : (errno == ECONNREFUSED));
 
-	      words = 0;
 
-	    }
 
-	  (*cursor) -= OFFSET;
 
-	}
 
-      avm_recoverable_enqueue_branch(&front, &back, ((*cursor) >> (WORD_SIZE - bits)) & 1, fault);
 
-    }
 
-  avm_dispose_branch_queue (front);
 
-  if (!(*crc = strdup (gcry_md_read (hash_context, GCRY_MD_CRC32_RFC1510))))
 
-    *fault = 1;
 
-  fds.fd = sockfd;
 
-  fds.events = POLLIN;
 
-  *fault = (*fault ? 1 : (*timeout = (*timeout ? 1 : ((words + (bits ? 1 : 0)) != received))));
 
-  if (*fault = (*fault ? 1 : (poll (&fds, 1, 0) < 0) ? 1 : (fds.revents & POLLIN)))
 
-    {
 
-      avm_dispose (result);
 
-      while ((poll (&fds, 1, 0) == 0) ? (fds.revents & POLLIN) : 0)
 
-	received = recv (sockfd, packet_buffer, PACKET_SIZE, MSG_NOSIGNAL);  /* flush spurious trailing data */
 
-      return NULL;
 
-    }
 
-  return result;
 
-#endif
 
-  avm_error ("I need avram built with libgcrypt.");
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_received_list (object, filename)
 
-     FILE *object;
 
-     char *filename;
 
-
 
-     /* This reads a list from a file that better be in raw format. */
 
-{
 
-  list result;
 
-  int spoke, spool;
 
-  branch_queue old, front, back;
 
-
 
-  if (!initialized)
 
-    avm_initialize_rawio ();	/* if the caller didn't do what it should */
 
-  spoke = spool = 0;
 
-  front = back = NULL;
 
-  avm_anticipate (&front, &back, &result);
 
-  while (front)
 
-    {
 
-      if (*(front->above) = (received_bit (object, filename, &spoke, &spool) ? avm_join (NULL, NULL) : NULL))
 
-	{
 
-	  avm_anticipate (&front, &back, &((*(front->above))->head));
 
-	  avm_anticipate (&front, &back, &((*(front->above))->tail));
 
-	}
 
-      front = (old = front)->following;
 
-      avm_dispose_branch (old);
 
-    }
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_rawio ()
 
-     /* This is called at the beginning before any of the others, if
 
-        the calling program is conforming to the specs. */
 
-{
 
-  int fault;
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_branches ();
 
-  avm_initialize_chrcodes ();
 
-#if HAVE_GCRYPT
 
-  fault = ! gcry_check_version (NULL);
 
-  fault = (fault ? 1 : (gcry_control (GCRYCTL_DISABLE_SECMEM) != GPG_ERR_NO_ERROR));
 
-  fault = (fault ? 1 : (gcry_control (GCRYCTL_SET_VERBOSITY, 0) != GPG_ERR_NO_ERROR));
 
-  fault = (fault ? 1 : (gcry_control (GCRYCTL_INITIALIZATION_FINISHED) != GPG_ERR_NO_ERROR));
 
-  fault = (fault ? 1 : (gcry_md_open (&hash_context, GCRY_MD_CRC32_RFC1510, 0) != GPG_ERR_NO_ERROR));
 
-  if (fault = (fault ? 1 : ! gcry_md_is_enabled (hash_context, GCRY_MD_CRC32_RFC1510)))
 
-    avm_error ("unable to initialize libgcrypt");
 
-#endif
 
-}
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_rawio ()
 
-
 
-     /* This is just a hook if you want to put something here; client
 
-        programs are supposed to call this at the end of a run. */
 
-{
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-#if HAVE_GCRYPT
 
-  gcry_md_close (hash_context);
 
-#endif
 
-}

+ 0 - 431
src/remote.c
View File 

@@ -1,431 +0,0 @@
 
-
 
-/* pertaining to execution of virtual machine code on remote servers
 
-
 
-   Copyright (C) 2010 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-*/
 
-
 
-#include <netdb.h>
 
-#include <stdint.h>
 
-#include <fcntl.h>
 
-#include <errno.h>
 
-#include <poll.h>
 
-#include <netinet/in.h>
 
-#include <sys/time.h>
 
-#include <sys/socket.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/apply.h>
 
-#include <avm/branches.h>
 
-#include <avm/rawio.h>
 
-#include <avm/compare.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/servlist.h>
 
-#include <avm/farms.h>
 
-#include <avm/jobs.h>
 
-#include <avm/vglue.h>
 
-#include <avm/remote.h>
 
-
 
-/* Non-zero means static variables have been initialized. */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list memory_overflow = NULL;
 
-
 
-/* virtual code for the function that turns a two item list into a pair */
 
-static list listopair = NULL;
 
-
 
-/* virtual code for the function that takes the head of a list */
 
-static list listhead = NULL;
 
-
 
-/* used for constructing virtual code */
 
-static list shared_cell = NULL;
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-int
 
-avm_remotely_constructed (left_side, right_side, operand, result, fault)
 
-     list left_side;
 
-     list right_side;
 
-     list operand;
 
-     list *result;
 
-     int *fault;
 
-
 
-     /* this implements concurrent evaluation of functions of the form couple(f,g) */
 
-{
 
-  job front,back,top;
 
-
 
-  if (!initialized)
 
-    avm_initialize_remote ();
 
-  *result = NULL;
 
-  if (*fault ? 1 : avm_offline ())
 
-    return 0;
 
-  front = back = top = NULL;
 
-  avm_new_job (&front, &back, avm_compose (avm_copied (left_side), avm_copied (listhead), fault), NULL, NULL, 1, fault);
 
-  if (! (*fault = (*fault ? 1 : !back)))
 
-    avm_new_job (&(back->prerequisites), NULL, avm_copied (operand), back, NULL, 0, fault);
 
-  avm_new_job (&front, &back, avm_compose (avm_copied (right_side), avm_copied (listhead), fault), NULL, NULL, 1, fault);
 
-  if (! (*fault = (*fault ? 1 : !back)))
 
-    avm_new_job (&(back->prerequisites), NULL, avm_copied (operand), back, NULL, 0, fault);
 
-  avm_new_job (&top,  NULL,  avm_copied (listopair), NULL, front, 2, fault);
 
-  *result = (*fault ? avm_copied (memory_overflow) : avm_evaluation (top, 0, fault));
 
-  return 1;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static counter
 
-balanced (operand_length, granularity)
 
-     counter operand_length;
 
-     counter granularity;
 
-
 
-     /* finds the maximum size for nearly equal blocks not exceeding
 
-	the granularity */
 
-{
 
-  counter block_size, blocks;
 
-
 
-  if (!granularity)
 
-    return 0;
 
-  if ((blocks = operand_length / granularity) * granularity < operand_length)
 
-    blocks++;
 
-  block_size = operand_length / blocks;
 
-  while (block_size * blocks < operand_length)
 
-    block_size++;
 
-  return block_size;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-int
 
-avm_remotely_mapped (operator, operand, result, granularity, fault)
 
-     list operator;
 
-     list operand;
 
-     list *result;
 
-     counter granularity;
 
-     int *fault;
 
-
 
-     /* This gets called by the main universal function, apply, when
 
-        it determines that distributed evaluation is indicated for a
 
-        function of the form map(operator) (in Ursala notation). If a
 
-        distributed evaluation can't be performed due to being off
 
-        line, this function returns zero and the caller performs the
 
-        evaluation locally.  Otherwise, the result of the evaluation
 
-        is placed in the result list and the function returns a
 
-        non-zero value.
 
-
 
-        The granularity is interpreted as the maximum size of a
 
-        sublist to be evaluated on a single host. The job tree has a
 
-        constant depth regardless of the granularity, and its root is
 
-        a flattening function indicated by shared_cell. */
 
-
 
-{
 
-  int dependence;
 
-  job front,back,top,bottom;
 
-  counter operand_length, block_size, block_member;
 
-
 
-  if (!initialized)
 
-    avm_initialize_remote ();
 
-  *result = NULL;
 
-  if (*fault ? 1 : avm_offline () ? 1 : (operand_length = avm_recoverable_length (operand)) <= granularity)
 
-    return 0;
 
-  dependence = 0;
 
-  front = back = NULL;
 
-  if (!(block_size = balanced (operand_length, granularity)))
 
-    block_size = 1;
 
-  if (block_size == 1)
 
-    operator = avm_compose (avm_copied (operator), avm_copied (listhead), fault);
 
-  else
 
-    operator = avm_map (avm_copied (operator), fault);
 
-  while (*fault ? NULL : operand)
 
-    {
 
-      bottom = NULL;
 
-      block_member = block_size;
 
-      avm_new_job (&front, &back, avm_copied (operator), NULL, NULL, 0, fault);
 
-      while (*fault ? 0 : operand ? block_member-- : 0)
 
-	{
 
-	  avm_new_job (&(back->prerequisites), &bottom, avm_copied (operand->head), back, NULL, 0, fault);
 
-	  operand = operand->tail;
 
-	  (back->dependence)++;
 
-	}
 
-      dependence++;
 
-    }
 
-  avm_new_job (&top, NULL, (block_size == 1 ? NULL : avm_copied (shared_cell)), NULL, front, dependence, fault);
 
-  avm_dispose (operator);
 
-  *result = (*fault ? avm_copied (memory_overflow) : avm_evaluation (top, 0, fault));
 
-  return 1;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-int
 
-avm_remotely_reduced (operator, vacuous_case, operand, result, granularity, balanceable, fault)
 
-     list operator;
 
-     list vacuous_case;
 
-     list operand;
 
-     list *result;
 
-     counter granularity;
 
-     flag balanceable;
 
-     int *fault;
 
-
 
-     /* This function is similar to avm_remotely_mapped, but pertains
 
-        to functions of the form reduce(f,k), where the operator
 
-        corresponds to f and the vacuous case to k.
 
-
 
-        The job tree has logarithmic depth in the length of the
 
-        operand, and each non-terminal node has a linearly many
 
-        prerequisites in the granularity. */
 
-{
 
-  job front,back,top,bottom;
 
-  counter operand_length, block_size, block_member;
 
-
 
-  if (!initialized)
 
-    avm_initialize_remote ();
 
-  *result = NULL;
 
-  if (!(operand ? operand->tail : NULL))
 
-    {
 
-      *result = avm_copied (operand ? operand->head : vacuous_case);
 
-      return 1;
 
-    }
 
-  if (*fault ? 1 : avm_offline() ? 1 : (operand_length = avm_recoverable_length (operand)) <= granularity)
 
-    return 0;
 
-  if ((block_size = balanced (operand_length, granularity)) < 2)
 
-    block_size = 2;
 
-  if (block_size == 2)
 
-    operator = avm_compose (avm_copied (operator), avm_copied (listopair), fault);
 
-  else
 
-    operator = avm_reduce (avm_copied (operator), fault);
 
-  front = back = top = NULL;
 
-  operand_length = 0;
 
-  while (*fault ? NULL : operand ? operand->tail : NULL)
 
-    {
 
-      bottom = NULL;
 
-      operand_length++;
 
-      block_member = block_size;
 
-      avm_new_job (&front, &back, avm_copied (operator), NULL, NULL, 0, fault);
 
-      while (*fault ? 0 : operand ? block_member-- : 0)
 
-	{
 
-	  avm_new_job (&(back->prerequisites), &bottom, avm_copied (operand->head), back, NULL, 0, fault);
 
-	  operand = operand->tail;
 
-	  (back->dependence)++;
 
-	}
 
-    }
 
-  if (*fault ? NULL : operand)
 
-    avm_new_job (&front, &back, avm_copied (operand->head), NULL, NULL, 0, fault);
 
-  top = front;
 
-  while (*fault ? NULL : top->corequisites)
 
-    {
 
-      if ((block_size = balanced (operand_length, granularity)) < 2)
 
-	block_size = 2;
 
-      operand_length = 0;
 
-      front = back = NULL;
 
-      while (*fault ? NULL : top ? top->corequisites : NULL)
 
-	{
 
-	  bottom = NULL;
 
-	  operand_length++;
 
-	  block_member = block_size;
 
-	  avm_new_job (&front, &back, avm_copied (operator), NULL, NULL, 0, fault);
 
-	  while (*fault ? 0 : top ? block_member-- : 0)
 
-	    avm_queue_job (&(back->prerequisites), &bottom, &top, back);
 
-	}
 
-      if (*fault ? NULL : top)
 
-	{
 
-	  operand_length++;
 
-	  avm_queue_job (&front, &back, &top, NULL);
 
-	}
 
-      top = front;
 
-    }
 
-  avm_dispose (operator);
 
-  *result = (*fault ? avm_copied (memory_overflow) : avm_evaluation (top, balanceable, fault));
 
-  return 1;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-int
 
-avm_remotely_sorted (operator, operand, result, granularity, fault)
 
-     list operator;
 
-     list operand;
 
-     list *result;
 
-     counter granularity;
 
-     int *fault;
 
-
 
-     /* This implements a distributed sort given the relational
 
-	operator and the granularity.
 
-
 
-        The job tree has logarithmic depth in the length of the
 
-        operand, and the lowest level non-terminal nodes have linearly
 
-        many descendents in the granularity, but above that they're
 
-        all binary. */
 
-{
 
-  job front,back,top,middle,bottom;
 
-  counter operand_length, block_size, block_member;
 
-  list sorter,merger;
 
-
 
-  if (!initialized)
 
-    avm_initialize_remote ();
 
-  *result = NULL;
 
-  if (!(operand ? operand->tail : NULL))
 
-    {
 
-      *result = avm_copied (operand);
 
-      return 1;
 
-    }
 
-  if (*fault ? 1 : avm_offline() ? 1 : (operand_length = avm_recoverable_length (operand)) <= granularity)
 
-    return 0;
 
-  if ((block_size = balanced (operand_length, granularity)) < 2)
 
-    block_size = 2;
 
-  front = back = top = NULL;
 
-  sorter = avm_sort (avm_copied (operator), fault);
 
-  merger = avm_compose (avm_merge (avm_copied (operator), fault), avm_copied (listopair), fault);
 
-  while (*fault ? NULL : (operand ? operand->tail : NULL))
 
-    {
 
-      middle = NULL;
 
-      block_member = block_size;
 
-      avm_new_job (&front, &back, avm_copied ((block_size == 2) ? merger : sorter), NULL, NULL, 0, fault);
 
-      while ((*fault = (*fault ? 1 : !back)) ? 0 : operand ? block_member-- : 0)
 
-	{
 
-	  if (block_size != 2)
 
-	    avm_new_job (&(back->prerequisites), &middle, avm_copied (operand->head), back, NULL, 0, fault);
 
-	  else
 
-	    {
 
-	      avm_new_job (&(back->prerequisites), &middle, NULL, back, NULL, 1, fault);
 
-	      if (! (*fault = (*fault ? 1 : !middle)))
 
-		avm_new_job (&(middle->prerequisites), NULL, avm_copied (operand->head), middle, NULL, 0, fault);
 
-	    }
 
-	  operand = operand->tail;
 
-	  (back->dependence)++;
 
-	}
 
-    }
 
-  if (*fault ? NULL : operand)
 
-    {
 
-      avm_new_job (&front, &back, NULL, NULL, NULL, 1, fault);
 
-      if (! (*fault = (*fault ? 1 : !back)))
 
-	avm_new_job (&(back->prerequisites), NULL, avm_copied (operand->head), back, NULL, 0, fault);
 
-    }
 
-  top = front;
 
-  while (*fault ? NULL : top->corequisites)
 
-    {
 
-      front = back = NULL;
 
-      while (*fault ? NULL : (top ? top->corequisites : NULL))
 
-	{
 
-	  avm_new_job (&front, &back, avm_copied (merger), NULL, NULL, 0, fault);
 
-	  bottom = NULL;
 
-	  if (! (*fault = (*fault ? 1 : !back)))
 
-	    {
 
-	      avm_queue_job (&(back->prerequisites), &bottom, &top, back);
 
-	      avm_queue_job (&(back->prerequisites), &bottom, &top, back);
 
-	    }
 
-	}
 
-      if (*fault ? NULL : top)
 
-	avm_queue_job (&front, &back, &top, NULL);
 
-      top = front;
 
-    }
 
-  avm_dispose (merger);
 
-  avm_dispose (sorter);
 
-  *result = (*fault ? avm_copied (memory_overflow) : avm_evaluation (top, 1, fault));
 
-  return 1;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_remote ()
 
-
 
-     /* This initializes static data structures. */
 
-{
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_branches ();
 
-  avm_initialize_apply ();
 
-  avm_initialize_compare ();
 
-  avm_initialize_jobs ();
 
-  avm_initialize_farms ();
 
-  avm_initialize_vglue ();
 
-  listhead = avm_scanned_list("h<");
 
-  listopair = avm_scanned_list("kE<");
 
-  shared_cell = avm_join (NULL, NULL);
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_remote ()
 
-
 
-{
 
-  server_list old,servers;
 
-
 
-  if (!initialized)
 
-    return;
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (listopair);
 
-  avm_dispose (listhead);
 
-  avm_dispose (shared_cell);
 
-  shared_cell = NULL;
 
-  memory_overflow = NULL;
 
-  listopair = NULL;
 
-  listhead = NULL;
 
-  initialized = 0;
 
-}

+ 0 - 34
src/rewrite.c
View File 

@@ -1,34 +0,0 @@
 
-
 
-/* This is the virtual machine code expressed as a c formatted character
 
-   constant for a function that takes a virtual machine program to an equivalent
 
-   program by translating the top level combinator into more primitive
 
-   combinators if possible. */
 
-
 
-char *interpreter_code = "{kqwd{gOwhO?[[KQkx{xSqoKmH{AczSHkjhsjccwxhcOz{COqQCwA\
 
-woEJRKkn{MYQa`mZBSo^?pZkwWdzwCaailUZB[_nQ]zKkypqGPqUzsPPtUz=CwLUgAxsKkqZRPzHZhS\
 
-aOgS<Mzb[aVnBSosqhzvQNq?yJodUZwPmJEct@Cvhn=cuQqWqFyKo`bWQtWWNB[qI]GL@CvE{xc<Mzr\
 
-ZS=upi^{OUQmcQPao<@[r?NGDcth[oKAectwIKHpRHrkjmPtuQWciDfU{NT>^mz<EZUac\\L[cHvXxv\
 
-ZyPGz{W]OrUOQZpR=={yK\\>S^WoEuz^[pfqvyGR[]W^hgFiXqgQQTwiPUN^[yQPnEja{NcwAth[w\
 
-\\VSeR=alScqoFngHuUXVmiaqrUdTh[kt`Me[f]z<HS]at<auySKVuiiFScyNKGnkWMQMEqIYMPSOH\
 
-\\>SksM@f]z>EZBS]ctbxqaMxHrhqNCcwAxnafRFSqZJoG^qJjQTl\\bvzqt>>EZf[]ct@[e[mbjQF_\
 
-HnJ><@[]a{>CpZew=sOQUa`tqIjpdazKjgP^ez@]z=CvUzfCwgGVVHNXpDatU{qCyCyCwoQgaoIQPwQ\
 
-WNef]{IGPNp@]zlcvUz==z>EZHnALXcAz>ct@[jM=Z?AtLSaNkVPzLjfeR_PT?DDaxxoD]HEz<mZ==z\
 
-^[fcxcJP]UxpNAvUzqfS]avaylPqJWx?NNuSJPbf[qXna<HS\\cvEzGCtNC{AiFCcuT^[\\L[aXZ[]c\
 
-uu{S`jANxot>ppqRB]D[aRft<cz=ZGCt<aw>[acrD[hSaBnZ^[vt<@[\\Mz<@[ySMRdo^Bp^fHwOG>[\
 
-fq]O\\S]at<atbt?AuuzQLS]az\\<[^m{Jp^SecvE[qOcqf?oG\\icPq<<mZ@p]]ateJEjaz>[cxAzN\
 
-atU{XMj<E[Hg>ct@CtezwnqniPi<MV`vu^<ctenFOawe[f]{\\ShSfSpCct@[q>[tbw>FNAvEzNAwyg\
 
-_JGJHPQPGePb=[XvSj\\cvd[\\^S]atUZZ[v<@[ecwd>CvStCdcth[dctx_kFi=Q<e\\?O`=a{KNDEz\
 
-FCtDavezFO]ct<M{V^S\\L[iNEZfCxnWEt<auhciNvnI_GkqHP>`xcD\\d[hEZf[]D[aw\\Mz^SqDez\
 
-^[jNez>EZM\\<[^W\\<[qGJ]AFaOHfG]Zvo<latf[]D[hEz\\cvUzF[j=DS^mzP]D[fcuEBvSuBtD?x\
 
-<rTbVsN>[]\\FctMbw>[\\HS^]z==zNAyVEz<E[blctNCte{f]zc{gz?I@niJ>]{DMbv=W<HS\\cw>S\
 
-dcvE{qbnZEkP\\HShEz<D[\\^S\\D[nKkLJPh=rlayDAhFV>[tAtf[^mzWEviL<CvSv^>[\\HSdavez\
 
-^S_IOQA<=ITf[\\FNIr=ZBS]BW\\>S\\<[gJ@Wf]ze\\S\\cvez@]zf[`yI?^ILMbtx\\DUZFOdAhEj\
 
-MjAPcz>E[DU[\\S]D[hEz@]zIgGpW^=WDe^`uZtefSv[vv<]zf[hFO]aw>[\\HShE{QBCJyPFVJ]Zv>\
 
-[_`fCt>CuPdatNCtAw^`t?AtEz<mZQOErhF_`DDEzFCv>>EZ^SbFezlcv>[aw\\cz=Z>[vbXqG]eDFC\
 
-w>Sbf[fcy<NCt?Atd[dE{\\S]az=[moFj]y]hEZFcv=D[]D[tlctEzlatd[]ateJBSjnf]q=On>ez@U\
 
-jHEzlcy<HStAtf[hEZFOaw^`wxT=rOf\\@Uj\\Rl?At?Az<ctUZ@UjFcuZv>[aw_nNeNsF\\RleDEz>\
 
-[q\\S^`v=W=BWdEzFCv>[iNfuiTdedy\\StAz]auZteF=W>]zlatd[qF<qDi`IN>BS]aydeJ\\ctxFN\
 
-latf[hEZ><d`xDe^`teKPaw^]z\\_lf[]BW^e{fndB]ZuZwd\\cw>Sb^]BWdAh@UkH]P\\\\cv>[yLd\
 
-[^ez\\V=W>bdAhI^\\d[^]{rO>S]BW^>b_`FV@flaw>SfP^ez\\RlJNFJm>Fctf[gb@UjFV\\]d><Mb\
 
-tMbtqF=W?pVB\\Rn=WB^FV\\F>>b^bpdqB<w?Y^DfD>\\ITTUuFDa@=]RrqGfr_PohITwORmaGOJfpg\
 
-TXpoTT`nP\\<";

+ 0 - 522
src/rmathlib.c
View File 

@@ -1,522 +0,0 @@
 
-
 
-/* this file incorporates statistical functions from the R math library
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.  
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/compare.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/rmathlib.h>
 
-#include <math.h>
 
-#include <avm/apply.h>
 
-#if HAVE_FENV
 
-#if HAVE_RMATH
 
-#include <fenv.h>
 
-
 
-typedef double (*r_operator)(double);
 
-typedef double (*rr_operator)(double,double);
 
-typedef double (*rrb_operator)(double,double,int);
 
-typedef double (*rrr_operator)(double,double,double);
 
-typedef double (*rrbb_operator)(double,double,int,int);
 
-typedef double (*rrrb_operator)(double,double,double,int);
 
-typedef double (*rrrbb_operator)(double,double,double,int,int);
 
-
 
-#include <Rmath.h>
 
-
 
-double
 
-Rlog1p(x)        /* work around a bug somewhere in Rmath */
 
-     double x;
 
-{
 
-  return log1p(x);
 
-}
 
-
 
-#endif
 
-#endif
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list bad_rmath_spec = NULL;
 
-static list memory_overflow = NULL;
 
-static list unrecognized_function_name = NULL;
 
-
 
-/* function names as lists of lists of character representations */
 
-static list wild = NULL;
 
-static list funs = NULL;
 
-
 
-
 
-#if HAVE_FENV
 
-#if HAVE_RMATH
 
-
 
-
 
-
 
-
 
-static list
 
-r_evaluation(operator, operand, fault)
 
-     r_operator operator;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* the operator is a C function taking a double to a double, and
 
-	the operand is a list representing a double */
 
-{
 
-  list message;
 
-  double *a,y;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  message = NULL;
 
-  a = (double *) avm_value_of_list(operand,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  y = (*operator)(*a);
 
-  return avm_list_of_value((void *) &y,sizeof(double),fault);
 
-}
 
-
 
-
 
-
 
-
 
-static list
 
-rr_evaluation(operator, operand, fault)
 
-     rr_operator operator;
 
-     list operand;
 
-     int *fault;
 
-
 
-     /* the operator is a C function taking a pair of doubles to a
 
-	double, and the operand is a list representing a pair of
 
-	doubles */
 
-{
 
-  list message;
 
-  double *a,*b,y;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  message = NULL;
 
-  if (*fault = !operand)
 
-    return avm_copied(bad_rmath_spec);
 
-  a = (double *) avm_value_of_list(operand->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  b = (double *) avm_value_of_list(operand->tail,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  y = (*operator)(*a,*b);
 
-  return avm_list_of_value((void *) &y,sizeof(double),fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-rrb_evaluation(operator, operand, fault)
 
-     rrb_operator operator;
 
-     list operand;
 
-     int *fault;
 
-{
 
-  list message;
 
-  double *a,*b,y;
 
-  int c;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  message = NULL;
 
-  if (*fault = !(operand ? operand->tail : NULL))
 
-    return avm_copied(bad_rmath_spec);
 
-  a = (double *) avm_value_of_list(operand->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  b = (double *) avm_value_of_list(operand->tail->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  c = !!(operand->tail->tail);
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  y = (*operator)(*a,*b,c);
 
-  return avm_list_of_value((void *) &y,sizeof(double),fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-rrr_evaluation(operator, operand, fault)
 
-     rrr_operator operator;
 
-     list operand;
 
-     int *fault;
 
-{
 
-  list message;
 
-  double *a,*b,*c,y;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  message = NULL;
 
-  if (*fault = !(operand ? operand->tail : NULL))
 
-    return avm_copied(bad_rmath_spec);
 
-  a = (double *) avm_value_of_list(operand->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  b = (double *) avm_value_of_list(operand->tail->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  c = (double *) avm_value_of_list(operand->tail->tail,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  y = (*operator)(*a,*b,*c);
 
-  return avm_list_of_value((void *) &y,sizeof(double),fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-rrrb_evaluation(operator, operand, fault)
 
-     rrrb_operator operator;
 
-     list operand;
 
-     int *fault;
 
-{
 
-  list message;
 
-  double *a,*b,*c,y;
 
-  int d;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  message = NULL;
 
-  if (*fault = !(operand ? (operand->tail ? operand->tail->tail : NULL) : NULL))
 
-    return avm_copied(bad_rmath_spec);
 
-  a = (double *) avm_value_of_list(operand->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  message = NULL;
 
-  b = (double *) avm_value_of_list(operand->tail->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  c = (double *) avm_value_of_list(operand->tail->tail->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  d = !!(operand->tail->tail->tail);
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  y = (*operator)(*a,*b,*c,d);
 
-  return avm_list_of_value((void *) &y,sizeof(double),fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-rrbb_evaluation(operator, operand, fault)
 
-     rrrb_operator operator;
 
-     list operand;
 
-     int *fault;
 
-{
 
-  list message;
 
-  double *a,*b,y;
 
-  int c,d;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  message = NULL;
 
-  if (*fault = !(operand ? (operand->tail ? operand->tail->tail : NULL) : NULL))
 
-    return avm_copied(bad_rmath_spec);
 
-  a = (double *) avm_value_of_list(operand->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  b = (double *) avm_value_of_list(operand->tail->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  c = !!(operand->tail->tail->head);
 
-  d = !!(operand->tail->tail->tail);
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  y = (*operator)(*a,*b,c,d);
 
-  return avm_list_of_value((void *) &y,sizeof(double),fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-rrrbb_evaluation(operator, operand, fault)
 
-     rrrbb_operator operator;
 
-     list operand;
 
-     int *fault;
 
-{
 
-  list message;
 
-  double *a,*b,*c,y;
 
-  int d,e;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (*fault = !(operand ? (operand->tail ? (operand->tail->tail ? (operand->tail->tail->tail) : NULL) : NULL) : NULL))
 
-    return avm_copied(bad_rmath_spec);
 
-  message = NULL;
 
-  a = (double *) avm_value_of_list(operand->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  b = (double *) avm_value_of_list(operand->tail->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  c = (double *) avm_value_of_list(operand->tail->tail->head,&message,fault);
 
-  if (*fault = (*fault ? 1 : !!message))
 
-    return message;
 
-  d = !!(operand->tail->tail->tail->head);
 
-  e = !!(operand->tail->tail->tail->tail);
 
-  feclearexcept (FE_ALL_EXCEPT);  
-  y = (*operator)(*a,*b,*c,d,e);
 
-  return avm_list_of_value((void *) &y,sizeof(double),fault);
 
-}
 
-
 
-
 
-
 
-#endif
 
-#endif
 
-
 
-
 
-
 
-
 
-list
 
-avm_have_rmath_call (function_name,fault)
 
-     list function_name;
 
-     int *fault;
 
-
 
-     /* this reports the availability of a function */
 
-{
 
-#if HAVE_FENV
 
-#if HAVE_RMATH
 
-  list membership;
 
-  list comparison;
 
-  list result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_rmath ();
 
-  if (*fault)
 
-    return NULL;
 
-  comparison = avm_binary_comparison (function_name, wild, fault);
 
-  if (*fault)
 
-    return comparison;
 
-  if (comparison)
 
-    {
 
-      avm_dispose(comparison);
 
-      return avm_copied(funs);
 
-    }
 
-  if (!(membership = avm_binary_membership (function_name, funs, fault)) ? 1 : *fault)
 
-    return membership;
 
-  avm_dispose(membership);
 
-  return ((*fault = !(result = avm_recoverable_join(avm_copied(function_name),NULL))) ? avm_copied(memory_overflow) : result);
 
-#endif
 
-#endif
 
-  return (NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_rmath_call (function_name, argument, fault)
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-
 
-     /* This figures out what function to call and calls it. */
 
-{
 
-#if HAVE_FENV
 
-#if HAVE_RMATH
 
-  list message;
 
-  int function_number;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (! initialized)
 
-    avm_initialize_rmath ();
 
-  if (!(function_number = 0xff & (function_name ? function_name->characterization : 0)))
 
-    {
 
-      message = avm_position (function_name, funs, fault);
 
-      if (*fault)
 
-	return message;
 
-      if (*fault = !message)
 
-	return avm_copied (unrecognized_function_name);
 
-      function_number = message->characterization;
 
-      function_name->characterization = function_number;
 
-      avm_dispose (message);
 
-    }
 
-  switch (function_number)
 
-    {
 
-    case 1: return r_evaluation((r_operator) gammafn, argument, fault);
 
-    case 2: return r_evaluation((r_operator) lgammafn, argument, fault);
 
-    case 3: return r_evaluation((r_operator) digamma, argument, fault);
 
-    case 4: return r_evaluation((r_operator) trigamma, argument, fault);
 
-    case 5: return r_evaluation((r_operator) tetragamma, argument, fault);
 
-    case 6: return r_evaluation((r_operator) pentagamma, argument, fault);
 
-    case 7: return r_evaluation((r_operator) rt, argument, fault);
 
-    case 8: return r_evaluation((r_operator) rexp, argument, fault);
 
-    case 9: return r_evaluation((r_operator) rchisq, argument, fault);
 
-    case 10: return rr_evaluation((rr_operator) beta, argument, fault);
 
-    case 11: return rr_evaluation((rr_operator) lbeta, argument, fault);
 
-    case 12: return rr_evaluation((rr_operator) bessel_j, argument, fault);
 
-    case 13: return rr_evaluation((rr_operator) bessel_y, argument, fault);
 
-    case 14: return rr_evaluation((rr_operator) rnorm, argument, fault);
 
-    case 15: return rr_evaluation((rr_operator) rlnorm, argument, fault);
 
-    case 16: return rr_evaluation((rr_operator) runif, argument, fault);
 
-    case 17: return rr_evaluation((rr_operator) rnchisq, argument, fault);
 
-    case 18: return rrb_evaluation((rrb_operator) dt, argument, fault);
 
-    case 19: return rrb_evaluation((rrb_operator) dexp, argument, fault);
 
-    case 20: return rrb_evaluation((rrb_operator) dchisq, argument, fault);
 
-    case 21: return rrr_evaluation((rrr_operator) bessel_i, argument, fault);
 
-    case 22: return rrr_evaluation((rrr_operator) bessel_k, argument, fault);
 
-    case 23: return rrbb_evaluation((rrbb_operator) pchisq, argument, fault);
 
-    case 24: return rrbb_evaluation((rrbb_operator) qchisq, argument, fault);
 
-    case 25: return rrbb_evaluation((rrbb_operator) pt, argument, fault);
 
-    case 26: return rrbb_evaluation((rrbb_operator) qt, argument, fault);
 
-    case 27: return rrbb_evaluation((rrbb_operator) pexp, argument, fault);
 
-    case 28: return rrbb_evaluation((rrbb_operator) qexp, argument, fault);
 
-    case 29: return rrrb_evaluation((rrrb_operator) dnorm, argument, fault);
 
-    case 30: return rrrb_evaluation((rrrb_operator) dlnorm, argument, fault);
 
-    case 31: return rrrb_evaluation((rrrb_operator) dunif, argument, fault);
 
-    case 32: return rrrb_evaluation((rrrb_operator) dnchisq, argument, fault);
 
-    case 33: return rrrbb_evaluation((rrrbb_operator) pnorm, argument, fault);
 
-    case 34: return rrrbb_evaluation((rrrbb_operator) qnorm, argument, fault);
 
-    case 35: return rrrbb_evaluation((rrrbb_operator) plnorm, argument, fault);
 
-    case 36: return rrrbb_evaluation((rrrbb_operator) qlnorm, argument, fault);
 
-    case 37: return rrrbb_evaluation((rrrbb_operator) punif, argument, fault);
 
-    case 38: return rrrbb_evaluation((rrrbb_operator) qunif, argument, fault);
 
-    case 39: return rrrbb_evaluation((rrrbb_operator) pnchisq, argument, fault);
 
-    case 40: return rrrbb_evaluation((rrrbb_operator) qnchisq, argument, fault);
 
-    case 41: return rrb_evaluation((rrb_operator) dpois, argument, fault);
 
-    case 42: return rrbb_evaluation((rrbb_operator) ppois, argument, fault);
 
-    case 43: return rrbb_evaluation((rrbb_operator) qpois, argument, fault);
 
-    case 44: return r_evaluation((r_operator) rpois, argument, fault);
 
-    }
 
-#endif /* HAVE_RMATH */
 
-#endif /* HAVE_FENV */
 
-   *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_rmath ()
 
-
 
-     /* This initializes some static data structures. */
 
-{
 
-  char *funames[] = {
 
-    "gammafn",
 
-    "lgammafn",
 
-    "digamma",
 
-    "trigamma",
 
-    "tetragamma",
 
-    "pentagamma",
 
-    "rt",
 
-    "rexp",
 
-    "rchisq",
 
-    "beta",
 
-    "lbeta",
 
-    "bessel_j",
 
-    "bessel_y",
 
-    "rnorm",
 
-    "rlnorm",
 
-    "runif",
 
-    "rnchisq",
 
-    "dt",
 
-    "dexp",
 
-    "dchisq",
 
-    "bessel_i",
 
-    "bessel_k",
 
-    "pchisq",
 
-    "qchisq",
 
-    "pt",
 
-    "qt",
 
-    "pexp",
 
-    "qexp",
 
-    "dnorm",
 
-    "dlnorm",
 
-    "dunif",
 
-    "dnchisq",
 
-    "pnorm",
 
-    "qnorm",
 
-    "plnorm",
 
-    "qlnorm",
 
-    "punif",
 
-    "qunif",
 
-    "pnchisq",
 
-    "qnchisq",
 
-    "dpois",
 
-    "ppois",
 
-    "qpois",
 
-    "rpois",
 
-    NULL};            /* add more function names here up to a total of 255 */
 
-  list back;
 
-  int string_number;
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_apply ();
 
-  avm_initialize_listfuns ();
 
-  avm_initialize_chrcodes ();
 
-  wild = avm_strung ("*");
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  bad_rmath_spec = avm_join (avm_strung ("bad rmath specification"), NULL);
 
-  unrecognized_function_name = avm_join (avm_strung ("unrecognized rmath function name"), NULL);
 
-  string_number = 0;
 
-  funs = back = NULL;
 
-  while (funames[string_number])
 
-    avm_enqueue (&funs, &back, avm_standard_strung (funames[string_number++]));
 
-}
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_rmath ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (funs);
 
-  avm_dispose (wild);
 
-  avm_dispose (bad_rmath_spec);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (unrecognized_function_name);
 
-  funs = NULL;
 
-  bad_rmath_spec = NULL;
 
-  memory_overflow = NULL;
 
-  unrecognized_function_name = NULL;
 
-}

+ 0 - 807
src/servlist.c
View File 

@@ -1,807 +0,0 @@
 
-
 
-/* for keeping track of remote servers and their states
 
-
 
-   Copyright (C) 2010 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-*/
 
-
 
-#define _GNU_SOURCE
 
-
 
-#include <netdb.h>
 
-#include <stdint.h>
 
-#include <fcntl.h>
 
-#include <errno.h>
 
-#include <poll.h>
 
-#include <netinet/in.h>
 
-#include <sys/time.h>
 
-#include <sys/socket.h>
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/servlist.h>
 
-
 
-/* Non-zero means static variables have been initialized. */
 
-static int initialized = 0;
 
-
 
-/* diagnostic reported when when the server uses a newer protocol version than the client recognizes */
 
-static list protocol_breach = NULL;
 
-
 
-/* Three global static lists are maintained, for busy, dead, and idle servers. */
 
-static int idle_servers = 0;
 
-static int busy_servers = 0;
 
-static int dead_servers = 0;
 
-static int extant_servers = 0;
 
-
 
-/* lists of available servers */
 
-static server_list idle_front = NULL;
 
-static server_list idle_back = NULL;
 
-static server_list busy_front = NULL;
 
-static server_list busy_back = NULL;
 
-static server_list dead_front = NULL;
 
-static server_list dead_back = NULL;
 
-
 
-
 
-/*---------------------------------------------------- registration --------------------------------------------*/
 
-
 
-
 
-
 
-
 
-int
 
-avm_registered_server (host, port_number)
 
-     char *host;
 
-     int port_number;
 
-
 
-     /* this adds to the list of available servers, and returns non-zero if successful */
 
-{
 
-  server_list server;
 
-  int fault;
 
-
 
-  if (!(server = (server_list) malloc (sizeof *server)))
 
-    return 0;
 
-  extant_servers++;
 
-  memset (server, 0, sizeof *server);
 
-  fault = (asprintf (&(server->data_port), "%d", port_number) < 0);
 
-  fault = (fault ? 1 : (asprintf (&(server->status_port), "%d", port_number + 1) < 0));
 
-  fault = (fault ? 1 : !(server->host = strdup (host)));
 
-  if (fault = (fault ? 1 : ! avm_connectable (server)))
 
-    {
 
-      avm_unregister_server (&server);
 
-      return 0;
 
-    }
 
-  else
 
-    {
 
-      busy_servers++;                       /* because releasing normally decrements it */
 
-      avm_release_server (&server);
 
-      return 1;
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_unregister_server (servers)
 
-     server_list *servers;
 
-
 
-     /* frees all servers and closes open connections */
 
-{
 
-  server_list old;
 
-
 
-  while (*servers)
 
-    {
 
-      extant_servers--;
 
-      *servers = (old = *servers)->peer;
 
-      avm_flush_server (old);
 
-      if (old->opened)
 
-	{
 
-	  close (old->data_fd);
 
-	  close (old->status_fd);
 
-	}
 
-      avm_dispose (old->cache);
 
-      free (old->expected_crc);
 
-      free (old->status_port);
 
-      free (old->data_port);
 
-      free (old->host);
 
-      free (old);
 
-    }
 
-}
 
-
 
-
 
-
 
-/*--------------------------------------------------- observation ----------------------------------------------*/
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_watch_server (server)
 
-     server_list server;
 
-
 
-     /* puts a server into the busy list, where it will be monitored by
 
-	avm_wait_for_event */
 
-{
 
-  if (!server)
 
-    return;
 
-  busy_servers++;
 
-  server->state_change = time (NULL);
 
-  server->peer = NULL;
 
-  busy_back = (busy_back ? (busy_back->peer = server) : (busy_front = server));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_wait_for_event (interval)
 
-     time_t interval;
 
-
 
-     /* sleeps until either an event happens on a watched server or
 
-	it's time to check the one that has been running the longest,
 
-	but can also just return if there isn't enough memory, since
 
-	the only detrimental effect will be not waiting long enough */
 
-{
 
-  time_t running_time;
 
-  struct pollfd *fds;
 
-  struct pollfd *nextfd;
 
-  server_list server;
 
-  int numfds, fdnum;
 
-
 
-  if (!(server = busy_front) ? 0 : (running_time = time (NULL) - busy_front->state_change) >= interval)
 
-    return;
 
-  fds = NULL;
 
-  numfds = busy_servers;
 
-  while ((numfds <= 0) ? 0 : !(fds = (struct pollfd *) malloc (numfds * sizeof *fds)))
 
-    numfds = numfds >> 1;
 
-  if (!fds)
 
-    return;
 
-  fdnum = 0;
 
-  nextfd = fds;
 
-  while (server ? (fdnum++ < numfds) : 0)
 
-    {
 
-      nextfd->fd = server->data_fd;
 
-      (nextfd++)->events = POLLIN | POLLRDHUP | POLLHUP | POLLNVAL;
 
-      server = server->peer;
 
-    }
 
-  poll (fds, fdnum, interval - running_time);
 
-  free (fds);
 
-  return;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-/*---------------------------------------------------- mutation ------------------------------------------------*/
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_flush_server (server)
 
-     server_list server;
 
-
 
-     /* this gets rid of any data waiting to be read from a server,
 
-        and will also close the connection if there's a problem
 
-        reading from it */
 
-{
 
-  struct statpacket reply[10];
 
-  struct pollfd fds;
 
-  int flushing;
 
-
 
-  if (!server ? 1 : !(server->opened) ? 1 : !(server->connected))
 
-    return;
 
-  server->queried = 0;
 
-  fds.events = POLLIN;
 
-  fds.fd = server->status_fd;
 
-  if (flushing = (poll (&fds, 1, 0) > 0))
 
-    {
 
-      while (flushing > 0)
 
-	flushing = recv ((server)->status_fd, reply, sizeof reply, MSG_NOSIGNAL | MSG_DONTWAIT);
 
-      if (!flushing ? 1 : (flushing == -1) ? ((errno == ENOTCONN) ? 1 : (errno == ECONNREFUSED)) : 0)
 
-	server->connected = 0;
 
-    }
 
-  fds.fd = server->data_fd;
 
-  if (flushing = (poll (&fds, 1, 0) > 0))
 
-    {
 
-      while (flushing > 0)
 
-	flushing = recv (server->data_fd, reply, sizeof reply, MSG_NOSIGNAL | MSG_DONTWAIT);
 
-      if (!flushing ? 1 : (flushing == -1) ? ((errno == ENOTCONN) ? 1 : (errno == ECONNREFUSED)) : 0)
 
-	server->connected = 0;
 
-    }
 
-  if (server->opened = server->connected)
 
-    return;
 
-  close (server->data_fd);
 
-  close (server->status_fd);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_release_server (server)
 
-     server_list *server;
 
-
 
-     /* returns a server that was most likely in the busy list either
 
-	to the idle or dead server list depending on its connection
 
-	status; also tries to flush leftover messages but doesn't
 
-	examine them */
 
-{
 
-  int sent, flushed;
 
-  struct statpacket reply;
 
-
 
-  if (!(*server))
 
-    return;
 
-  busy_servers--;
 
-  avm_flush_server (*server);
 
-  (*server)->queried = 0;
 
-  (*server)->peer = NULL;
 
-  (*server)->state_change = time (NULL);
 
-  free ((*server)->expected_crc);
 
-  (*server)->expected_crc = NULL;
 
-  avm_dispose ((*server)->cache);
 
-  if ((*server)->opened)
 
-    {
 
-      idle_servers++;
 
-      idle_back = (idle_back ? (idle_back->peer = *server) : (idle_front = *server));
 
-    }
 
-  else
 
-    {
 
-      dead_servers++;
 
-      (*server)->connected = 0;
 
-      dead_back = (dead_back ? (dead_back->peer = *server) : (dead_front = *server));
 
-    }
 
-  *server = NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-server_list
 
-avm_revived_server (interval, fault)
 
-     time_t interval;
 
-     int *fault;
 
-
 
-   /* returns the oldest dead server in the list that hasn't been
 
-      tried for at least the given interval and is possible to reopen,
 
-      based on the assumption that the dead list ordered from oldest
 
-      to newest. */
 
-{
 
-  server_list unwritable_front, unwritable_back, result;
 
-  int found;
 
-  time_t now;
 
-
 
-  now = time (NULL);
 
-  found = 0;
 
-  unwritable_front = unwritable_back = result = NULL;
 
-  while (*fault ? 0 : found ? 0 : !dead_front ? 0 : (dead_front->state_change < now - interval))
 
-    if (!(found = avm_writable (dead_front, fault)))
 
-      {
 
-	dead_front->state_change = now = time (NULL);
 
-	unwritable_back = (unwritable_back ? (unwritable_back->peer = dead_front) : (unwritable_front = dead_front));
 
-	dead_front = ((dead_front == dead_back) ? (dead_back = NULL) : dead_front->peer);
 
-	unwritable_back->peer = NULL;
 
-      }
 
-  if (found)
 
-    {
 
-      dead_servers--;
 
-      result = dead_front;
 
-      result->state_change = time (NULL);
 
-      dead_front = ((dead_front == dead_back) ? (dead_back = NULL) : dead_front->peer);
 
-      result->peer = NULL;
 
-    }
 
-  if (dead_front)
 
-    dead_back->peer = unwritable_front;
 
-  else
 
-    dead_front = unwritable_front;
 
-  dead_back = (unwritable_back ? unwritable_back : dead_back);
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-server_list
 
-avm_acquired_server (interval, fault)
 
-     time_t interval;
 
-     int *fault;
 
-
 
-   /* This tries to select the least loaded server from the list of
 
-      idle servers based on the load metric and removes it from the
 
-      list if it finds one. If it can't do that, it tries to revive a
 
-      dead server. If it discovers any unconnectable servers along the
 
-      way, it moves them to the dead list. */
 
-{
 
-  server_list server, result, writable_front, writable_back;
 
-  double min_load;
 
-
 
-  result = writable_front = writable_back = NULL;
 
-  while (*fault ? 0 : idle_front)
 
-    if (avm_writable (idle_front, fault))
 
-      {
 
-	if (!result ? 1 : (idle_front->load_metric < min_load))         /* scan the idle list for the minimum load */
 
-	  {
 
-	    result = idle_front;
 
-	    min_load = result->load_metric;
 
-	  }
 
-	writable_back = (writable_back ? (writable_back->peer = idle_front) : (writable_front = idle_front));
 
-	idle_front = ((idle_back == idle_front) ? (idle_back = NULL) : idle_front->peer);
 
-	writable_back->peer = NULL;
 
-      }
 
-    else if (!(idle_front->opened))
 
-      {                                                          /* enqueue unconnectable servers in the dead list */
 
-	idle_front->state_change = time (NULL);
 
-	dead_back = (dead_back ? (dead_back->peer = idle_front) : (dead_front = idle_front));
 
-	idle_front = ((idle_back == idle_front) ? (idle_back = NULL) : (idle_front->peer));
 
-	dead_back->peer = NULL;
 
-      }
 
-  if (idle_front)                                            /* put the surviving  servers back into the idle list */
 
-    idle_back->peer = writable_front;
 
-  else
 
-    idle_front = writable_front;
 
-  idle_back = (writable_back ? writable_back : idle_back);
 
-  if (*fault ? 1 : !result)
 
-    return (*fault ? NULL : avm_revived_server (interval, fault));      /* if there's no result, try the dead list */
 
-  idle_servers--;
 
-  if (result == idle_front)
 
-    idle_front = ((idle_front == idle_back) ? (idle_back = NULL) : idle_front->peer);
 
-  else
 
-    {
 
-      server = idle_front;
 
-      while (server->peer != result)
 
-	server = server->peer;
 
-      if (!(server->peer = result->peer))
 
-	idle_back = server;
 
-    }
 
-  result->peer = NULL;
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-/*---------------------------------------------------- interrogation -------------------------------------------*/
 
-
 
-
 
-
 
-
 
-
 
-int
 
-avm_offline ()
 
-
 
-/* this function returns a non-zero value if there are no remote
 
-   servers available */
 
-
 
-{
 
-  int online;
 
-
 
-  if (!initialized)
 
-    avm_initialize_remote ();
 
-  return (idle_servers ? 0 : busy_servers ? 0 : ! dead_servers);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-int
 
-avm_readable (server, fault)
 
-     server_list *server;
 
-     int *fault;
 
-
 
-     /* tests whether there are data to receive from a given busy
 
-        server, and may also move it to the dead server list if a
 
-        hangup is detected */ 
-{
 
-  struct pollfd fds;
 
-
 
-  fds.fd = (*server)->data_fd;
 
-  fds.events = POLLIN | POLLRDHUP | POLLHUP | POLLNVAL;
 
-  if (*fault)
 
-    return 0;
 
-  if (poll (&fds, 1, 0) < 0)
 
-    {
 
-      if (*fault = (errno == ENOMEM))
 
-	return 0;
 
-      avm_internal_error (120);
 
-    }
 
-  if (fds.revents & POLLNVAL)
 
-    avm_internal_error (111);
 
-  if (fds.revents & POLLIN)
 
-    return 1;
 
-  if (fds.revents & (POLLRDHUP | POLLHUP))
 
-    {
 
-      close ((*server)->data_fd);
 
-      close ((*server)->status_fd);
 
-      (*server)->opened = (*server)->connected = 0;
 
-      avm_release_server (server);
 
-    }
 
-  return 0;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-int
 
-avm_writable (server, fault)
 
-     server_list server;
 
-     int *fault;
 
-
 
-     /* This returns true iff a server socket is writable, which is tested
 
-        here instead of when the socket is created (in connectable) because
 
-        it's done asynchronously. If so, the connected field is set. */
 
-{
 
-  struct pollfd fds;
 
-  int connection_error, connection_error_size;
 
-
 
-  if (*fault ? 1 : !server)
 
-    return 0;
 
-  if (server->opened ? server->connected : 0)
 
-    return 1;
 
-  if (!(server->opened ? 1 : avm_connectable (server)))
 
-    return 0;
 
-  fds.fd = server->data_fd;
 
-  fds.events = POLLOUT | POLLRDHUP | POLLHUP | POLLNVAL;
 
-  if (poll (&fds, 1, 0) < 0)
 
-    {
 
-      if (*fault = (errno == ENOMEM))
 
-	return 0;
 
-      avm_internal_error (112);
 
-    }
 
-  if (fds.revents & POLLNVAL)
 
-    avm_internal_error (113);
 
-  if (fds.revents & POLLOUT)
 
-    {
 
-      connection_error_size = sizeof connection_error;
 
-      if (getsockopt (server->data_fd, SOL_SOCKET, SO_ERROR, &connection_error, &connection_error_size) == -1)
 
-	avm_internal_error (114);
 
-      if (server->connected = ! connection_error)
 
-	return 1;
 
-    }
 
-  close (server->status_fd);
 
-  close (server->data_fd);
 
-  return (server->opened = 0);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-int
 
-avm_connectable (server)
 
-     server_list server;
 
-
 
-     /* This initializes socket descriptors and initiates the
 
-	connection asynchronously. The data socket is given a timeout
 
-	of AVM_DEFAULT_TIMEOUT seconds and the status socket is made
 
-	non-blocking. If successful, the opened field is set but not
 
-	the connected field, indicating that the server is in a state
 
-	of waiting for the connection to be established. The connected
 
-	field will be set subsequently when the server is successfully
 
-	polled by the writable function. */
 
-{
 
-  struct addrinfo hints, *servinfo, *statinfo, *info;
 
-  struct timeval timeout;
 
-  int fault;
 
-
 
-  if (!server)
 
-    return 0;
 
-  statinfo = servinfo = NULL;
 
-  memset (&hints, 0, sizeof hints);
 
-  memset (&timeout, 0, sizeof timeout);
 
-  timeout.tv_sec = AVM_DEFAULT_TIMEOUT;
 
-  hints.ai_family = AF_UNSPEC;
 
-  hints.ai_socktype = SOCK_STREAM;
 
-  hints.ai_flags = AI_PASSIVE;
 
-  fault = (getaddrinfo (server->host, server->data_port, &hints, &servinfo) != 0);
 
-  info = servinfo;
 
-  while (fault ? 0 : info ? ((server->data_fd = socket (info->ai_family, info->ai_socktype, info->ai_protocol)) == -1) : 0)
 
-    info = info->ai_next;
 
-  fault = (fault ? 1 : (fcntl (server->data_fd, F_SETFL, O_NONBLOCK) == -1));
 
-  if (!(fault = (fault ? 1 : !info)))
 
-    fault = ((connect (server->data_fd, info->ai_addr, info->ai_addrlen) == -1) ? (errno != EINPROGRESS) : 0);
 
-  fault = (fault ? 1 : (fcntl (server->data_fd, F_SETFL, O_SYNC) == -1));
 
-  fault = (fault ? 1 : (setsockopt (server->data_fd, SOL_SOCKET, SO_SNDTIMEO, &timeout, sizeof timeout) == -1));
 
-  fault = (fault ? 1 : (setsockopt (server->data_fd, SOL_SOCKET, SO_RCVTIMEO, &timeout, sizeof timeout) == -1));
 
-  fault = (fault ? 1 : (getaddrinfo (server->host, server->status_port, &hints, &statinfo) != 0));
 
-  info = statinfo;
 
-  while (fault ? 0 : info ? ((server->status_fd = socket (info->ai_family, info->ai_socktype, info->ai_protocol)) == -1) : 0)
 
-    info = info->ai_next;
 
-  fault = (fault ? 1 : (fcntl (server->status_fd, F_SETFL, O_NONBLOCK)));
 
-  if (!(fault = (fault ? 1 : !info)))
 
-    fault = ((connect (server->status_fd, info->ai_addr, info->ai_addrlen) == -1) ? (errno != EINPROGRESS) : 0);
 
-  if (servinfo)
 
-    freeaddrinfo (servinfo);
 
-  if (statinfo)
 
-    freeaddrinfo (statinfo);
 
-  if (server->opened = !fault)
 
-    return 1;
 
-  close (server->data_fd);
 
-  close (server->status_fd);
 
-  return 0;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static int
 
-status_requestable (server, fault)
 
-     server_list *server;
 
-     int *fault;
 
-
 
-     /* This makes a status request and returns true if the request is
 
-        successfully made. It doesn't wait for a reply.  A status
 
-        request consists of the null terminated AVM_MSG_STATUS string,
 
-        followed by the null terminated crc of the relevant job. */
 
-{
 
-  int sent;
 
-  char *status_code = AVM_MSG_STATUS;
 
-
 
-  if (*fault ? 1 : !*server)
 
-    avm_internal_error (118);
 
-  sent = send ((*server)->status_fd, status_code, 1 + strlen (status_code), MSG_NOSIGNAL | MSG_MORE);
 
-  if (*fault = ((sent == -1) ? (errno == ENOMEM) : 0))
 
-    return 0;
 
-  if (sent == 1 + strlen (status_code))
 
-    (*server)->queried = 1;
 
-  else
 
-    (*server)->queried = ((sent == -1) ? ((errno == EAGAIN) ? 1 : (errno == EWOULDBLOCK)) : 0);
 
-  if ((*server)->queried)
 
-    {
 
-      sent = send((*server)->status_fd, (*server)->expected_crc, 1 + strlen ((*server)->expected_crc), MSG_NOSIGNAL);
 
-      if (*fault = ((sent == -1) ? (errno == ENOMEM) : 0))
 
-	return 0;
 
-      if (sent != 1 + strlen (status_code))
 
-	(*server)->queried = ((sent == -1) ? ((errno == EAGAIN) ? 1 : (errno == EWOULDBLOCK)) : 0);
 
-      if ((*server)->queried)
 
-	{
 
-	  (*server)->request_time = time (NULL);              /* a new status request has been sent or is being sent */
 
-	  return 1;
 
-	}
 
-    }
 
-  if (!(!sent ? 1 : (sent == -1) ? ((errno == EPIPE) ? 1 : (errno == ENOBUFS) ? 1 : (errno == ECONNRESET)) : 0))
 
-    avm_internal_error (119);
 
-  (*server)->opened = (*server)->connected = 0;             /* a request couldn't be sent because the server is down */
 
-  close ((*server)->status_fd);
 
-  close ((*server)->data_fd);
 
-  avm_release_server (server);
 
-  return 0;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static int
 
-affirmative_response (server, value, fault)
 
-     server_list *server;
 
-     list *value;
 
-     int *fault;
 
-
 
-     /* This receives and interprets a status report expected from a
 
-        server. This shouldn't block because status ports are set to
 
-        non-blocking operation when opened, and the status request
 
-        should have been sent a sufficient time ago when this function
 
-        is called, so if the reply isn't aready here, the server is
 
-        assumed to be down.
 
-
 
-        In protocol version 0 (which is the only one at this writing),
 
-        the reply to a status request is expected to be a statpacket
 
-        containing the server's load metric, the protocol version (0),
 
-        and the crc for the submitted job. A server can choose to send
 
-        the result from the job to the data port instead of answering
 
-        a status request on the status port if it's finished already,
 
-        or such a thing could happen due to a race, so this condition
 
-        is checked if the status request acknowledgement isn't
 
-        received. */
 
-{
 
-  int received, result;
 
-  struct statpacket reply;
 
-
 
-  if (*fault ? 1 : !*server)
 
-    avm_internal_error (116);
 
-  *value = NULL;
 
-  memset (&reply, 0, sizeof reply);
 
-  received = recv ((*server)->status_fd, &reply, sizeof reply, MSG_NOSIGNAL);
 
-  if (*fault = ((received == -1) ? (errno == ENOMEM) : 0))
 
-    return 0;
 
-  if (received > 0)                                                                          /* the server is up */
 
-    {
 
-      (*server)->load_metric = reply.load_average;
 
-      if (*fault = reply.protocol_version)
 
-	*value = avm_copied (protocol_breach);
 
-      else 
-	result = (strcmp ((*server)->expected_crc, reply.payload) == 0);
 
-      avm_release_server (server);
 
-      return (*fault ? 0 : result);                        /* but God knows if it's working on the submitted job */
 
-    }
 
-  else if (avm_readable (server, fault))
 
-    return 1;
 
-  if (!(!received ? 1 : (received == -1) ? ((errno == ENOTCONN) ? 1 : (errno == ECONNREFUSED)) : 0))
 
-    avm_internal_error (117);
 
-  (*server)->opened = (*server)->connected = 0;                                            /* the server is down */
 
-  close ((*server)->status_fd);
 
-  close ((*server)->data_fd);
 
-  avm_release_server (server);
 
-  return 0;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-int
 
-avm_unresponsive (server, interval, value, fault)
 
-     server_list *server;
 
-     time_t interval;
 
-     list *value;
 
-     int *fault;
 
-
 
-     /* This requests a status update from a busy server or follows up
 
-	a previous request and returns true and releases the server if
 
-	there is any problem, such as a closed connection or a missing
 
-	or wrong response. If the server is responsive, this returns
 
-	0, as a correct response is considered a non-event insofar as
 
-	it means that the client should just keep waiting. */
 
-{
 
-  *value = NULL;
 
-  if (*fault)
 
-    return 0;
 
-  if (!*server ? 1 : !((*server)->connected) ? 1 : !((*server)->expected_crc))
 
-    avm_internal_error (115);
 
-  if (! (*server)->queried)
 
-    return (! status_requestable (server, fault));
 
-  if (time (NULL) - (*server)->request_time < interval)
 
-    return 0;
 
-  (*server)->queried = 0;
 
-  return (! affirmative_response (server, value, fault));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-/*---------------------------------------------------- initializaiton ------------------------------------------*/
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_servlist ()
 
-
 
-     /* This initializes static data structures. */
 
-{
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  protocol_breach = avm_join (avm_strung ("incompatible client/server protocol"), NULL);
 
-  avm_initialize_lists ();
 
-  avm_initialize_compare ();
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_servlist ()
 
-
 
-{
 
-  server_list old,servers;
 
-
 
-  if (!initialized)
 
-    return;
 
-  avm_unregister_server (&idle_front);
 
-  avm_unregister_server (&busy_front);
 
-  avm_unregister_server (&dead_front);
 
-  idle_back = busy_back = dead_back = NULL;
 
-  avm_dispose (protocol_breach);
 
-  protocol_breach = NULL;
 
-  initialized = 0;
 
-  if (extant_servers)
 
-    avm_reclamation_failure ("server lists", extant_servers);
 
-}

+ 0 - 467
src/umf.c
View File 

@@ -1,467 +0,0 @@
 
-
 
-/* this file interfaces to sparse matrix routines from libufsparse
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-#include <avm/compare.h>
 
-#include <avm/listfuns.h>
 
-#include <avm/matcon.h>
 
-#include <avm/chrcodes.h>
 
-#include <avm/umf.h>
 
-#if HAVE_UMF
 
-#include <suitesparse/umfpack.h>
 
-#endif
 
-
 
-typedef double complex[2];
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list umf_error = NULL;
 
-static list bad_umf_spec = NULL;
 
-static list memory_overflow = NULL;
 
-static list unrecognized_function_name = NULL;
 
-
 
-/* function names as lists of lists of character representations */
 
-static list wild = NULL;
 
-static list funs = NULL;
 
-
 
-
 
-#define freeif(x) if (x)			\
 
-    free (x)
 
-
 
-
 
-#if HAVE_UMF
 
-
 
-
 
-
 
-
 
-static list
 
-umfpack_i(real, result, mode, Ap, Ai, Ax, Ab, n, fault)
 
-     int real;
 
-     list result;
 
-     int mode;
 
-     int *Ap, *Ai;
 
-     void *Ax, *Ab;   /* could be either double or complex */
 
-     int n;
 
-     int *fault;
 
-
 
-     /* This takes a problem specification in compressed column form
 
-	as described in the umfpack user guide. Result and *fault
 
-	should be already initialized on entry, and are left unchanged
 
-	if *fault is true. Some memory allocated to other input
 
-	parameters is freed (unconditionally) by this procedure
 
-	instead of the caller because not all of it is needed by the
 
-	time the result is computed. */
 
-{
 
-  void *x;
 
-  void *Symbolic, *Numeric;
 
-  int status;
 
-
 
-  Symbolic = NULL;
 
-  status = 0;
 
-  if (!(*fault = (*fault ? 1 : !!result)))
 
-    {
 
-      if (real)
 
-	status = umfpack_di_symbolic(n, n, Ap, Ai, Ax, &Symbolic, NULL, NULL);
 
-      else
 
-	status = umfpack_zi_symbolic(n, n, Ap, Ai, Ax, NULL, &Symbolic, NULL, NULL);
 
-      if (*fault = (status < 0))
 
-	result = ((status == UMFPACK_ERROR_out_of_memory) ? avm_copied(memory_overflow) : avm_copied(umf_error));
 
-    }
 
-  Numeric = NULL;
 
-  if (!*fault)
 
-    {
 
-      if (real)
 
-	status = umfpack_di_numeric(Ap, Ai, Ax, Symbolic, &Numeric, NULL, NULL);
 
-      else
 
-	status = umfpack_zi_numeric(Ap, Ai, Ax, NULL, Symbolic, &Numeric, NULL, NULL);
 
-      if (*fault = (status < 0))
 
-	result = ((status == UMFPACK_ERROR_out_of_memory) ? avm_copied(memory_overflow) : avm_copied(umf_error));
 
-    }
 
-  if (Symbolic)
 
-    umfpack_di_free_symbolic(&Symbolic);
 
-  x = NULL;
 
-  if (!*fault)
 
-    {
 
-      x = malloc(n * (real ? sizeof(double) : sizeof(complex)));
 
-      if (*fault = !x)
 
-	result = avm_copied(memory_overflow);
 
-    }
 
-  if (!*fault)
 
-    {
 
-      if (real)
 
-	status = umfpack_di_solve(mode, Ap, Ai, Ax, x, Ab, Numeric, NULL, NULL);
 
-      else
 
-	status = umfpack_zi_solve(mode, Ap, Ai, Ax, NULL, x, NULL, Ab, NULL, Numeric, NULL, NULL);
 
-      if (*fault = (status < 0))
 
-	result = ((status == UMFPACK_ERROR_out_of_memory) ? avm_copied(memory_overflow) : avm_copied(umf_error));
 
-    }
 
-  if (Numeric)
 
-    {
 
-      if (real)
 
-	umfpack_di_free_numeric(&Numeric);
 
-      else
 
-	umfpack_zi_free_numeric(&Numeric);
 
-    }
 
-  freeif (Ap);
 
-  freeif (Ai);
 
-  freeif (Ax);
 
-  freeif (Ab);
 
-  if (*fault)
 
-    result = (result ? result : avm_copied(umf_error));
 
-  else if (status == 0)
 
-    result = avm_list_of_vector((void *) x,n,real ? sizeof(double) : sizeof(complex),fault);
 
-  freeif (x);
 
-  return result;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-umfpack_i_col(real, mode, piab, fault)
 
-     int real;
 
-     int mode;
 
-     list piab;
 
-     int *fault;
 
-
 
-     /* piab should represent a tuple of (((p,i),a),b), p and i are
 
-	lists of naturals, a is a list of floats, and b is also a list
 
-	of floats. p and i correspond to the arrays Ap and Ai as
 
-	documented in the Umfpack user guide to represent a sparse
 
-	matrix in compressed column format, a is the list of non-zero
 
-	entries in the matrix, and b is the list of entries in the
 
-	(dense) column vector to be solved. Mode is a umfpack SYS parameter
 
-        like UMFPACK_A that tells the library which system to solve. */
 
-
 
-{
 
-  list b,p,i,result;
 
-  int *Ap, *Ai;
 
-  void *Ax, *Ab;       /* could be either double or complex */
 
-  counter Apl,Ail,j;
 
-
 
-  if (*fault)
 
-    return (NULL);
 
-  b = result = NULL;
 
-  if (*fault = ! (piab ? (piab->head ? (piab->tail ? piab->head->head : NULL) : NULL): NULL))
 
-    return avm_copied(bad_umf_spec);
 
-  Ap = (int *) malloc((Apl = avm_length(p = piab->head->head->head)) * sizeof(int));
 
-  Ai = (int *) malloc((Ail = avm_length(i = piab->head->head->tail)) * sizeof(int));
 
-  if (real)
 
-    {
 
-      Ax = (*fault ? NULL : avm_vector_of_list (piab->head->tail, sizeof(double), &result, fault));
 
-      Ab = (*fault ? NULL : avm_vector_of_list (b = piab->tail, sizeof(double), &result, fault));
 
-    }
 
-  else
 
-    {
 
-      Ax = (*fault ? NULL : avm_vector_of_list (piab->head->tail, sizeof(complex), &result, fault));
 
-      Ab = (*fault ? NULL : avm_vector_of_list (b = piab->tail, sizeof(complex), &result, fault));
 
-    }
 
-  if (*fault = (*fault ? 1 : !(Ap ? (Ai ? (Ax ? Ab : NULL): NULL): NULL)))
 
-    result = (result ? result : avm_copied(memory_overflow));
 
-  else
 
-    {
 
-      for (j = 0; j < Apl; j++)
 
-	{
 
-	  if (!p)
 
-	    avm_internal_error(48);
 
-	  Ap[j] = (int) avm_counter(p->head);
 
-	  p = p->tail;
 
-	}
 
-      for (j = 0; j < Ail; j++)
 
-	{
 
-	  if (!i)
 
-	    avm_internal_error(49);
 
-	  Ai[j] = (int) avm_counter(i->head);
 
-	  i = i->tail;
 
-	}
 
-      if (*fault ? 0 : (p ? i : NULL))
 
-	avm_internal_error(54);
 
-    }
 
-  return umfpack_i (real, result, mode, Ap, Ai, Ax, Ab, (int) avm_length(b), fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-static list
 
-umfpack_i_trp(real, mode, ab, fault)
 
-     int real;
 
-     int mode;
 
-     list ab;
 
-     int *fault;
 
-
 
-     /* ab represents a pair (a,b), where a is a list of triples
 
-        ((i,j),x) with x being the i,jth entry in the input matrix and
 
-        b being the column vector.  Only non-zero values of x are
 
-        required. This form is more convenient than the compressed
 
-        column form but requires an extra conversion step and more
 
-        memory. However, the conversion is likely to be faster here
 
-        than if it's done in virtual code. Mode is a umfpack SYS
 
-        parameter like UMFPACK_A that tells the library which system
 
-        to solve. */
 
-{
 
-  list a,b,result;
 
-  int *Ap, *Ai, *Ti, *Tj, *Map, status, n_row, n_col, Abl;
 
-  counter nz, k;
 
-  void *t, *Ax, *Ab, *Tx;    /* could be either double or complex */
 
-
 
-  if (*fault)
 
-    return (NULL);
 
-  if (*fault = ! ab)
 
-    return (avm_copied(bad_umf_spec));
 
-  a = ab->head;
 
-  b = ab->tail;
 
-  Ti = (int *) malloc((nz = avm_length(a)) * sizeof(int));
 
-  Tj = (int *) malloc(nz * sizeof(int));
 
-  Tx = malloc(nz * (real ? sizeof(double) : sizeof(complex)));
 
-  result = NULL;
 
-  if (*fault = ! (Ti ? (Tj ? Tx : NULL): NULL))
 
-    result = avm_copied(memory_overflow);
 
-  Abl = k = 0;
 
-  n_row = 0;
 
-  n_col = 0;
 
-  while (*fault ? 0 : (k < nz))
 
-    {
 
-      if (!a)
 
-	avm_internal_error(60);
 
-      if (*fault = ! (a->head ? a->head->head: NULL))
 
-	result = avm_copied(bad_umf_spec);
 
-      else
 
-	{
 
-	  Ti[k] = (int) avm_counter(a->head->head->head);
 
-	  Tj[k] = (int) avm_counter(a->head->head->tail);
 
-	  n_row = ((n_row < Ti[k]) ? Ti[k] : n_row);
 
-	  n_col = ((n_col < Tj[k]) ? Tj[k] : n_col);
 
-	  t = avm_value_of_list(a->head->tail,&result,fault);
 
-	  if (! *fault)
 
-	    {
 
-	      if (!t)
 
-		avm_internal_error(55);
 
-	      memcpy(Tx + ((k++) * (real ? sizeof(double) : sizeof(complex))),t,real ? sizeof(double) : sizeof(complex));
 
-	    }
 
-	  /*printf("((%d,%d),%0.1f)\n",Ti[k-1],Tj[k-1],((double *) Tx)[k-1]);*/
 
-	  a = a->tail;
 
-	}
 
-    }
 
-  n_row++;
 
-  n_col++;
 
-  /*printf("%d %d\n",n_row,n_col);*/
 
-  if (*fault = (*fault ? 1 : (n_row != n_col)))
 
-    result = (result ? result : avm_copied (bad_umf_spec));
 
-  else
 
-    Abl = n_row;
 
-  if (*fault ? 0 : a)
 
-    avm_internal_error(56);
 
-  Map = Ap = Ai = (int *) (Ax = NULL);
 
-  if (!*fault)
 
-    {
 
-      Ap = (int *) malloc((n_col+1) * sizeof(int));
 
-      Ai = (int *) malloc(nz * sizeof(int));
 
-      Ax = malloc(nz * (real ? sizeof(double) : sizeof(complex)));
 
-      if (*fault = ! (Ap ? (Ai ? Ax : NULL): NULL))
 
-	result = avm_copied(memory_overflow);
 
-    }
 
-  if (!*fault)
 
-    {
 
-      if (real)
 
-	status = umfpack_di_triplet_to_col(n_row, n_col, nz, Ti, Tj, Tx, Ap, Ai, Ax, Map);
 
-      else
 
-	status = umfpack_zi_triplet_to_col(n_row, n_col, nz, Ti, Tj, Tx, NULL, Ap, Ai, Ax, NULL, Map);
 
-      if (*fault = (status != UMFPACK_OK))
 
-	result = ((status == UMFPACK_ERROR_out_of_memory) ? avm_copied(memory_overflow) : avm_copied(bad_umf_spec));
 
-    }
 
-  freeif (Ti);
 
-  freeif (Tj);
 
-  freeif (Tx);
 
-  if (real)
 
-    Ab = (*fault ? NULL : avm_vector_of_list (b, sizeof(double), &result, fault));
 
-  else
 
-    Ab = (*fault ? NULL : avm_vector_of_list (b, sizeof(complex), &result, fault));
 
-  return umfpack_i (real, result, mode, Ap, Ai, Ax, Ab, Abl, fault);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-#endif
 
-
 
-
 
-
 
-
 
-list
 
-avm_have_umf_call (list function_name, int *fault)
 
-
 
-/* this reports the availability of a function */
 
-
 
-{
 
-#if HAVE_UMF
 
-  list membership;
 
-  list comparison;
 
-  list result;
 
-
 
-  if (!initialized)
 
-    avm_initialize_umf ();
 
-  if (*fault)
 
-    return NULL;
 
-  comparison = avm_binary_comparison (function_name, wild, fault);
 
-  if (*fault)
 
-    return comparison;
 
-  if (comparison)
 
-    {
 
-      avm_dispose(comparison);
 
-      return avm_copied(funs);
 
-    }
 
-  if (!(membership = avm_binary_membership (function_name, funs, fault)) ? 1 : *fault)
 
-    return membership;
 
-  avm_dispose(membership);
 
-  return ((*fault = !(result = avm_recoverable_join(avm_copied(function_name),NULL))) ? avm_copied(memory_overflow) : result);
 
-#endif
 
-  return NULL;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_umf_call (function_name, argument, fault)
 
-     list function_name;
 
-     list argument;
 
-     int *fault;
 
-{
 
-#if HAVE_UMF
 
-  list message;
 
-  int function_number;
 
-
 
-  if (*fault)
 
-    return NULL;
 
-  if (! initialized)
 
-    avm_initialize_umf ();
 
-  if (!(function_number = 0xff & (function_name ? function_name->characterization : 0)))
 
-    {
 
-      message = avm_position (function_name, funs, fault);
 
-      if (*fault)
 
-	return (message);
 
-      if (*fault = !message)
 
-	return avm_copied (unrecognized_function_name);
 
-      function_number = message->characterization;
 
-      function_name->characterization = function_number;
 
-      avm_dispose (message);
 
-    }
 
-  switch (function_number)
 
-    {
 
-    case  1: return umfpack_i_trp (1, UMFPACK_A, argument, fault);
 
-    case  2: return umfpack_i_trp (1, UMFPACK_Aat, argument, fault);
 
-    case  3: return umfpack_i_col (1, UMFPACK_A, argument, fault);
 
-    case  4: return umfpack_i_col (1, UMFPACK_Aat, argument, fault);
 
-    case  5: return umfpack_i_trp (0, UMFPACK_A, argument, fault);
 
-    case  6: return umfpack_i_trp (0, UMFPACK_At, argument, fault);
 
-    case  7: return umfpack_i_trp (0, UMFPACK_Aat, argument, fault);
 
-    case  8: return umfpack_i_col (0, UMFPACK_A, argument, fault);
 
-    case  9: return umfpack_i_col (0, UMFPACK_At, argument, fault);
 
-    case 10: return umfpack_i_col (0, UMFPACK_Aat, argument, fault);
 
-    }
 
-#endif /* !HAVE_UMF */
 
-  *fault = 1;
 
-  return avm_copied (unrecognized_function_name);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_umf ()
 
-
 
-     /* This initializes some static data structures. */
 
-
 
-{
 
-  char *funames[] = { /* see umfpack user guide page 24 */
 
-    "di_a_trp",
 
-    "di_t_trp",
 
-    "di_a_col",
 
-    "di_t_col",
 
-    "zi_a_trp",
 
-    "zi_c_trp",
 
-    "zi_t_trp",
 
-    "zi_a_col",
 
-    "zi_c_col",
 
-    "zi_t_col",
 
-    NULL};            /* add more function names here up to a total of 255 */
 
-  list back;
 
-  int string_number;
 
-
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  avm_initialize_listfuns ();
 
-  avm_initialize_matcon ();
 
-  avm_initialize_chrcodes ();
 
-  wild = avm_strung("*");
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-  umf_error = avm_join (avm_strung ("umf error"), NULL);
 
-  bad_umf_spec = avm_join (avm_strung ("bad umf specification"), NULL);
 
-  unrecognized_function_name = avm_join (avm_strung ("unrecognized umf function name"), NULL);
 
-  string_number = 0;
 
-  funs = back = NULL;
 
-  while (funames[string_number])
 
-    avm_enqueue (&funs, &back, avm_standard_strung (funames[string_number++]));
 
-}
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_umf ()
 
-
 
-     /* This frees some static data structures as an aid to the
 
-	detection of memory leaks. */
 
-{
 
-
 
-  if (!initialized)
 
-    return;
 
-  initialized = 0;
 
-  avm_dispose (funs);
 
-  avm_dispose (wild);
 
-  avm_dispose (umf_error);
 
-  avm_dispose (bad_umf_spec);
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (unrecognized_function_name);
 
-  funs = NULL;
 
-  wild = NULL;
 
-  umf_error = NULL;
 
-  memory_overflow = NULL;
 
-  unrecognized_function_name = NULL;
 
-}

+ 0 - 260
src/vglue.c
View File 

@@ -1,260 +0,0 @@
 
-
 
-/* virtual glue code generating functions
 
-
 
-   Copyright (C) 2010 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
-*/
 
-
 
-#include <avm/chrcodes.h>
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/lists.h>
 
-
 
-/* Non-zero means static variables have been initialized. */
 
-static int initialized = 0;
 
-
 
-/* error messages as lists of lists of character representations */
 
-static list memory_overflow = NULL;
 
-
 
-/* used for constructing virtual code */
 
-static list shared_cell = NULL;
 
-
 
-/* constants used to construct a merging function from a predicate */
 
-static list merge_0 = NULL;
 
-static list merge_1 = NULL;
 
-static list merge_2 = NULL;
 
-static list merge_3 = NULL;
 
-static list merge_4 = NULL;
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_compose (operator, preprocessor, fault)
 
-     list operator;
 
-     list preprocessor;
 
-     int *fault;
 
-
 
-     /* returns the virtual machine code for the composition of a pair of functions */
 
-{
 
-  if (!initialized)
 
-    avm_initialize_vglue ();
 
-  *fault = (*fault ? 1 : !operator ? 1 : !preprocessor);
 
-  if (!operator ? 0 : operator->tail ? 0 : !(operator->head) ? 0 : !(operator->head->head))
 
-    {
 
-      avm_dispose (preprocessor);
 
-      preprocessor = NULL;
 
-    }
 
-  else
 
-    {
 
-      *fault = (*fault ? 1 : !(operator = avm_recoverable_join (operator, preprocessor)));
 
-      *fault = (*fault ? 1 : !(operator = avm_recoverable_join (operator, NULL)));
 
-    }
 
-  if (*fault)
 
-    {
 
-      avm_dispose (operator);
 
-      avm_dispose (preprocessor);
 
-      return NULL;
 
-    }
 
-  return operator;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_map (operator, fault)
 
-     list operator;
 
-     int *fault;
 
-
 
-     /* returns the virtual machine code for the map of a function */
 
-{
 
-  if (!initialized)
 
-    avm_initialize_vglue ();
 
-  *fault = (*fault ? 1 : ! operator);
 
-  *fault = (*fault ? 1 : ! (operator = avm_recoverable_join (NULL, operator)));
 
-  *fault = (*fault ? 1 : ! (operator = avm_recoverable_join (operator, NULL)));
 
-  *fault = (*fault ? 1 : ! (operator = avm_recoverable_join (avm_copied (shared_cell), operator)));
 
-  if (*fault)
 
-    {
 
-      avm_dispose (operator);
 
-      return NULL;
 
-    }
 
-  return operator;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_reduce (operator, fault)
 
-     list operator;
 
-     int *fault;
 
-
 
-     /* returns the virtual machine code for the reduce of a function with an empty vacuous case */
 
-{
 
-  if (!initialized)
 
-    avm_initialize_vglue ();
 
-  *fault = (*fault ? 1 : ! operator);
 
-  *fault = (*fault ? 1 : ! (operator = avm_recoverable_join (operator, NULL)));
 
-  *fault = (*fault ? 1 : ! (operator = avm_recoverable_join (operator, NULL)));
 
-  *fault = (*fault ? 1 : ! (operator = avm_recoverable_join (avm_copied (shared_cell), operator)));
 
-  if (*fault)
 
-    {
 
-      avm_dispose (operator);
 
-      return NULL;
 
-    }
 
-  return operator;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_sort (operator, fault)
 
-     list operator;
 
-     int *fault;
 
-
 
-     /* takes a predicate to a function that sorts a list according to it */
 
-{
 
-  if (!initialized)
 
-    avm_initialize_vglue ();
 
-  *fault = (*fault ? 1 : ! operator);
 
-  *fault = (*fault ? 1 : ! (operator = avm_recoverable_join (operator, NULL)));
 
-  *fault = (*fault ? 1 : ! (operator = avm_recoverable_join (operator, avm_copied (shared_cell))));
 
-  *fault = (*fault ? 1 : ! (operator = avm_recoverable_join (avm_copied (shared_cell), operator)));
 
-  if (*fault)
 
-    {
 
-      avm_dispose (operator);
 
-      return NULL;
 
-    }
 
-  return operator;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-list
 
-avm_merge (predicate, fault)
 
-     list predicate;
 
-     int *fault;
 
-
 
-     /* takes a predicate to a function that merges two lists according to it */
 
-{
 
-  if (!initialized)
 
-    avm_initialize_vglue ();
 
-  *fault = (*fault ? 1 : ! predicate);
 
-  *fault = (*fault ? 1 : ! (predicate = avm_recoverable_join (predicate, avm_copied (merge_0))));
 
-  *fault = (*fault ? 1 : ! (predicate = avm_recoverable_join (predicate, NULL)));
 
-  *fault = (*fault ? 1 : ! (predicate = avm_recoverable_join (predicate, avm_copied (merge_1))));
 
-  *fault = (*fault ? 1 : ! (predicate = avm_recoverable_join (predicate, avm_copied (merge_2))));
 
-  *fault = (*fault ? 1 : ! (predicate = avm_recoverable_join (avm_copied (merge_3), predicate)));
 
-  *fault = (*fault ? 1 : ! (predicate = avm_recoverable_join (predicate, avm_copied (merge_4))));
 
-  *fault = (*fault ? 1 : ! (predicate = avm_recoverable_join (avm_copied (merge_4), predicate)));
 
-  *fault = (*fault ? 1 : ! (predicate = avm_recoverable_join (predicate, avm_copied (merge_3))));
 
-  *fault = (*fault ? 1 : ! (predicate = avm_recoverable_join (predicate, NULL)));
 
-  *fault = (*fault ? 1 : ! (predicate = avm_recoverable_join (predicate, NULL)));
 
-  *fault = (*fault ? 1 : ! (predicate = avm_recoverable_join (predicate, NULL)));
 
-  if (*fault)
 
-    {
 
-      avm_dispose (predicate);
 
-      return NULL;
 
-    }
 
-  return predicate;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_initialize_vglue ()
 
-
 
-     /* This initializes static data structures. */
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  avm_initialize_lists ();
 
-  shared_cell = avm_join (NULL, NULL);
 
-  merge_0 = avm_scanned_list ("goL<");
 
-  merge_1 = avm_scanned_list ("yHip]n\\");
 
-  merge_2 = avm_scanned_list ("yHgp]nD");
 
-  merge_3 = avm_scanned_list ("f\\");
 
-  merge_4 = avm_scanned_list ("g<");
 
-  memory_overflow = avm_join (avm_strung ("memory overflow"), NULL);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_count_vglue ()
 
-
 
-{
 
-  if (!initialized)
 
-    return;
 
-  avm_dispose (memory_overflow);
 
-  avm_dispose (merge_0);
 
-  avm_dispose (merge_1);
 
-  avm_dispose (merge_2);
 
-  avm_dispose (merge_3);
 
-  avm_dispose (merge_4);
 
-  avm_dispose (shared_cell);
 
-  shared_cell = NULL;
 
-  merge_0 = NULL;
 
-  merge_1 = NULL;
 
-  merge_2 = NULL;
 
-  merge_3 = NULL;
 
-  merge_4 = NULL;
 
-  memory_overflow = NULL;
 
-  initialized = 0;
 
-}

+ 0 - 148
src/vman.c
View File 

@@ -1,148 +0,0 @@
 
-
 
-/* management of backward compatibility modes
 
-
 
-   Copyright (C) 2006 Dennis Furey
 
-
 
-   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; if not, write to the Free Software Foundation,
 
-   Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.  
-
 
-*/
 
-
 
-#include <avm/common.h>
 
-#include <avm/error.h>
 
-#include <avm/vman.h>
 
-
 
-/* increment this when creating a new version */
 
-#define number_of_versions 3
 
-
 
-/* an array of strings representing past and present version numbers */
 
-static char *known_versions[number_of_versions];
 
-
 
-/* an index into the array of known versions indicating which version is being emulated */
 
-static int selection;
 
-
 
-/* non-zero means a version has been selected */
 
-static int selected = 0;
 
-
 
-/* non-zero means static variables are initialized */
 
-static int initialized = 0;
 
-
 
-
 
-
 
-
 
-static void
 
-initialize_vman ()
 
-
 
-     /* This is used locally to initialize the table of known version numbers. */
 
-{
 
-  if (initialized)
 
-    return;
 
-  initialized = 1;
 
-  selection = number_of_versions - 1;
 
-  known_versions[0] = "0.0.0";
 
-  known_versions[1] = "0.1.0";
 
-
 
-  /* put the present version number above when creating a new one */
 
-
 
-  known_versions[number_of_versions - 1] = VERSION;
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-void
 
-avm_set_version (number)
 
-     char *number;
 
-
 
-     /* This is used for emulating earlier versions; the version set
 
-        by this function can be interrogated by the one below. If this
 
-        function is called, it must be called before any other
 
-        function in this file.  */
 
-
 
-{
 
-  int found;
 
-
 
-  if (selected)
 
-    avm_error ("multiple version specifications");
 
-  if (initialized)
 
-    avm_internal_error (36);
 
-  initialize_vman ();
 
-  if (!number)
 
-    avm_internal_error (37);
 
-  selected = 1;
 
-  found = selection = 0;
 
-  while (found ? 0 : (selection < number_of_versions))
 
-    if (!(found = !strcmp (known_versions[selection], number)))
 
-      selection++;
 
-  if (!found)
 
-    {
 
-      fprintf (stderr, "avram: can't emulate version %s\n", number);
 
-      exit (EXIT_FAILURE);
 
-    }
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-char *
 
-avm_version ()
 
-
 
-     /* This returns the version previously set by avm_set_version, or
 
-        returns the current version by default if none has been
 
-        set. */
 
-{
 
-  if (!initialized)
 
-    initialize_vman ();
 
-  return (known_versions[selection]);
 
-}
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-
 
-int
 
-avm_prior_to_version (number)
 
-     char *number;
 
-
 
-     /* This takes a version number in a string, which must be one of
 
-        the known versions, and returns true if the version currently
 
-        being emulated is earlier than the given one. */
 
-
 
-{
 
-  int matching_index;
 
-
 
-  if (!initialized)
 
-    initialize_vman ();
 
-  if (!number)
 
-    avm_internal_error (50);
 
-  matching_index = 0;
 
-  while ((matching_index < number_of_versions) ? strcmp (number,known_versions[matching_index]) : 0)
 
-    matching_index++;
 
-  if (matching_index >= number_of_versions)
 
-    avm_internal_error (35);
 
-  return (selection < matching_index);
 
-}

+ 0 - 40
src/xstrerror.c
View File 

@@ -1,40 +0,0 @@
 
-/* xstrerror.c -- strerror wrapper with bound checking
 
-   Fri Jun 16 18:30:00 1995  Pat Rankin  <[email protected]>
 
-   This code is in the public domain.
 
-
 
-   Modified by Dennis Furey, February 26, 2001, to use the
 
-   HAVE_STRERROR symbol in case this is being compiled on a system
 
-   that doesn't have it. */
 
-
 
-#if HAVE_CONFIG_H
 
-# include <config.h>
 
-#endif
 
-
 
-#include <stdio.h>
 
-
 
-#if HAVE_STRERROR
 
-extern char *strerror ();
 
-#else
 
-char *strerror (){return(NULL);}
 
-#endif
 
-
 
-/* If strerror returns NULL, we'll format the number into a static buffer.  */
 
-#define ERRSTR_FMT "undocumented error #%d"
 
-static char xstrerror_buf[sizeof ERRSTR_FMT + 20];
 
-
 
-/* This is like strerror, but result is never a null pointer.  */
 
-char *
 
-xstrerror (errnum)
 
-     int errnum;
 
-{
 
-  char *errstr = strerror (errnum);
 
-
 
-  /* If `errnum' is out of range, result might be NULL.  We'll fix that.  */
 
-  if (!errstr)
 
-    {
 
-      sprintf (xstrerror_buf, ERRSTR_FMT, errnum);
 
-      errstr = xstrerror_buf;
 
-    }
 
-
 
-  return errstr;
 
-}