static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) { int i; if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x) || sexp_flonump(x) || sexp_bignump(x)) { sexp_write(ctx, x, out); } else if (depth <= 0) { goto print_name; } else if (sexp_synclop(x)) { sexp_write_string(ctx, "#<sc ", out); sexp_print_simple(ctx, sexp_synclo_expr(x), out, depth); sexp_write_string(ctx, ">", out); } else if (sexp_pairp(x)) { sexp_write_char(ctx, '(', out); sexp_print_simple(ctx, sexp_car(x), out, depth-1); sexp_write_string(ctx, " . ", out); sexp_print_simple(ctx, sexp_cdr(x), out, depth-1); sexp_write_char(ctx, ')', out); } else if (sexp_vectorp(x)) { sexp_write_string(ctx, "#(", out); for (i=0; i<SEXP_HEAP_VECTOR_DEPTH && i<(int)sexp_vector_length(x); i++) { if (i>0) sexp_write_char(ctx, ' ', out); sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1); } if (i<(int)sexp_vector_length(x)) sexp_write_string(ctx, " ...", out); sexp_write_char(ctx, ')', out); } else { print_name: sexp_write_string(ctx, "#<", out); sexp_write(ctx, sexp_object_type_name(ctx, x), out); sexp_write_string(ctx, ">", out); } }
unsigned short sexp_writeln(IOHandle *h, sexp_t *x) { unsigned short result; fflush(NULL); result = sexp_write(h, x); if (result == 0) { iohandle_write(h, cmsg_cstring_bytes("\n")); ICHECK(iohandle_flush(h), "sexp_writeln iohandle_flush"); } return result; }
static gcry_error_t account_write(FILE *privf, const char *accountname, const char *protocol, gcry_sexp_t privkey) { gcry_error_t err; gcry_sexp_t names, protos; fprintf(privf, " (account\n"); err = gcry_sexp_build(&names, NULL, "(name %s)", accountname); if (!err) { err = sexp_write(privf, names); gcry_sexp_release(names); } if (!err) err = gcry_sexp_build(&protos, NULL, "(protocol %s)", protocol); if (!err) { err = sexp_write(privf, protos); gcry_sexp_release(protos); } if (!err) err = sexp_write(privf, privkey); fprintf(privf, " )\n"); return err; }
static int do_public_key( IOBUF out, int ctb, PKT_public_key *pk ) { int rc = 0; int n, i; IOBUF a = iobuf_temp(); if ( !pk->version ) iobuf_put( a, 3 ); else iobuf_put( a, pk->version ); write_32(a, pk->timestamp ); if ( pk->version < 4 ) { u16 ndays; if ( pk->expiredate ) ndays = (u16)((pk->expiredate - pk->timestamp) / 86400L); else ndays = 0; write_16(a, ndays ); } iobuf_put (a, pk->pubkey_algo ); if ( pk->pubkey_algo == PUBKEY_ALGO_NTRU){ rc = sexp_write(a, pk->ntru_pkey); } else { n = pubkey_get_npkey ( pk->pubkey_algo ); if ( !n ) write_fake_data( a, pk->pkey[0] ); } if (!rc) { write_header2 (out, ctb, iobuf_get_temp_length(a), pk->hdrbytes); printf("write output\n"); rc = iobuf_write_temp ( out, a ); } printf("finished writing\n"); iobuf_close(a); return rc; }
static void repl (sexp ctx, sexp env) { sexp_gc_var6(obj, tmp, res, in, out, err); sexp_gc_preserve6(ctx, obj, tmp, res, in, out, err); sexp_context_tracep(ctx) = 1; in = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL)); out = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL)); err = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL)); if (in == NULL || out == NULL) { fprintf(stderr, "Standard I/O ports not found, aborting. Maybe a bad -x language?\n"); exit_failure(); } if (err == NULL) err = out; sexp_port_sourcep(in) = 1; while (1) { sexp_write_string(ctx, "> ", out); sexp_flush(ctx, out); sexp_maybe_block_port(ctx, in, 1); obj = sexp_read(ctx, in); sexp_maybe_unblock_port(ctx, in); if (obj == SEXP_EOF) break; if (sexp_exceptionp(obj)) { sexp_print_exception(ctx, obj, err); } else { sexp_context_top(ctx) = 0; if (!(sexp_idp(obj)||sexp_pairp(obj)||sexp_nullp(obj))) obj = sexp_make_lit(ctx, obj); tmp = sexp_env_bindings(env); res = sexp_eval(ctx, obj, env); #if SEXP_USE_WARN_UNDEFS sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, res); #endif if (res && sexp_exceptionp(res)) { sexp_print_exception(ctx, res, err); if (res != sexp_global(ctx, SEXP_G_OOS_ERROR)) sexp_stack_trace(ctx, err); } else if (res != SEXP_VOID) { sexp_write(ctx, res, out); sexp_write_char(ctx, '\n', out); } } } sexp_gc_release6(ctx); }
static void repl (sexp ctx, sexp env) { sexp in, out, err; sexp_gc_var3(obj, tmp, res); sexp_gc_preserve3(ctx, obj, tmp, res); sexp_context_tracep(ctx) = 1; in = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL)); out = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL)); err = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL)); sexp_port_sourcep(in) = 1; while (1) { sexp_write_string(ctx, "> ", out); sexp_flush(ctx, out); sexp_maybe_block_port(ctx, in, 1); obj = sexp_read(ctx, in); sexp_maybe_unblock_port(ctx, in); if (obj == SEXP_EOF) break; if (sexp_exceptionp(obj)) { sexp_print_exception(ctx, obj, err); } else { tmp = sexp_env_bindings(env); sexp_context_top(ctx) = 0; res = sexp_eval(ctx, obj, env); if (sexp_exceptionp(res)) { sexp_print_exception(ctx, res, err); sexp_stack_trace(ctx, err); } else { #if SEXP_USE_WARN_UNDEFS sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp); #endif if (res != SEXP_VOID) { sexp_write(ctx, res, out); sexp_write_char(ctx, '\n', out); } } } } sexp_gc_release3(ctx); }
sexp run_main (int argc, char **argv) { #if SEXP_USE_MODULES char *impmod; #endif char *arg; const char *prefix=NULL, *suffix=NULL, *main_symbol=NULL, *main_module=NULL; sexp_sint_t i, j, c, quit=0, print=0, init_loaded=0, mods_loaded=0, fold_case=SEXP_DEFAULT_FOLD_CASE_SYMS, nonblocking=0; sexp_uint_t heap_size=0, heap_max_size=SEXP_MAXIMUM_HEAP_SIZE; sexp out=SEXP_FALSE, ctx=NULL, ls; sexp_gc_var4(tmp, sym, args, env); args = SEXP_NULL; env = NULL; /* SRFI 22: invoke `main` procedure by default if the interpreter is */ /* invoked as `scheme-r7rs`. */ arg = strrchr(argv[0], '/'); if (strncmp((arg == NULL ? argv[0] : arg + 1), "scheme-r7rs", strlen("scheme-r7rs")) == 0) { main_symbol = "main"; /* skip option parsing since we can't pass `--` before the name of script */ /* to avoid misinterpret the name as options when the interpreter is */ /* executed via `#!/usr/env/bin scheme-r7rs` shebang. */ i = 1; goto done_options; } /* parse options */ for (i=1; i < argc && argv[i][0] == '-'; i++) { switch ((c=argv[i][1])) { case 'D': init_context(); arg = (argv[i][2] == '\0') ? argv[++i] : argv[i]+2; sym = sexp_intern(ctx, arg, -1); ls = sexp_global(ctx, SEXP_G_FEATURES); if (sexp_pairp(ls)) { for (; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls)) ; sexp_cdr(ls) = sexp_cons(ctx, sym, SEXP_NULL); } break; case 'e': case 'p': mods_loaded = 1; load_init(0); print = (argv[i][1] == 'p'); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('e', arg); tmp = check_exception(ctx, sexp_eval_string(ctx, arg, -1, env)); if (print) { if (! sexp_oportp(out)) out = sexp_eval_string(ctx, "(current-output-port)", -1, env); sexp_write(ctx, tmp, out); sexp_write_char(ctx, '\n', out); } quit = 1; break; case 'l': mods_loaded = 1; load_init(0); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('l', arg); check_exception(ctx, sexp_load_module_file(ctx, arg, env)); break; case 'x': prefix = sexp_environment_prefix; suffix = sexp_environment_suffix; case 'm': arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); if (c == 'x') { if (strcmp(arg, "chibi.primitive") == 0) { goto load_primitive; } else if (strcmp(arg, "scheme.small") == 0) { load_init(0); break; } } else { prefix = sexp_import_prefix; suffix = sexp_import_suffix; } mods_loaded = 1; load_init(c == 'x'); #if SEXP_USE_MODULES check_nonull_arg(c, arg); impmod = make_import(prefix, arg, suffix); tmp = check_exception(ctx, sexp_eval_string(ctx, impmod, -1, (c=='x' ? sexp_global(ctx, SEXP_G_META_ENV) : env))); free(impmod); if (c == 'x') { sexp_set_parameter(ctx, sexp_global(ctx, SEXP_G_META_ENV), sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), tmp); sexp_context_env(ctx) = env = tmp; sexp_add_import_binding(ctx, env); tmp = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL)); if (tmp != NULL && !sexp_oportp(tmp)) { sexp_load_standard_ports(ctx, env, stdin, stdout, stderr, 0); } } #endif break; load_primitive: case 'Q': init_context(); mods_loaded = 1; if (! init_loaded++) sexp_load_standard_ports(ctx, env, stdin, stdout, stderr, 0); handle_noarg(); break; case 'q': argv[i--] = (char*)"-xchibi"; break; case 'A': init_context(); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('A', arg); sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE); break; case 'I': init_context(); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('I', arg); sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE); break; #if SEXP_USE_GREEN_THREADS case 'b': nonblocking = 1; break; #endif case '-': if (argv[i][2] == '\0') { i++; goto done_options; } sexp_usage(1); case 'h': arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('h', arg); #if ! SEXP_USE_BOEHM heap_size = strtoul(arg, &arg, 0); if (sexp_isalpha((unsigned char)*arg)) heap_size *= multiplier(*arg++); if (*arg == '/') { heap_max_size = strtoul(arg+1, &arg, 0); if (sexp_isalpha((unsigned char)*arg)) heap_max_size *= multiplier(*arg++); } #endif break; #if SEXP_USE_IMAGE_LOADING case 'i': arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); if (ctx) { fprintf(stderr, "-:i <file>: image files must be loaded first\n"); exit_failure(); } ctx = sexp_load_image(arg, 0, heap_size, heap_max_size); if (!ctx || !sexp_contextp(ctx)) { fprintf(stderr, "-:i <file>: couldn't open image file for reading: %s\n", arg); fprintf(stderr, " %s\n", sexp_load_image_err()); ctx = NULL; } else { env = sexp_load_standard_params(ctx, sexp_context_env(ctx), nonblocking); init_loaded++; } break; case 'd': if (! init_loaded++) { init_context(); env = sexp_load_standard_env(ctx, env, SEXP_SEVEN); } arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); if (sexp_save_image(ctx, arg) != SEXP_TRUE) { fprintf(stderr, "-d <file>: couldn't save image to file: %s\n", arg); fprintf(stderr, " %s\n", sexp_load_image_err()); exit_failure(); } quit = 1; break; #endif case 'V': load_init(1); if (! sexp_oportp(out)) out = sexp_eval_string(ctx, "(current-output-port)", -1, env); sexp_write_string(ctx, sexp_version_string, out); tmp = sexp_env_ref(ctx, env, sym=sexp_intern(ctx, "*features*", -1), SEXP_NULL); sexp_write(ctx, tmp, out); sexp_newline(ctx, out); return SEXP_TRUE; #if SEXP_USE_FOLD_CASE_SYMS case 'f': fold_case = 1; init_context(); sexp_global(ctx, SEXP_G_FOLD_CASE_P) = SEXP_TRUE; handle_noarg(); break; #endif case 'R': main_module = argv[i][2] != '\0' ? argv[i]+2 : (i+1 < argc && argv[i+1][0] != '-') ? argv[++i] : "chibi.repl"; if (main_symbol == NULL) main_symbol = "main"; break; case 'r': main_symbol = argv[i][2] == '\0' ? "main" : argv[i]+2; break; case 's': init_context(); sexp_global(ctx, SEXP_G_STRICT_P) = SEXP_TRUE; handle_noarg(); break; case 'T': init_context(); sexp_global(ctx, SEXP_G_NO_TAIL_CALLS_P) = SEXP_TRUE; handle_noarg(); break; case 't': mods_loaded = 1; load_init(1); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); #if SEXP_USE_MODULES check_nonull_arg('t', arg); suffix = strrchr(arg, '.'); sym = sexp_intern(ctx, suffix + 1, -1); *(char*)suffix = '\0'; impmod = make_import(sexp_trace_prefix, arg, sexp_trace_suffix); tmp = check_exception(ctx, sexp_eval_string(ctx, impmod, -1, sexp_meta_env(ctx))); if (!(tmp && sexp_envp(tmp))) { fprintf(stderr, "couldn't find library to trace: %s\n", impmod); } else if (!((sym = sexp_env_cell(ctx, tmp, sym, 0)))) { fprintf(stderr, "couldn't find binding to trace: %s in %s\n", suffix + 1, impmod); } else { sym = sexp_list1(ctx, sym); tmp = check_exception(ctx, sexp_eval_string(ctx, "(environment '(chibi trace))", -1, sexp_meta_env(ctx))); tmp = sexp_env_ref(ctx, tmp, sexp_intern(ctx, "trace-cell", -1), 0); if (tmp && sexp_procedurep(tmp)) check_exception(ctx, sexp_apply(ctx, tmp, sym)); } free(impmod); #endif break; default: fprintf(stderr, "unknown option: %s\n", argv[i]); /* ... FALLTHROUGH ... */ case '?': sexp_usage(1); } } done_options: if (!quit || main_symbol != NULL) { init_context(); /* build argument list */ if (i < argc) for (j=argc-1; j>=i; j--) args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args); if (i >= argc || main_symbol != NULL) args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args); load_init(i < argc || main_symbol != NULL); sexp_set_parameter(ctx, sexp_meta_env(ctx), sym=sexp_intern(ctx, sexp_argv_symbol, -1), args); if (i >= argc && main_symbol == NULL) { /* no script or main, run interactively */ repl(ctx, env); } else { #if SEXP_USE_MODULES /* load the module or script */ if (main_module != NULL) { impmod = make_import("(load-module '(", main_module, "))"); env = check_exception(ctx, sexp_eval_string(ctx, impmod, -1, sexp_meta_env(ctx))); if (sexp_vectorp(env)) env = sexp_vector_ref(env, SEXP_ONE); free(impmod); check_exception(ctx, env); if (!sexp_envp(env)) { fprintf(stderr, "couldn't find module: %s\n", main_module); exit_failure(); } } else #endif if (i < argc) { /* script usage */ #if SEXP_USE_MODULES /* reset the environment to have only the `import' and */ /* `cond-expand' bindings */ if (!mods_loaded) { env = sexp_make_env(ctx); sexp_set_parameter(ctx, sexp_meta_env(ctx), sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env); sexp_context_env(ctx) = env; sym = sexp_intern(ctx, "repl-import", -1); tmp = sexp_env_ref(ctx, sexp_meta_env(ctx), sym, SEXP_VOID); sym = sexp_intern(ctx, "import", -1); check_exception(ctx, sexp_env_define(ctx, env, sym, tmp)); sym = sexp_intern(ctx, "cond-expand", -1); tmp = sexp_env_cell(ctx, sexp_meta_env(ctx), sym, 0); #if SEXP_USE_RENAME_BINDINGS sexp_env_rename(ctx, env, sym, tmp); #endif sexp_env_define(ctx, env, sym, sexp_cdr(tmp)); } #endif sexp_context_tracep(ctx) = 1; tmp = sexp_env_bindings(env); #if SEXP_USE_MODULES /* use scheme load if possible for better stack traces */ sym = sexp_intern(ctx, "load", -1); tmp = sexp_env_ref(ctx, sexp_meta_env(ctx), sym, SEXP_FALSE); if (sexp_procedurep(tmp)) { sym = sexp_c_string(ctx, argv[i], -1); sym = sexp_list2(ctx, sym, env); tmp = check_exception(ctx, sexp_apply(ctx, tmp, sym)); } else #endif tmp = check_exception(ctx, sexp_load(ctx, sym=sexp_c_string(ctx, argv[i], -1), env)); #if SEXP_USE_WARN_UNDEFS sexp_warn_undefs(ctx, env, tmp, SEXP_VOID); #endif #ifdef EMSCRIPTEN if (sexp_applicablep(tmp)) { sexp_resume_ctx = ctx; sexp_resume_proc = tmp; sexp_preserve_object(ctx, sexp_resume_proc); emscripten_exit_with_live_runtime(); } #endif } /* SRFI-22: run main if specified */ if (main_symbol) { sym = sexp_intern(ctx, main_symbol, -1); tmp = sexp_env_ref(ctx, env, sym, SEXP_FALSE); if (sexp_procedurep(tmp)) { args = sexp_list1(ctx, sexp_cdr(args)); check_exception(ctx, sexp_apply(ctx, tmp, args)); } else { fprintf(stderr, "couldn't find main binding: %s in %s\n", main_symbol, main_module ? main_module : argv[i]); } } } } sexp_gc_release4(ctx); if (sexp_destroy_context(ctx) == SEXP_FALSE) { fprintf(stderr, "destroy_context error\n"); return SEXP_FALSE; } return SEXP_TRUE; }
static int do_secret_key( IOBUF out, int ctb, PKT_secret_key *sk ) { int rc = 0; int i, nskey, npkey; IOBUF a = iobuf_temp(); /* Build in a self-enlarging buffer. */ /* Write the version number - if none is specified, use 3 */ if ( !sk->version ) iobuf_put ( a, 3 ); else iobuf_put ( a, sk->version ); write_32 (a, sk->timestamp ); /* v3 needs the expiration time. */ if ( sk->version < 4 ) { u16 ndays; if ( sk->expiredate ) ndays = (u16)((sk->expiredate - sk->timestamp) / 86400L); else ndays = 0; write_16(a, ndays); } iobuf_put (a, sk->pubkey_algo ); if (sk->pubkey_algo == PUBKEY_ALGO_NTRU) { rc = sexp_write(a, sk->ntru_skey); } else { /* Get number of secret and public parameters. They are held in one array first the public ones, then the secret ones. */ nskey = pubkey_get_nskey ( sk->pubkey_algo ); npkey = pubkey_get_npkey ( sk->pubkey_algo ); /* If we don't have any public parameters - which is the case if we don't know the algorithm used - the parameters are stored as one blob in a faked (opaque) MPI. */ if ( !npkey ) { write_fake_data( a, sk->skey[0] ); goto leave; } assert ( npkey < nskey ); /* Writing the public parameters is easy. */ for (i=0; i < npkey; i++ ) if ((rc = mpi_write (a, sk->skey[i]))) goto leave; /* Build the header for protected (encrypted) secret parameters. */ if ( sk->is_protected ) { if ( is_RSA(sk->pubkey_algo) && sk->version < 4 && !sk->protect.s2k.mode ) { /* The simple rfc1991 (v3) way. */ iobuf_put (a, sk->protect.algo ); iobuf_write (a, sk->protect.iv, sk->protect.ivlen ); } else { /* OpenPGP protection according to rfc2440. */ iobuf_put(a, sk->protect.sha1chk? 0xfe : 0xff ); iobuf_put(a, sk->protect.algo ); if ( sk->protect.s2k.mode >= 1000 ) { /* These modes are not possible in OpenPGP, we use them to implement our extensions, 101 can be seen as a private/experimental extension (this is not specified in rfc2440 but the same scheme is used for all other algorithm identifiers) */ iobuf_put(a, 101 ); iobuf_put(a, sk->protect.s2k.hash_algo ); iobuf_write(a, "GNU", 3 ); iobuf_put(a, sk->protect.s2k.mode - 1000 ); } else { iobuf_put(a, sk->protect.s2k.mode ); iobuf_put(a, sk->protect.s2k.hash_algo ); } if ( sk->protect.s2k.mode == 1 || sk->protect.s2k.mode == 3 ) iobuf_write (a, sk->protect.s2k.salt, 8 ); if ( sk->protect.s2k.mode == 3 ) iobuf_put (a, sk->protect.s2k.count ); /* For our special modes 1001, 1002 we do not need an IV. */ if ( sk->protect.s2k.mode != 1001 && sk->protect.s2k.mode != 1002 ) iobuf_write (a, sk->protect.iv, sk->protect.ivlen ); } } else iobuf_put (a, 0 ); if ( sk->protect.s2k.mode == 1001 ) ; /* GnuPG extension - don't write a secret key at all. */ else if ( sk->protect.s2k.mode == 1002 ) { /* GnuPG extension - divert to OpenPGP smartcard. */ iobuf_put(a, sk->protect.ivlen ); /* Length of the serial number or 0 for no serial number. */ /* The serial number gets stored in the IV field. */ iobuf_write(a, sk->protect.iv, sk->protect.ivlen); } else if ( sk->is_protected && sk->version >= 4 ) { /* The secret key is protected - write it out as it is. */ byte *p; unsigned int ndatabits; assert (gcry_mpi_get_flag (sk->skey[npkey], GCRYMPI_FLAG_OPAQUE)); p = gcry_mpi_get_opaque (sk->skey[npkey], &ndatabits ); iobuf_write (a, p, (ndatabits+7)/8 ); } else if ( sk->is_protected ) { /* The secret key is protected the old v4 way. */ for ( ; i < nskey; i++ ) { byte *p; unsigned int ndatabits; assert (gcry_mpi_get_flag (sk->skey[i], GCRYMPI_FLAG_OPAQUE)); p = gcry_mpi_get_opaque (sk->skey[i], &ndatabits); iobuf_write (a, p, (ndatabits+7)/8); } write_16(a, sk->csum ); } else { /* Non-protected key. */ for ( ; i < nskey; i++ ) if ( (rc = mpi_write (a, sk->skey[i]))) goto leave; write_16 (a, sk->csum ); } } // algo != PUBKEY_ALGO_NTRU leave: if (!rc) { /* Build the header of the packet - which we must do after writing all the other stuff, so that we know the length of the packet */ write_header2(out, ctb, iobuf_get_temp_length(a), sk->hdrbytes); /* And finally write it out the real stream */ rc = iobuf_write_temp( out, a ); } iobuf_close(a); /* Close the remporary buffer */ return rc; }
void run_main (int argc, char **argv) { char *arg, *impmod, *p; sexp out=SEXP_FALSE, env=NULL, ctx=NULL; sexp_sint_t i, j, len, quit=0, print=0, init_loaded=0, fold_case=SEXP_DEFAULT_FOLD_CASE_SYMS; sexp_uint_t heap_size=0, heap_max_size=SEXP_MAXIMUM_HEAP_SIZE; sexp_gc_var2(tmp, args); args = SEXP_NULL; /* parse options */ for (i=1; i < argc && argv[i][0] == '-'; i++) { switch (argv[i][1]) { case 'e': case 'p': load_init(); print = (argv[i][1] == 'p'); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('e', arg); tmp = check_exception(ctx, sexp_eval_string(ctx, arg, -1, env)); if (print) { if (! sexp_oportp(out)) out = sexp_eval_string(ctx, "(current-output-port)", -1, env); sexp_write(ctx, tmp, out); sexp_write_char(ctx, '\n', out); } quit = 1; break; case 'l': load_init(); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('l', arg); check_exception(ctx, sexp_load_module_file(ctx, arg, env)); break; case 'm': load_init(); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('m', arg); len = strlen(arg)+strlen(sexp_import_prefix)+strlen(sexp_import_suffix); impmod = (char*) malloc(len+1); strcpy(impmod, sexp_import_prefix); strcpy(impmod+strlen(sexp_import_prefix), arg); strcpy(impmod+len-+strlen(sexp_import_suffix), sexp_import_suffix); impmod[len] = '\0'; for (p=impmod; *p; p++) if (*p == '.') *p=' '; check_exception(ctx, sexp_eval_string(ctx, impmod, -1, env)); free(impmod); break; case 'q': init_context(); if (! init_loaded++) sexp_load_standard_ports(ctx, env, stdin, stdout, stderr, 0); break; case 'A': init_context(); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('A', arg); sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE); break; case 'I': init_context(); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('I', arg); sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE); break; case '-': i++; goto done_options; case 'h': arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('h', arg); heap_size = strtoul(arg, &arg, 0); if (sexp_isalpha(*arg)) heap_size *= multiplier(*arg++); if (*arg == '/') { heap_max_size = strtoul(arg+1, &arg, 0); if (sexp_isalpha(*arg)) heap_max_size *= multiplier(*arg++); } break; case 'V': load_init(); if (! sexp_oportp(out)) out = sexp_eval_string(ctx, "(current-output-port)", -1, env); sexp_write_string(ctx, sexp_version_string, out); tmp = sexp_env_ref(env, sexp_intern(ctx, "*features*", -1), SEXP_NULL); sexp_write(ctx, tmp, out); sexp_newline(ctx, out); return; #if SEXP_USE_FOLD_CASE_SYMS case 'f': fold_case = 1; if (ctx) sexp_global(ctx, SEXP_G_FOLD_CASE_P) = SEXP_TRUE; break; #endif default: fprintf(stderr, "unknown option: %s\n", argv[i]); exit_failure(); } } done_options: if (! quit) { load_init(); if (i < argc) for (j=argc-1; j>i; j--) args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args); else args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args); sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol, -1), args); sexp_eval_string(ctx, sexp_argv_proc, -1, env); if (i < argc) { /* script usage */ sexp_context_tracep(ctx) = 1; check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env)); tmp = sexp_intern(ctx, "main", -1); tmp = sexp_env_ref(env, tmp, SEXP_FALSE); if (sexp_procedurep(tmp)) { args = sexp_list1(ctx, args); check_exception(ctx, sexp_apply(ctx, tmp, args)); } } else { repl(ctx, env); } } sexp_gc_release2(ctx); sexp_destroy_context(ctx); }