Universal backend: add --enable-targets=... configure option

INSTALL.txt

@@ -222,6 +222,7 @@ The configure options which are specific to the Gambit system are:
                           module search order (default is ~~lib,~~userlib)
   --enable-module-whitelist=...
                           module whitelist (default is github.com/gambit)
+  --enable-targets=...    targets to build in addition to C
   --enable-ansi-c         link only with ANSI C libraries
   --enable-symlinks       use symbolic links for installed files not in the
                           Gambit central installation directory

configure

@@ -978,6 +978,7 @@ enable_path_encoding
 enable_module_search_order
 enable_module_whitelist
 enable_default_runtime_options
+enable_targets
 enable_shared
 enable_ansi_c
 enable_symlinks
@@ -1698,6 +1699,7 @@ Optional Features:
                           Module whitelist (default is github.com/gambit)
   --enable-default-runtime-options=...
                           Default runtime options (default is none)
+  --enable-targets=...    Targets to build in addition to C (default is none)
   --enable-shared         build the Scheme runtime system as a shared library
                           (default is NO)
   --enable-ansi-c         link only with ANSI C libraries (default is NO)
@@ -3077,8 +3079,6 @@ fi
 
 RTLIB_COND_EXPAND_FEATURES=""
 
-BUILD_TARGETS="C"
-
 userlibdir="~/.gambit_userlib"
 instlibdir="~~userlib"
 
@@ -5181,6 +5181,30 @@ _ACEOF
 
 fi
 
+###############################################################################
+#
+# Determine targets to build.
+
+# Check whether --enable-targets was given.
+if test "${enable_targets+set}" = set; then :
+  enableval=$enable_targets; ENABLE_TARGETS=$enableval
+else
+  ENABLE_TARGETS=
+fi
+
+
+BUILD_TARGETS="C"
+
+if test "$ENABLE_TARGETS" != ""; then
+  for t in `echo "$ENABLE_TARGETS" | sed -e 's/,/ /g'`; do
+    if test "$t" != "C"; then
+      BUILD_TARGETS="$BUILD_TARGETS $t"
+    fi
+  done
+fi
+
+echo BUILD_TARGETS="$BUILD_TARGETS"
+
 ###############################################################################
 #
 # Check the size of the type "void*".  On many systems it is the same

configure.ac

@@ -66,8 +66,6 @@ fi
 
 RTLIB_COND_EXPAND_FEATURES=""
 
-BUILD_TARGETS="C"
-
 userlibdir="~/.gambit_userlib"
 instlibdir="~~userlib"
 
@@ -655,6 +653,28 @@ if test "$DEFAULT_RUNTIME_OPTIONS" != ""; then
   AC_DEFINE_UNQUOTED([___DEFAULT_RUNTIME_OPTIONS],[$DEFAULT_RUNTIME_OPTIONS],[Select default runtime options])
 fi
 
+###############################################################################
+#
+# Determine targets to build.
+
+AC_ARG_ENABLE(targets,
+              AC_HELP_STRING([--enable-targets=...],
+                             [Targets to build in addition to C (default is none)]),
+              ENABLE_TARGETS=$enableval,
+              ENABLE_TARGETS=)
+
+BUILD_TARGETS="C"
+
+if test "$ENABLE_TARGETS" != ""; then
+  for t in `echo "$ENABLE_TARGETS" | sed -e 's/,/ /g'`; do
+    if test "$t" != "C"; then
+      BUILD_TARGETS="$BUILD_TARGETS $t"
+    fi
+  done
+fi
+
+echo BUILD_TARGETS="$BUILD_TARGETS"
+
 ###############################################################################
 #
 # Check the size of the type "void*".  On many systems it is the same

gsc/_gsclib.scm

