add load-compiled-from-port and Sregister_boot_file_fd

original commit: 0865b4637fce16079cb9ad8d3eb6211f1bf08c9f

LOG

@@ -788,3 +788,7 @@
 - fix bounds checking with an immediate index on immutable vectors,
   fxvectors, strings, and bytevectors
     cpnanopass.ss, 5_5.ms, 5_6.ms, bytevector.ms
+- 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

@@ -545,17 +545,18 @@ 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;
   char *expandedpath;
   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();
@@ -563,11 +564,16 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp;
 
     path = name;
 
-    expandedpath = S_malloc_pathname(path);
-    file = gzopen(expandedpath, "rb");
-    /* assumption (seemingly true based on a glance at the source code):
-       gzopen doesn't squirrel away a pointer to expandedpath. */
-    free(expandedpath);
+    if (fd != -1) {
+      file = gzdopen(fd, "rb");
+    } else {
+      expandedpath = S_malloc_pathname(path);
+      file = gzopen(expandedpath, "rb");
+      /* 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);
@@ -725,7 +731,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 ");
@@ -979,20 +985,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) {
@@ -1047,7 +1061,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

@@ -2720,6 +2720,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}
@@ -2752,9 +2753,11 @@ for subsequently registered boot files.
 
 \scheme{Sregister_boot_file} searches for
 the named boot file and
-register it for loading.
-The file is opened but not loaded until the heap is built via
-\scheme{Sbuild_heap}.
+register it for loading, while \scheme{Sregister_boot_file_fd}
+provides a specific boot file as a file descriptor.
+When only a boot file name is provided, the 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,7 +184,7 @@
 
 (let ()
   (define do-load-binary
-    (lambda (who fn ip situation for-import?)
+    (lambda (who fn ip situation for-import? results?)
       (module (Lexpand? visit-stuff? visit-stuff-inner revisit-stuff? revisit-stuff-inner
                recompile-info? library/ct-info? library/rt-info? program-info?)
         (import (nanopass))
@@ -193,8 +193,9 @@
       (define unexpected-value!
         (lambda (x)
           ($oops who "unexpected value ~s read from ~a" x fn)))
-      (let loop ()
-        (let ([x (fasl-read ip)])
+      (let loop ([lookahead-x #f])
+        (let* ([x (or lookahead-x (fasl-read ip))]
+               [next-x (and results? (not (eof-object? x)) (fasl-read ip))])
           (define run-inner
             (lambda (x)
               (cond
@@ -210,11 +211,23 @@
                 [(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))])))
           (cond
             [(eof-object? x) (close-port ip)]
-            [(vector? x) (vector-for-each run-outer x) (loop)]
-            [(Lexpand? x) ($interpret-backend x situation for-import? fn) (loop)]
-            [else (run-outer x) (loop)])))))
+            [(vector? x)
+             (cond
+              [(and results? (eof-object? next-x) (fx> (vector-length x) 0)) (run-vector x 0)]
+              [else (vector-for-each run-outer x) (loop next-x)])]
+            [(Lexpand? x) ($interpret-backend x situation for-import? fn) (loop next-x)]
+            [(and results? (eof-object? next-x)) (run-outer x)]
+            [else (run-outer x) (loop next-x)])))))
 
   (define (do-load who fn situation for-import? ksrc)
     (let ([ip ($open-file-input-port who fn)])
@@ -234,7 +247,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))
@@ -246,6 +259,12 @@
                   (set! ip (transcoded-port ip (current-transcoder)))
                   (ksrc ip sfd ($make-read ip sfd fp)))))))))
 
+  (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

@@ -371,6 +371,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

@@ -1392,6 +1392,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])