chez-openbsd/c/main.c

/* main.c
 * Copyright 1984-2017 Cisco Systems, Inc.
 * 
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 * 
 * http://www.apache.org/licenses/LICENSE-2.0
 * 
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 */

#include <stdlib.h>
#include <string.h>
#include <stdio.h>
#include "scheme.h"
#include "config.h"

/****
  CUSTOM_INIT may be defined as a function with the signature shown to
  perform boot-time initialization, e.g., registering foreign symbols.
****/
#ifndef CUSTOM_INIT
#define CUSTOM_INIT ((void (*)(void))0)
#endif /* CUSTOM_INIT */

/****
  ABNORMAL_EXIT may be defined as a function with the signature shown to
  take some action, such as printing a special error message or performing
  a nonlocal exit with longjmp, when the Scheme system exits abnormally,
  i.e., when an unrecoverable error occurs.  If left null, the default
  is to call exit(1).
****/
#ifndef ABNORMAL_EXIT
#define ABNORMAL_EXIT ((void (*)(void))0)
#endif /* ABNORMAL_EXIT */

#ifndef SCHEME_SCRIPT
#define SCHEME_SCRIPT "scheme-script"
#endif

static const char *path_last(const char *p) {
  const char *s;
#ifdef WIN32
  char c;
  if ((c = *p) >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')
    if (*(p + 1) == ':')
      p += 2;

  for (s = p; *s != 0; s += 1)
    if ((c = *s) == '/' || c == '\\') p = ++s;
#else /* WIN32 */
  for (s = p; *s != 0; s += 1) if (*s == '/') p = ++s;
#endif /* WIN32 */
  return p;
}

#if defined(WIN32) && !defined(__MINGW32__)
#define GETENV Sgetenv
#define GETENV_FREE free
int wmain(int argc, wchar_t* wargv[], wchar_t* wenvp[]) {
  const char** argv = (char**)malloc((argc + 1) * sizeof(char*));
  int i;
  for (i = 0; i < argc; i++) {
    wchar_t* warg = wargv[i];
    if (NULL == (argv[i] = Swide_to_utf8(warg))) {
      fprintf_s(stderr, "Invalid argument: %S\n", warg);
      exit(1);
    }
  }
  argv[argc] = NULL;
#else /* WIN32 */
#define GETENV getenv
#define GETENV_FREE (void)
int main(int argc, const char *argv[]) {
#endif /* WIN32 */
  int n, new_argc = 1;
#ifdef SAVEDHEAPS
  int compact = 1, savefile_level = 0;
  const char *savefile = (char *)0;
#endif /* SAVEDHEAPS */
  const char *execpath = argv[0];
  const char *scriptfile = (char *)0;
  const char *programfile = (char *)0;
  const char *libdirs = (char *)0;
  const char *libexts = (char *)0;
  int status;
  const char *arg;
  int quiet = 0;
  int eoc = 0;
  int optlevel = 0;
  int debug_on_exception = 0;
  int import_notify = 0;
  int compile_imported_libraries = 0;
#ifdef FEATURE_EXPEDITOR
  int expeditor_enable = 1;
  const char *expeditor_history_file = "";  /* use "" for default location */
#endif /* FEATURE_EXPEDITOR */

  if (strcmp(Skernel_version(), VERSION) != 0) {
    (void) fprintf(stderr, "unexpected shared library version %s for %s version %s\n", Skernel_version(), execpath, VERSION);
    exit(1);
  }

  Sscheme_init(ABNORMAL_EXIT);

  if (strcmp(path_last(execpath), SCHEME_SCRIPT) == 0) {
    if (argc < 2) {
      (void) fprintf(stderr,"%s requires program-path argument\n", execpath);
      exit(1);
    }
    argv[0] = programfile = argv[1];
    n = 1;
    while (++n < argc) argv[new_argc++] = argv[n];
  } else {
   /* process command-line arguments, registering boot and heap files */
    for (n = 1; n < argc; n += 1) {
      arg = argv[n];
      if (strcmp(arg,"--") == 0) {
        while (++n < argc) argv[new_argc++] = argv[n];
      } else if (strcmp(arg,"-b") == 0 || strcmp(arg,"--boot") == 0) {
        if (++n == argc) {
          (void) fprintf(stderr,"%s requires argument\n", arg);
          exit(1);
        }
        Sregister_boot_file(argv[n]);
      } else if (strcmp(arg,"--eedisable") == 0) {
  #ifdef FEATURE_EXPEDITOR
        expeditor_enable = 0;
  #endif /* FEATURE_EXPEDITOR */
      } else if (strcmp(arg,"--eehistory") == 0) {
        if (++n == argc) {
          (void) fprintf(stderr,"%s requires argument\n", arg);
          exit(1);
        }
  #ifdef FEATURE_EXPEDITOR
        if (strcmp(argv[n], "off") == 0)
          expeditor_history_file = (char *)0;
        else
          expeditor_history_file = argv[n];
  #endif /* FEATURE_EXPEDITOR */
      } else if (strcmp(arg,"-q") == 0 || strcmp(arg,"--quiet") == 0) {
        quiet = 1;
      } else if (strcmp(arg,"--retain-static-relocation") == 0) {
        Sretain_static_relocation();
      } else if (strcmp(arg,"--enable-object-counts") == 0) {
        eoc = 1;
#ifdef SAVEDHEAPS
      } else if (strcmp(arg,"-c") == 0 || strcmp(arg,"--compact") == 0) {
        compact = !compact;
      } else if (strcmp(arg,"-h") == 0 || strcmp(arg,"--heap") == 0) {
        if (++n == argc) {
          (void) fprintf(stderr,"%s requires argument\n", arg);
          exit(1);
        }
        Sregister_heap_file(argv[n]);
      } else if (strncmp(arg,"-s",2) == 0 &&
                 (savefile_level = -2,
                  *(arg+2) == 0 ||
                  *(arg+3) == 0 &&
                  ((savefile_level = *(arg+2) - '+' - 1) == -1 ||
                    (savefile_level = *(arg+2) - '0') >= 0 &&
                     savefile_level <= 9)) ||
                 strncmp(arg,"--saveheap",10) == 0 &&
                 (savefile_level = -2,
                  *(arg+10) == 0 ||
                  *(arg+11) == 0 &&
                  ((savefile_level = *(arg+2) - '+' - 1) == -1 ||
                    (savefile_level = *(arg+10) - '0') >= 0 &&
                     savefile_level <= 9))) {
        if (++n == argc) {
          (void) fprintf(stderr,"%s requires argument\n", arg);
          exit(1);
        }
        savefile = argv[n];
#else /* SAVEDHEAPS */
      } else if (strcmp(arg,"-c") == 0 || strcmp(arg,"--compact") == 0) {
        fprintf(stderr, "-c and --compact options are not presently supported\n");
        exit(1);
      } else if (strcmp(arg,"-h") == 0 || strcmp(arg,"--heap") == 0) {
        fprintf(stderr, "-h and --heap options are not presently supported\n");
        exit(1);
      } else if (strncmp(arg,"-s",2) == 0 || strncmp(arg,"--saveheap",10) == 0) {
        fprintf(stderr, "-s and --saveheap options are not presently supported\n");
        exit(1);
#endif /* SAVEDHEAPS */
      } else if (strcmp(arg,"--script") == 0) {
        if (++n == argc) {
          (void) fprintf(stderr,"%s requires argument\n", arg);
          exit(1);
        }
        scriptfile = argv[n];
        while (++n < argc) argv[new_argc++] = argv[n];
      } else if (strcmp(arg,"--optimize-level") == 0) {
        const char *nextarg;
        if (++n == argc) {
          (void) fprintf(stderr,"%s requires argument\n", arg);
          exit(1);
        }
        nextarg = argv[n];
        if (strcmp(nextarg,"0") == 0)
          optlevel = 0;
        else if (strcmp(nextarg,"1") == 0)
          optlevel = 1;
        else if (strcmp(nextarg,"2") == 0)
          optlevel = 2;
        else if (strcmp(nextarg,"3") == 0)
          optlevel = 3;
        else {
          (void) fprintf(stderr,"invalid optimize-level %s\n", nextarg);
          exit(1);
        }
      } else if (strcmp(arg,"--debug-on-exception") == 0) {
        debug_on_exception = 1;
      } else if (strcmp(arg,"--import-notify") == 0) {
        import_notify = 1;
      } else if (strcmp(arg,"--libexts") == 0) {
        if (++n == argc) {
          (void) fprintf(stderr,"%s requires argument\n", arg);
          exit(1);
        }
        libexts = argv[n];
      } else if (strcmp(arg,"--libdirs") == 0) {
        if (++n == argc) {
          (void) fprintf(stderr,"%s requires argument\n", arg);
          exit(1);
        }
        libdirs = argv[n];
      } else if (strcmp(arg,"--compile-imported-libraries") == 0) {
        compile_imported_libraries = 1;
      } else if (strcmp(arg,"--program") == 0) {
        if (++n == argc) {
          (void) fprintf(stderr,"%s requires argument\n", arg);
          exit(1);
        }
        programfile = argv[n];
        while (++n < argc) argv[new_argc++] = argv[n];
      } else if (strcmp(arg,"--help") == 0) {
        fprintf(stderr,"usage: %s [options and files]\n", execpath);
        fprintf(stderr,"options:\n");
        fprintf(stderr,"  -q, --quiet                             suppress greeting and prompt\n");
        fprintf(stderr,"  --script <path>                         run as shell script\n");
        fprintf(stderr,"  --program <path>                        run rnrs program as shell script\n");
#ifdef WIN32
#define sep ";"
#else
#define sep ":"
#endif
        fprintf(stderr,"  --libdirs <dir>%s...                     set library directories\n", sep);
        fprintf(stderr,"  --libexts <ext>%s...                     set library extensions\n", sep);
        fprintf(stderr,"  --compile-imported-libraries            compile libraries before loading\n");
        fprintf(stderr,"  --import-notify                         enable import search messages\n");
        fprintf(stderr,"  --optimize-level <0 | 1 | 2 | 3>        set optimize-level\n");
        fprintf(stderr,"  --debug-on-exception                    on uncaught exception, call debug\n");
        fprintf(stderr,"  --eedisable                             disable expression editor\n");
        fprintf(stderr,"  --eehistory <off | path>                expression-editor history file\n");
        fprintf(stderr,"  --enable-object-counts                  have collector maintain object counts\n");
        fprintf(stderr,"  --retain-static-relocation              keep reloc info for compute-size, etc.\n");
        fprintf(stderr,"  -b <path>, --boot <path>                load boot file\n");
//        fprintf(stderr,"  -c, --compact                           toggle compaction flag\n");
//        fprintf(stderr,"  -h <path>, --heap <path>                load heap file\n");
//        fprintf(stderr,"  -s[<n>] <path>, --saveheap[<n>] <path>  save heap file\n");
        fprintf(stderr,"  --verbose                               trace boot/heap search process\n");
        fprintf(stderr,"  --version                               print version and exit\n");
        fprintf(stderr,"  --help                                  print help and exit\n");
        fprintf(stderr,"  --                                      pass through remaining args\n");
        exit(0);
      } else if (strcmp(arg,"--verbose") == 0) {
        Sset_verbose(1);     
      } else if (strcmp(arg,"--version") == 0) {
        fprintf(stderr,"%s\n", VERSION);
        exit(0);
      } else {
        argv[new_argc++] = arg;
      }
    }
  }

 /* must call Sbuild_heap after registering boot and heap files.
  * Sbuild_heap() completes the initialization of the Scheme system
  * and loads the boot or heap files.  If no boot or heap files have
  * been registered, the first argument to Sbuild_heap must be a
  * non-null path string; in this case, Sbuild_heap looks for
  * a heap or boot file named <name>.boot, where <name> is the last
  * component of the path.  If no heap files are loaded and
  * CUSTOM_INIT is non-null, Sbuild_heap calls CUSTOM_INIT just
  * prior to loading the boot file(s). */
  Sbuild_heap(execpath, CUSTOM_INIT);

#define CALL0(who) Scall0(Stop_level_value(Sstring_to_symbol(who)))
#define CALL1(who, arg) Scall1(Stop_level_value(Sstring_to_symbol(who)), arg)
#ifdef FunCRepl
  {
    ptr p;

    for (;;) {
        CALL1("display", Sstring("* "));
        p = CALL0("read");
        if (Seof_objectp(p)) break;
        p = CALL1("eval", p);
        if (p != Svoid) CALL1("pretty-print", p);
    }
    CALL0("newline");
    status = 0;
  }
#else /* FunCRepl */
  if (quiet) {
    CALL1("suppress-greeting", Strue);
    CALL1("waiter-prompt-string", Sstring(""));
  }
  if (eoc) {
    CALL1("enable-object-counts", Strue);
  }
  if (optlevel != 0) {
    CALL1("optimize-level", Sinteger(optlevel));
  }
  if (debug_on_exception != 0) {
    CALL1("debug-on-exception", Strue);
  }
  if (import_notify != 0) {
    CALL1("import-notify", Strue);
  }
  if (libdirs == 0) {
    char *cslibdirs = GETENV("CHEZSCHEMELIBDIRS");
    if (cslibdirs != 0) {
      CALL1("library-directories", Sstring_utf8(cslibdirs, -1));
      GETENV_FREE(cslibdirs);
    }
  } else {
    CALL1("library-directories", Sstring_utf8(libdirs, -1));
  }
  if (libexts == 0) {
    char *cslibexts = GETENV("CHEZSCHEMELIBEXTS");
    if (cslibexts != 0) {
      CALL1("library-extensions", Sstring_utf8(cslibexts, -1));
      GETENV_FREE(cslibexts);
    }
  } else {
    CALL1("library-extensions", Sstring_utf8(libexts, -1));
  }
  if (compile_imported_libraries != 0) {
    CALL1("compile-imported-libraries", Strue);
  }
#ifdef FEATURE_EXPEDITOR
 /* Senable_expeditor must be called before Scheme_start/Scheme_script (if at all) */
  if (!quiet && expeditor_enable) Senable_expeditor(expeditor_history_file);
#endif /* FEATURE_EXPEDITOR */

  if (scriptfile != (char *)0)
   /* Sscheme_script invokes the value of the scheme-script parameter */
    status = Sscheme_script(scriptfile, new_argc, argv);
  else if (programfile != (char *)0)
   /* Sscheme_program invokes the value of the scheme-program parameter */
    status = Sscheme_program(programfile, new_argc, argv);
  else {
   /* Sscheme_start invokes the value of the scheme-start parameter */
    status = Sscheme_start(new_argc, argv);
  }
#endif /* FunCRepl */

#ifdef SAVEDHEAPS
  if (status == 0 && savefile != (char *)0) {
      if (compact) Scompact_heap();
      Ssave_heap(savefile, savefile_level);
  }
#endif /* SAVEDHEAPS */

 /* must call Scheme_deinit after saving the heap and before exiting */
  Sscheme_deinit();

  exit(status);
}