Merge branch 'fdstart' of github.com:mflatt/ChezScheme

original commit: d03d4eba23b7d01ee20a48bfcfddc35f34afc70a

LOG

@@ -1000,3 +1000,7 @@
 - add current-generate-id and expand-omit-library-invocations, which can be
   useful for avoiding library recompilation and redundant invocation checks
     syntax.ss, record.ss, primdata.ss, front.ss, misc.ms, system.stex
+- add load-compiled-from-port and Sregister_boot_file_fd for loading modes
+  based on open files instead of paths
+    7.ss, primdata.ss, mkheader.ss, scheme.c
+    7.ms, foreign.stex, system.stex

c/scheme.c

@@ -558,10 +558,11 @@ static boot_desc bd[MAX_BOOT_FILES];
 /* locally defined functions */
 static uptr zget_uptr PROTO((gzFile file, uptr *pn));
 static INT zgetstr PROTO((gzFile file, char *s, iptr max));
-static IBOOL find_boot PROTO((const char *name, const char *ext, IBOOL errorp));
+static IBOOL find_boot PROTO((const char *name, const char *ext, int fd, IBOOL errorp));
 static void load PROTO((ptr tc, iptr n, IBOOL base));
+static void check_boot_file_state PROTO((const char *who));
 
-static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp; {
+static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IBOOL errorp; {
   char pathbuf[PATH_MAX], buf[PATH_MAX];
   uptr n; INT c;
   const char *path;
@@ -572,7 +573,7 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp;
 #endif
   gzFile file;
 
-  if (S_fixedpathp(name)) {
+  if ((fd != -1) || S_fixedpathp(name)) {
     if (strlen(name) >= PATH_MAX) {
       fprintf(stderr, "boot-file path is too long %s\n", name);
       S_abnormal_exit();
@@ -580,6 +581,9 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp;
 
     path = name;
 
+    if (fd != -1) {
+      file = gzdopen(fd, "rb");
+    } else {
 #ifdef WIN32
       expandedpath = S_malloc_wide_pathname(path);
       file = gzopen_w(expandedpath, "rb");
@@ -590,6 +594,8 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp;
       /* assumption (seemingly true based on a glance at the source code):
          gzopen doesn't squirrel away a pointer to expandedpath. */
       free(expandedpath);
+    }
+
     if (!file) {
       if (errorp) {
         fprintf(stderr, "cannot open boot file %s\n", path);
@@ -752,7 +758,7 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp;
           gzclose(file);
           S_abnormal_exit();
         }
-        if (find_boot(buf, ".boot", 0)) break;
+        if (find_boot(buf, ".boot", -1, 0)) break;
         if ((c = gzgetc(file)) == ')') {
           char *sep; char *wastebuf[8];
           fprintf(stderr, "cannot find subordinate boot file ");
@@ -1026,20 +1032,28 @@ extern void Sscheme_init(abnormal_exit) void (*abnormal_exit) PROTO((void)); {
 #endif
 }
 
-extern void Sregister_boot_file(name) const char *name; {
+static void check_boot_file_state(const char *who) {
   switch (current_state) {
     case UNINITIALIZED:
     case DEINITIALIZED:
-      fprintf(stderr, "error (Sregister_boot_file): uninitialized; call Sscheme_init first\n");
+      fprintf(stderr, "error (%s): uninitialized; call Sscheme_init first\n", who);
       if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit();
     case RUNNING:
-      fprintf(stderr, "error (Sregister_boot_file): already running\n");
+      fprintf(stderr, "error (%s): already running\n", who);
       S_abnormal_exit();
     case BOOTING:
       break;
   }
+}
 
-  find_boot(name, "", 1);
+extern void Sregister_boot_file(name) const char *name; {
+  check_boot_file_state("Sregister_boot_file");
+  find_boot(name, "", -1, 1);
+}
+
+extern void Sregister_boot_file_fd(name, fd) const char *name; int fd; {
+  check_boot_file_state("Sregister_boot_file_fd");
+  find_boot(name, "", fd, 1);
 }
 
 extern void Sregister_heap_file(UNUSED const char *path) {
@@ -1094,7 +1108,7 @@ extern void Sbuild_heap(kernel, custom_init) const char *kernel; void (*custom_i
     }
 #endif
 
-    if (!find_boot(name, ".boot", 0)) {
+    if (!find_boot(name, ".boot", -1, 0)) {
       fprintf(stderr, "cannot find compatible %s.boot in search path\n  \"%s%s\"\n",
               name,
               Sschemeheapdirs, Sdefaultheapdirs);

csug/foreign.stex

@@ -2804,6 +2804,7 @@ program.
 \cfunction{void}{Sscheme_init}{void (*\var{abnormal}_\var{exit})(void)}
 \cfunction{void}{Sset_verbose}{int \var{v}}
 \cfunction{void}{Sregister_boot_file}{const char *\var{name}}
+\cfunction{void}{Sregister_boot_file_fd}{const char *\var{name}, int \var{fd}}
 \cfunction{void}{Sbuild_heap}{const char *\var{exec}, void (*\var{custom}_\var{init})(void)}
 \cfunction{void}{Senable_expeditor}{const char *\var{history}_\var{file}}
 \cfunction{void}{Sretain_static_relocation}{void}
@@ -2836,9 +2837,11 @@ for subsequently registered boot files.
 
 \scheme{Sregister_boot_file} searches for
 the named boot file and
-register it for loading.
+register it for loading, while \scheme{Sregister_boot_file_fd}
-The file is opened but not loaded until the heap is built via
+provides a specific boot file as a file descriptor.
-\scheme{Sbuild_heap}.
+When only a boot file name is provided, the file is opened but not loaded until the heap is built via
+\scheme{Sbuild_heap}. When a file descriptor is provided, the given file name
+is used only for error reporting.
 For the first boot file registered only, the system also
 searches for the boot files upon which the named file
 depends, either directly or indirectly.

csug/system.stex

@@ -980,6 +980,24 @@ determines the set of directories searched for source files not identified
 by absolute path names.
 
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{load-compiled-from-port}{\categoryprocedure}{(load-compiled-from-port \var{input-port})}
+\returns result of the last compiled expression
+\listlibraries
+\endentryheader
+
+\noindent
+\scheme{load-compiled-from-port} reads and evaluates the object-code contents
+of \var{input-port} as previously created by functions like \scheme{compile-file},
+\scheme{compile-script}, \scheme{compile-library}, and
+\scheme{compile-to-port}.
+
+The return value is the value of the last expression whose compiled
+form is in \var{input-port}. If \var{input-port} is empty, then the
+result value is unspecified.
+
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{visit}{\categoryprocedure}{(visit \var{path})}

mats/7.ms

@@ -112,6 +112,14 @@
     "6\n")
  )
 
+(mat load-compiled-from-port
+  (begin
+   (define-values (o get) (open-bytevector-output-port))
+   (compile-to-port '((define lcfp1 'worked) 'loaded) o)
+   (equal? 'loaded (load-compiled-from-port (open-bytevector-input-port (get)))))
+  (equal? 'worked lcfp1)
+)
+
 (mat compile-to-file
   (begin
     (delete-file (format "testfile.~s" (machine-type)))

s/7.ss

@@ -184,13 +184,15 @@
 
 (let ()
   (define do-load-binary
-    (lambda (who fn ip situation for-import?)
+    (lambda (who fn ip situation for-import? results?)
       (let ([load-binary (make-load-binary who fn situation for-import?)])
-        (let loop ()
+        (let loop ([lookahead-x #f])
-          (let ([x (fasl-read ip)])
+          (let* ([x (or lookahead-x (fasl-read ip))]
+                 [next-x (and results? (not (eof-object? x)) (fasl-read ip))])
             (cond
              [(eof-object? x) (close-port ip)]
-             [else (load-binary x) (loop)]))))))
+             [(and results? (eof-object? next-x)) (load-binary x)]
+             [else (load-binary x) (loop next-x)]))))))
 
   (define (make-load-binary who fn situation for-import?)
     (module (Lexpand? visit-stuff? visit-stuff-inner revisit-stuff? revisit-stuff-inner
@@ -216,9 +218,17 @@
          [(revisit-stuff? x) (when (memq situation '(load revisit)) (run-inner (revisit-stuff-inner x)))]
          [(visit-stuff? x) (when (memq situation '(load visit)) (run-inner (visit-stuff-inner x)))]
          [else (run-inner x)])))
+    (define run-vector
+      (lambda (x i)
+        (cond
+         [(fx= (fx+ i 1) (vector-length x))
+          (run-outer (vector-ref x i))]
+         [else
+          (run-outer (vector-ref x i))
+          (run-vector x (fx+ i 1))])))
     (lambda (x)
       (cond
-       [(vector? x) (vector-for-each run-outer x)]
+       [(vector? x) (run-vector x 0)]
        [(Lexpand? x) ($interpret-backend x situation for-import? fn)]
        [else (run-outer x)])))
 
@@ -240,7 +250,7 @@
                         (begin (set-port-position! ip start-pos) 0)))])
           (port-file-compressed! ip)
           (if ($compiled-file-header? ip)
-              (do-load-binary who fn ip situation for-import?)
+              (do-load-binary who fn ip situation for-import? #f)
               (begin
                 (when ($port-flags-set? ip (constant port-flag-compressed))
                   ($oops who "missing header for compiled file ~s" fn))
@@ -256,6 +266,12 @@
     (lambda (fn situation for-import?)
       (make-load-binary '$make-load-binary fn situation for-import?)))
 
+  (set-who! load-compiled-from-port
+    (lambda (ip)
+      (unless (and (input-port? ip) (binary-port? ip))
+        ($oops who "~s is not a binary input port" ip))
+      (do-load-binary who (port-name ip) ip 'load #f #t)))
+
   (set-who! load-program
     (rec load-program
       (case-lambda

s/mkheader.ss

@@ -372,6 +372,7 @@
         (export "void" "Sset_verbose" "(int)")
         (export "void" "Sscheme_init" "(void (*)(void))")
         (export "void" "Sregister_boot_file" "(const char *)")
+        (export "void" "Sregister_boot_file_fd" "(const char *, int fd)")
         (export "void" "Sregister_heap_file" "(const char *)")
         (export "void" "Scompact_heap" "(void)")
         (export "void" "Ssave_heap" "(const char *, int)")

s/primdata.ss

@@ -1403,6 +1403,7 @@
   (list-head [sig [(sub-ptr sub-index) -> (ptr)]] [flags alloc])
   (literal-identifier=? [sig [(identifier identifier) -> (boolean)]] [flags pure mifoldable discard cp03])
   (load [sig [(pathname) (pathname procedure) -> (void)]] [flags true ieee r5rs])
+  (load-compiled-from-port [sig [(ptr) -> (ptr ...)]] [flags])
   (load-library [sig [(pathname) (pathname procedure) -> (void)]] [flags true])
   (profile-load-data [sig [(pathname) -> (void)]] [flags true])
   (load-program [sig [(pathname) (pathname procedure) -> (void)]] [flags true])