/*
 *                             S A V E . C
 *
 *  Function to save a scheme function (closure) in a "pretty" format.
 *
 *  Version      : $Revision: 1.2 $
 *
 *  Created      : Fri Jul  1 18:08:52 1994
 *  Author       : Ulrich Drepper <drepper@mydec>
 *
 *  Last modified: Mon Jul  4 14:15:25 1994
 *  Author       : Ulrich Drepper <drepper@mydec>
 *
 *  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 1, 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., 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 */
#if !defined(lint)
static const char *vcid = "$Id: save.c,v 1.2 1994/07/04 13:15:33 drepper Exp $";
#endif /* lint */

#include "empire.h"
#include "scheme.h"

/*
 * local functions
 */
static Scheme_Object *save(Scheme_Object *form, Scheme_Env *env);

/*
 * exported functions
 */
void
scheme_init_save(Scheme_Env *env)
{
    scheme_add_global("save", scheme_make_syntax(save), env);
}

/*
 * local functions
 */
static Scheme_Object *
save(Scheme_Object *form, Scheme_Env *env)
{
    int len = scheme_list_length(form);
    Scheme_Object *closure;
    Scheme_Object *closName;
    Scheme_Object *fName;
    Scheme_Object *outPort;
    FILE *fp;

    SCHEME_ASSERT((len == 3), "save: wrong number of arguments");
    closName = SCHEME_CAR(SCHEME_CDR(form));
    closure  = scheme_eval(closName, env);
    SCHEME_ASSERT(SCHEME_CLOSUREP(closure), "save: first arg must be closure");
    fName = SCHEME_CAR(SCHEME_CDR(SCHEME_CDR(form)));
    SCHEME_ASSERT(SCHEME_STRINGP(fName), "save: second arg must be a string");
    SCHEME_ASSERT(scheme_lookup_value(
	              scheme_intern_symbol("generic-write"),
                      env),
		  "save: pretty print function `generic-write' not defined");

    fp = fopen(SCHEME_STR_VAL(fName), "w");
    if (!fp) {
	scheme_signal_error("Cannot open output file %s", fName);
	/* NOTREACHED */
    }
    outPort = scheme_make_output_port(fp);

    /* (generic-write '(define (<name> <params>) <body>) #t NR_COLS
           (lambda (s) (display s <outPort>)) */
#define NR_COLS 70
    scheme_eval(scheme_make_pair(
	scheme_intern_symbol("generic-write"),
        scheme_make_pair(
	    scheme_make_pair(
                scheme_quote_symbol,
	        scheme_make_pair(
		    scheme_make_pair(
		        scheme_intern_symbol("define"),
	                scheme_make_pair(
		            scheme_make_pair(
			        closName,
		                SCHEME_CAR(SCHEME_CLOS_CODE(closure))),
		            SCHEME_CDR(SCHEME_CLOS_CODE(closure)))),
		    scheme_null)),
	    scheme_make_pair(
		scheme_true,
	        scheme_make_pair(
		    scheme_make_integer(NR_COLS),
		    scheme_make_pair(
		        scheme_make_pair(
			    scheme_intern_symbol("lambda"),
			    scheme_make_pair(
				scheme_make_pair(
				    scheme_intern_symbol("s"),
				    scheme_null),
			        scheme_make_pair(
				    scheme_make_pair(
					scheme_intern_symbol("display"),
				        scheme_make_pair(
					    scheme_intern_symbol("s"),
					    scheme_make_pair(
						outPort,
					        scheme_null))),
				    scheme_null))),
		        scheme_null))))), env);

    fclose(fp);

    return scheme_true;
}


/*
 * Local Variables:
 *  mode:c
 *  c-indent-level:4
 *  c-continued-statement-offset:4
 *  c-continued-brace-offset:0
 *  c-brace-offset:0
 *  c-imaginary-offset:0
 *  c-argdecl-indent:4
 *  c-label-offset:-2
 * End:
 */