@@ -395,18 +395,17 @@
     (##delete-file-or-directory build-subdir #t #f)
     (##create-directory build-subdir)
 
-    (let ((target-file
-           (##compile-file-to-target
-            path
+    (let* ((opts
             (##cons (##list 'target target)
                     (##cons
-                      (##list 'linker-name module-object-filename)
-                      options))
-            build-subdir)))
+                     (##list 'linker-name module-object-filename)
+                     options)))
+           (target-file
+            (##compile-file-to-target path opts build-subdir)))
       (and target-file
            (##compile-file
             target-file
-            options
+            opts
             (##path-expand module-object-filename build-subdir)
             #f ;; base
             cc-options

gsc/_t-univ-1.scm

@@ -660,11 +660,14 @@
      (compiler-internal-error
       "univ-emit-call-with-arg-array, unknown target"))))
 
-(define (univ-emit-var-declaration ctx type name #!optional (init #f))
+(define univ-js-define-globals-using-assignment #t) ;; for nodejs scoping rules
+
+(define (univ-emit-var-declaration ctx type name #!optional (init #f) (global? #f))
   (case (target-name (ctx-target ctx))
 
     ((js)
-     (^ "var " name (if init (^ " = " init) (^)) ";\n"))
+     (^ (if (and global? univ-js-define-globals-using-assignment) "" "var ")
+        name (if init (^ " = " init) (^)) ";\n"))
 
     ((python ruby)
      (^ name " = " (or init (^obj #f)) "\n"))

gsc/_t-univ-2.scm

@@ -1224,7 +1224,27 @@
               (index (^local-var 'index))
               (old (^local-var 'old)))
 
-          (define (run mod-descr)
+          (define (run-mod mod-descr)
+            (^ (^assign (gvm-state-sp-use ctx 'wr)
+                        (^int -1))
+
+               (^push (univ-end-of-cont-marker ctx))
+
+               (^assign (^rts-field-use 'r0)
+                        (^rts-jumpable-use 'underflow))
+
+               (^assign (^rts-field-use 'nargs)
+                        (^int 0))
+
+               (^expr-statement
+                (^call-prim
+                 (^rts-method-use 'trampoline)
+                 (^downupcast*
+                  'entrypt
+                  'jumpable
+                  (^vector-ref mod-descr (^int 4)))))))
+
+          (define (load-mod mod-descr)
             (^ (^assign (gvm-state-sp-use ctx 'wr)
                         (^int -1))
 
@@ -1264,9 +1284,14 @@
                                  (^rts-field-use-priv 'module_map)
                                  name))
 
-             (^if (^null? info)
+             (^assign (^rts-field-use-priv 'module_latest_registered)
+                      module_descr)
 
-                  (run module_descr)
+             (^if (^not
+                   (^parens
+                    (^or (^null? info)
+                         (^= (^rts-field-use-priv 'module_count)
+                             (^array-length (^rts-field-use-priv 'module_table))))))
 
                   (^ (^var-declaration
                       'int
@@ -1312,9 +1337,10 @@
                                                (^- (^vector-length temp)
                                                    (^int 1))))
 
-                                     (run (^array-index
-                                           (^rts-field-use-priv 'module_table)
-                                           (^int 0))))))))))))))
+                                     (run-mod
+                                      (^array-index
+                                       (^rts-field-use-priv 'module_table)
+                                       (^int 0))))))))))))))
 
     ;; ((modlinkinfo)
     ;;  (rts-class
@@ -1343,6 +1369,12 @@
       '(array scmobj)
       (^null)))
 
+    ((module_latest_registered)
+     (rts-field
+      'module_latest_registered
+      'scmobj
+      (^null)))
+
     ((heapify_cont)
      (rts-method
       'heapify_cont
@@ -5862,6 +5894,10 @@ EOF
   (univ-glo-use ctx '##vm-main-module-ref 'wr)
   (univ-glo-use ctx '##program-descr 'wr)
 
+  ;; in case these are needed by dynamically loaded code
+  (univ-use-rtlib ctx 'check_procedure)
+  (univ-use-rtlib ctx 'check_procedure_glo)
+
   (^expr-statement
    (^call-prim
     (^rts-method-use-priv 'module_registry_init)

gsc/_t-univ-3.scm

@@ -240,7 +240,7 @@
              ((and (pair? type) (eq? (car type) 'dict))
               (base (^ "map[" (^type (cadr type)) "]" (^type (caddr type)))))
              ((and (pair? type) (eq? (car type) 'fn))
-              (univ-emit-fn-decl ctx #f (caddr type) (cadr type) #f))
+              (univ-emit-fn-decl ctx #f (caddr type) (cadr type)))
              (else
               (case type
                 ((frm)      (decl* '(array scmobj) #f))
@@ -299,7 +299,7 @@
   (define (emit-method m)
     (univ-emit-function-declaration
      ctx
-     #t
+     global?
      (univ-method-name m)
      (univ-method-result-type m)
      (univ-method-params m)
@@ -328,11 +328,11 @@
            (name2 (^prefix name1 public?))
            (name (if global? (^global-var name2) (^local-var name2))))
       (^
-       (univ-emit-var-declaration
-        ctx
+       (^var-declaration
         (univ-field-type f)
         name
-        (univ-field-init f))
+        (univ-field-init f)
+        global?)
        (if (eq? (univ-field-type f) 'jumpable)
            (univ-emit-function-attribs
             ctx
@@ -638,7 +638,7 @@
     (case (target-name (ctx-target ctx))
 
       ((js go)
-       (^ (univ-emit-fn-decl ctx name result-type params body modifier)
+       (^ (univ-emit-fn-decl ctx name result-type params body modifier global?)
           (if (null? attribs)
               (^ "\n")
               (^ "\n"
@@ -658,7 +658,8 @@
                               (^)
                               (univ-emit-function-attribs ctx name attribs))
                           body))
-                  modifier)
+                  modifier
+                  global?)
                  "\n")))
          (cond (prim?
                 decl)
@@ -684,7 +685,7 @@
                 (^assign name decl)))))
 
       ((python)
-       (^ (univ-emit-fn-decl ctx name result-type params body modifier)
+       (^ (univ-emit-fn-decl ctx name result-type params body modifier global?)
           (if (null? attribs)
               (^)
               (^ "\n"
@@ -693,7 +694,7 @@
       ((ruby)
        (^ (if prim?
 
-              (^ (univ-emit-fn-decl ctx name result-type params body modifier)
+              (^ (univ-emit-fn-decl ctx name result-type params body modifier global?)
                  "\n")
 
               (let ((parameters
@@ -710,7 +711,7 @@
           (univ-emit-function-attribs ctx name attribs)))
 
       ((java);;TODO adapt to Java
-       (^ (univ-emit-fn-decl ctx name result-type params body modifier)
+       (^ (univ-emit-fn-decl ctx name result-type params body modifier global?)
           "\n"
           (univ-emit-function-attribs ctx name attribs)))
 
@@ -725,19 +726,28 @@
          params
          body
          #!optional
-         (modifier #f))
+         (modifier #f)
+         (global? #f))
   (case (target-name (ctx-target ctx))
 
     ((js)
-     (let ((formals
-            (univ-separated-list
-             ","
-             (map univ-field-name params))))
-       (^ "function " (or name "") "(" formals ") {"
-          (if body
-              (univ-indent body)
-              "")
-          "}")))
+     (let* ((formals
+             (univ-separated-list
+              ","
+              (map univ-field-name params)))
+            (fn-name
+             (and (or (not global?)
+                      (not univ-js-define-globals-using-assignment))
+                  name))
+            (fn
+             (^ "function " (or fn-name "") "(" formals ") {"
+                (if body
+                    (univ-indent body)
+                    "")
+                "}")))
+       (if (or (not name) fn-name)
+           fn
+           (^var-declaration 'ctrlpt name fn global?))))
 
     ((php)
      (let ((formals
@@ -947,7 +957,7 @@
              ((go)
               (^ (^local-var name) (if type (^ " " (^type type)) "") "\n"))
              (else
-              (univ-emit-var-declaration ctx type (^local-var name) (except-this init)))))))
+              (^var-declaration type (^local-var name) (except-this init)))))))
 
     (define (except-this v)
       (case (target-name (ctx-target ctx))
@@ -1104,7 +1114,9 @@
                     (not (null? instance-fields)))
                 (^ (assign-field-decls (^this) instance-fields)
                    (if constructor (constructor ctx) (^)))
-                (^))))))
+                (^))))
+         #f
+         (not obj)))
 
       (let ((objname name)) ;;(if obj (^member obj name) name)))
         ;;(pp (list obj name objname))

gsc/_univadt.scm

@@ -5,8 +5,8 @@
       `'()
       `(list ,@forms)))
 
-(define-macro (^var-declaration type name #!optional (init #f))
-  `(univ-emit-var-declaration ctx ,type ,name ,init))
+(define-macro (^var-declaration type name #!optional (init #f) (global? #f))
+  `(univ-emit-var-declaration ctx ,type ,name ,init ,global?))
 
 (define-macro (^expr-statement expr)
   `(univ-emit-expr-statement ctx ,expr))

lib/_eval.scm

@@ -5262,7 +5262,7 @@
            (if (##not quiet?)
                (##repl
                 (lambda (first port)
-                  (##write-string "*** WARNING -- Could not find C function: " port)
+                  (##write-string "*** WARNING -- Could not find object file entry point " port)
                   (##write (##vector-ref result 1) port)
                   (##newline port)
                   #t)))