First try to make it js. equal?-hash is the current missing piece

configure

@@ -71,7 +71,7 @@ if [ -f MANIFEST ] ; then
 else
   readonly gerbil_version="$(git describe --tags --always)"
 fi
-readonly gerbil_targets=""
+readonly gerbil_targets="js"
 readonly default_gambit_tag=09335d95cab6931791c0a8497cbe915053ff8af3
 readonly default_gambit_config="--enable-targets=${gerbil_targets} --enable-single-host --enable-dynamic-clib --enable-default-runtime-options=tE8,f8,-8 --enable-trust-c-tco"
 prefix="/opt/gerbil"
@@ -234,7 +234,8 @@ if [ ! -f MANIFEST -o ! -f src/gambit/configure ] ; then
 fi
 
 gambit_config="--prefix=${gerbil_prefix} --enable-march=${gambit_march} ${gambit_shared} ${gambit_config}"
-(export LDFLAGS="$LDFLAGS"; export CFLAGS="$CFLAGS"; cd src/gambit && ./configure $gambit_config ) || die
+
+(export LDFLAGS="$LDFLAGS"; export CFLAGS="$CFLAGS"; cd src/gambit && ./configure $gambit_config --enable-default-compile-options='(compactness 9)') || die
 
 if [ -n "$gambit_stamp_version" ] ; then
   sed -i -e "s/^stamp:/stamp-orig:/" src/gambit/include/makefile

src/bootstrap.sh

@@ -10,4 +10,4 @@ fi
 rm -rf bootstrap/*
 mkdir -p bootstrap/gerbil
 cp gerbil/builtin.ssxi.ss gerbil/builtin-inline-rules.ssxi.ss bootstrap/gerbil
-gxc $gerbil_opt -d bootstrap -s -S gerbil/core/{runtime,expander,sugar,mop,macro-object,match,more-sugar,more-syntax-sugar,module-sugar,contract}.ss gerbil/core.ss gerbil/runtime/{gambit,util,table,control,system,c3,mop,mop-system-classes,error,interface,hash,thread,syntax,eval,repl,loader,init}.ss gerbil/runtime.ss gerbil/expander/{common,stx,core,top,module,compile,root,stxcase,init}.ss gerbil/expander.ss gerbil/compiler/{base,method,compile,optimize-base,optimize-xform,optimize-top,optimize-spec,optimize-ann,optimize-call,optimize,driver,ssxi}.ss gerbil/compiler.ss gerbil/gambit.ss
+gxc $gerbil_opt -gsc-flag -debug-location -d bootstrap -s -S gerbil/core/{runtime,expander,sugar,mop,macro-object,match,more-sugar,more-syntax-sugar,module-sugar,contract}.ss gerbil/core.ss gerbil/runtime/{gambit,util,table,control,system,c3,mop,mop-system-classes,error,interface,hash,thread,syntax,eval,repl,loader,init}.ss gerbil/runtime.ss gerbil/expander/{common,stx,core,top,module,compile,root,stxcase,init}.ss gerbil/expander.ss gerbil/compiler/{base,method,compile,optimize-base,optimize-xform,optimize-top,optimize-spec,optimize-ann,optimize-call,optimize,driver,ssxi}.ss gerbil/compiler.ss gerbil/gambit.ss

src/build.sh

@@ -108,6 +108,8 @@ build_prepare() {
   feedback_mid "Preparing build"
   feedback_low "preparing ${GERBIL_STAGE0}"
   target_setup "${GERBIL_STAGE0}"
+  feedback_low "preparing ${GERBIL_STAGE0}/js"
+  target_setup "${GERBIL_STAGE0}"/js
   feedback_low "preparing ${GERBIL_BUILD_PREFIX}"
   target_setup "${GERBIL_BUILD_PREFIX}"
 }
@@ -118,9 +120,14 @@ build_gambit() {
   (cd gambit && rm -rf boot gsc-boot) || die
   (cd gambit && m="make -j ${GERBIL_BUILD_CORES:-1}" && $m bootstrap && $m from-scratch)
 
-  feedback_mid "Installing Gambit to ${GERBIL_BUILD_PREFIX}"
+  cp_gambit
+
+ }
+
+cp_gambit() {
+ feedback_mid "Installing Gambit to ${GERBIL_BUILD_PREFIX}"
   cp -v gambit/gsi/gsi "${GERBIL_STAGE0}/bin"
-  cp -v gambit/gsc/gsc gambit/bin/gambuild-C "${GERBIL_BUILD_PREFIX}/bin"
+  cp -v gambit/gsc/gsc gambit/bin/gambuild-js gambit/bin/gambuild-C "${GERBIL_BUILD_PREFIX}/bin"
   cp -v gambit/include/gambit.h gambit/include/gambit-not*.h "${GERBIL_BUILD_PREFIX}/include"
   cp -v gambit/lib/*\#.scm "${GERBIL_BUILD_PREFIX}/lib"
   cp -v gambit/lib/_define-syntax.scm "${GERBIL_BUILD_PREFIX}/lib"
@@ -165,12 +172,13 @@ finalize_stage1 () {
   (cd "${target_bin}" && ln -sf gerbil gxc)
 }
 
-build_stage0 () {
-  local target_bin="${GERBIL_STAGE0}/bin"
-  local target_lib="${GERBIL_STAGE0}/lib"
+build_stage0_target() {
+  local GERBIL_STAGE0_P="$1"
+  local target_bin="${GERBIL_STAGE0_P}/bin"
+  local target_lib="${GERBIL_STAGE0_P}/lib"
 
   ## feedback
-  feedback_low "Building Gerbil bootstrap"
+  feedback_low "Building Gerbil bootstrap for $2"
 
   ## gerbil bootstrap
   feedback_mid "preparing bootstrap"
@@ -188,6 +196,23 @@ build_stage0 () {
   finalize_stage0 "${target_lib}" "${target_bin}"
 }
 
+build_stage0_C () {
+    build_stage0_target "$GERBIL_STAGE0" C
+}
+
+build_stage0_js () {
+    GERBIL_TARGET=js
+    export GERBIL_TARGET
+    build_stage0_target "$GERBIL_STAGE0"/js js
+    unset GERBIL_TARGET
+}
+
+build_stage0 () {
+    build_stage0_C
+    build_stage0_js
+}
+
+
 build_stage1 () {
   ## constants
   local target_bin="${GERBIL_BUILD_PREFIX}/bin"
@@ -303,11 +328,20 @@ else
       "gambit")
          build_gambit || die
          ;;
+      "cp_gambit")
+         cp_gambit || die
+         ;;
       "boot-gxi")
          build_boot_gxi || die
          ;;
        "stage0")
-         build_stage0 || die
+        build_stage0 || die
+        ;;
+       "stage0_js")
+        build_stage0_js || die
+         ;;
+       "clean_stage0")
+         clean_stage0 || die
          ;;
        "stage1")
          build_stage1 || die

src/build/build0.scm

@@ -1,6 +1,12 @@
 (load "build/build0-lib.scm")
 
+(define TARGET (getenv "GERBIL_TARGET" "C"))
+
+(display "TARGET:") (display TARGET) (display "\n")
+
 (parallel-build
  (call-with-input-file ".build.stage0" read-all-as-lines)
- (compiler '("-e" "(include \"~~lib/_gambit#.scm\")"))
+ (compiler `("-target" ,TARGET
+	     "-debug-location" "-track-scheme"
+	     "-e" "(include \"~~lib/_gambit#.scm\")"))
  false)

src/gerbil/compiler/compile.ss

@@ -531,7 +531,7 @@ namespace: gxc
 
 (def (generate-runtime-values-count var)
   (def (generate-inline)
-    ['if ['##values? var] ['##vector-length var] 1])
+    ['if ['##values? var] ['##values-length var] 1])
 
   ;; see gambit#422
   (with-inline-unsafe-primitives (generate-inline)
@@ -542,8 +542,8 @@ namespace: gxc
 (def (generate-runtime-values-ref var i rest)
   (def (generate-inline)
     (if (and (fx= i 0) (not (stx-pair? rest)))
-      ['if ['##values? var] ['##vector-ref var 0] var]
-      ['##vector-ref var i]))
+      ['if ['##values? var] ['##values-ref var 0] var]
+      ['##values-ref var i]))
 
   ;; see gambit#422
   (with-inline-unsafe-primitives (generate-inline)
@@ -555,22 +555,22 @@ namespace: gxc
   (cond
    ((fx= i 0)
     (with-inline-unsafe-primitives
-        ['if ['##values? var] ['##vector->list var] ['list var]]
+        ['if ['##values? var] ['##values->list var] ['list var]]
       ['let []
         '(declare (not safe))
-        ['if ['##values? var] ['##vector->list var] ['list var]]]))
+        ['if ['##values? var] ['##values->list var] ['list var]]]))
    ((fx= i 1)
     (with-inline-unsafe-primitives
-        ['if ['##values? var] ['##cdr ['##vector->list var]] '(quote ())]
+        ['if ['##values? var] ['##cdr ['##values->list var]] '(quote ())]
       ['let []
         '(declare (not safe))
-        ['if ['##values? var] ['##cdr ['##vector->list var]] '(quote ())]]))
+        ['if ['##values? var] ['##cdr ['##values->list var]] '(quote ())]]))
    (else
     (with-inline-unsafe-primitives
-        ['##list-tail ['##vector->list var] i]
+        ['##list-tail ['##values->list var] i]
       ['let []
         '(declare (not safe))
-        ['##list-tail ['##vector->list var] i]]))))
+        ['##list-tail ['##values->list var] i]]))))
 
 (def (generate-runtime-lambda% self stx)
   (ast-case stx ()

src/gerbil/runtime/hash.ss

@@ -8,6 +8,9 @@ namespace: #f
 (import "gambit" "util" "table" "mop" "error" "interface")
 (export #t)
 
+(begin-foreign
+  (##include "~~lib/_system#.scm"))
+
 (defclass (UnboundKeyError Error) ()
   constructor: :init!)
 

src/gerbil/runtime/mop.ss

@@ -8,6 +8,7 @@ namespace: #f
 (export #t)
 (import "gambit" "util" "table" "c3")
 
+(provide compilation-target-js)
 ;; Gambit structure rtd [runtime type descriptor]
 ;;  (define-type type
 ;;    (id      unprintable: equality-test:)
@@ -1191,7 +1192,59 @@ namespace: #f
         (loop (##type-super super) (cons super hierarchy))))))))
 
 ;; the class-of operator
-(def (class-of obj) => :class
+(def (universal-class-of obj) => :class
+  (declare (not interrupts-enabled))
+  (:- 
+   (cond
+    ;; Structs
+    ((##structure? obj)
+     (let (klass (##structure-type obj))
+       (if (class-type? klass)
+	 klass
+	 (__shadow-class klass))))
+    ;; Values
+    ((##values? obj) (__system-class 'values))
+    ;; Boxes
+    ((##box? obj)     (__system-class 'box))
+    ((char? obj)      (__system-class 'char))
+    ((vector? obj)    (__system-class 'vector))
+    ((##ratnum? obj)  (__system-class 'ratnum))
+    ((##fixnum? obj)  (__system-class 'fixnum))
+    ((##pair? obj)    (__system-class 'pair))
+    ((##cpxnum? obj)  (__system-class 'cpxnum))
+    ((##symbol? obj)  (__system-class 'symbol))
+    ((##keyword? obj) (__system-class 'keyword))
+    ((##frame? obj)   (__system-class 'frame))
+    ((##continuation? obj)
+     (__system-class 'continuation))
+    ((##promise? obj) (__system-class 'promise))
+    ((##weak? obj)    (__system-class 'weak))
+    ((##procedure? obj)
+     (__system-class 'procedure))
+    ((##return? obj)  (__system-class 'return))
+    ((##foreign? obj) (__system-class 'foreign))
+    ((##string? obj)  (__system-class 'string))
+    ((##s8vector? obj) (__system-class 's8vector))
+    ((##u8vector? obj) (__system-class 'u8vector))
+    ((##s16vector? obj) (__system-class 's16vector))
+    ((##u16vector? obj) (__system-class 'u16vector))
+    ((##s32vector? obj) (__system-class 's32vector))
+    ((##u32vector? obj) (__system-class 'u32vector))
+    ((##s64vector? obj) (__system-class 's64vector))
+    ((##u64vector? obj)  (__system-class 'u64vector))
+    ((##flonum? obj)  (__system-class 'flonum))
+    ((##bignum? obj)  (__system-class 'bignum))
+    ((eq? obj '())    (__system-class 'null))
+    ((eq? obj #f)     (__system-class 'boolean))
+    ((eq? obj #t)     (__system-class 'boolean))
+    ((eq? obj #!void) (__system-class 'void))
+    ((eq? obj #!eof)  (__system-class 'eof))
+    (else
+     (__system-class 'special)))
+
+      :class))
+
+(def (C-class-of obj) => :class
   (declare (not interrupts-enabled))
   (:- (let (t (##type obj))
         (cond
@@ -1225,6 +1278,10 @@ namespace: #f
             (__system-class 'special))))))
       :class))
 
+(def class-of (cond-expand 
+		(compilation-target-js universal-class-of)
+		(else C-class-of)))
+
 (def __subtype-id (make-vector 32 #f))
 
 (defrules defsubtype ()