Merge pull request #734 from vyzo/misc-fixes

Miscellaneous fixes

src/gerbil/prelude/gambit/threads.ss

@@ -225,6 +225,22 @@ package: gerbil/gambit
   (thread-thread-group (current-thread)))
 
 (def (with-lock mx proc)
+  (let (handler (current-exception-handler))
+    (with-exception-handler
+     (lambda (e)
+       (with-catch void
+         (lambda ()
+           (mutex-unlock! mx)
+           (handler e)))
+       ;; if the handler returns here the state is inconsistent -- we need to bail
+       (##thread-end-with-uncaught-exception! e))
+     (lambda ()
+       (mutex-lock! mx)
+       (let (result (proc))
+         (mutex-unlock! mx)
+         result)))))
+
+(def (with-dynamic-lock mx proc)
   (dynamic-wind
       (cut mutex-lock! mx)
       proc

src/std/build-std.ss

@@ -3,6 +3,8 @@
 ;;; Inner build file for std, as specially imported and called by ./build.ss for bootstrap reasons
 
 (import ./build-config ./make)
+;; use this when making changes to make and want to rebuild
+;; (import "build-config" "make")
 
 (include "build-spec.ss")
 

src/std/event.ss

@@ -140,7 +140,7 @@
       (mutex-unlock! mx))))
 
 (def (selector-wait-io-condvar sel timeo)
-  (##wait-for-io! sel (if timeo (time->seconds (timeout->abs-timeout timeo)) #t)))
+  (##wait-for-io! sel (if timeo (timeout->abs-timeout->seconds timeo) #t)))
 
 (def (maybe-timeout? obj)
   (or (not obj)
@@ -151,6 +151,11 @@
   (if (time? timeo) timeo
       (seconds->time (+ (##current-time-point) timeo))))
 
+(def (timeout->abs-timeout->seconds timeo)
+  (if (time? timeo)
+    (time->seconds timeo)
+    (+ (##current-time-point) timeo)))
+
 (def (io-condition-variable? obj)
   (and (condition-variable? obj)
        (##foreign? (macro-condvar-name obj))))

src/std/interface.ss

@@ -20,17 +20,17 @@
 (def +interface-prototypes+ (make-hash-table))
 (def +interface-prototypes-mx+ (make-mutex 'interface-constructor))
 
-;; create a new instance of an interface for an object
-(def (new descriptor obj)
+;; cast an object to an interface instance
+(def (cast descriptor obj)
   (declare (not safe))
   (let (klass (interface-descriptor-type descriptor))
     (cond
      ((##structure-direct-instance-of? obj (##type-id klass))
       ;; already an instance of the right interface
       obj)
      ((interface-instance? obj)
-      ;; another interface instance, cast
-      (new descriptor (interface-instance-object obj)))
+      ;; another interface instance, recast
+      (cast descriptor (interface-instance-object obj)))
      (else
       ;; vanilla object, convert to an interface instance
       (let* ((prototype-key (cons (##type-id klass) (type-of obj)))
@@ -48,7 +48,7 @@
                                  (or (method-ref obj method)
                                      (begin
                                        (mutex-unlock! +interface-prototypes-mx+)
-                                       (error "Cannot create interface prototype; missing method" (##type-name klass) method))))
+                                       (error "Cannot create interface instance; missing method" (##type-name klass) method))))
                                (interface-descriptor-methods descriptor)))
                          (prototype
                           (apply ##structure klass #f method-impls)))
@@ -77,12 +77,12 @@
                                   method-impl unchecked-method-impl))
 
   (defmethod {apply-macro-expander interface-info}
-    (with-syntax ((new (quote-syntax new)))
+    (with-syntax ((cast (quote-syntax cast)))
       (lambda (self stx)
         (syntax-case stx ()
           ((_ obj)
            (with-syntax ((descriptor (interface-info-descriptor self)))
-             #'(new descriptor obj))))))))
+             #'(cast descriptor obj))))))))
 
 (defsyntax (interface stx)
   (def symbol<?
@@ -268,11 +268,10 @@
                                               ((out ...) (method-arguments signature)))
                                   #'(begin
                                       (def (method self in ...)
-                                        (unless (predicate self)
-                                          (error "object is not an interface instance" self 'name))
-                                        (let ((obj (##unchecked-structure-ref self 1 klass 'method))
-                                              (f   (##unchecked-structure-ref self offset klass 'method)))
-                                          (f obj out ...)))
+                                        (let (instance (cast descriptor self))
+                                          (let ((obj (##unchecked-structure-ref instance 1 klass 'method))
+                                                (f   (##unchecked-structure-ref instance offset klass 'method)))
+                                            (f obj out ...))))
                                       (def (unchecked-method self in ...)
                                         (declare (not safe))
                                         (let ((obj (##unchecked-structure-ref self 1 klass 'method))
@@ -283,11 +282,10 @@
                                               ((out ...) (method-arguments signature)))
                                   #'(begin
                                       (def (method self . in)
-                                        (unless (predicate self)
-                                          (error "object is not an interface instance" self 'name))
-                                        (let ((obj (##unchecked-structure-ref self 1 klass 'method))
-                                              (f   (##unchecked-structure-ref self offset klass 'method)))
-                                          (apply f obj out ...)))
+                                        (let (instance (cast descriptor self))
+                                          (let ((obj (##unchecked-structure-ref instance 1 klass 'method))
+                                                (f   (##unchecked-structure-ref instance offset klass 'method)))
+                                            (apply f obj out ...))))
                                       (def (unchecked-method self . in)
                                         (declare (not safe))
                                         (let ((obj (##unchecked-structure-ref self 1 klass 'method))
@@ -313,7 +311,7 @@
                           (make-interface-descriptor klass '(method-name ...))))
                     (defmake
                       #'(def (make obj)
-                          (new descriptor obj)))
+                          (cast descriptor obj)))
                     (defpred
                       #'(def (predicate obj)
                           (direct-instance? klass obj)))

src/std/make.ss

@@ -101,7 +101,7 @@ TODO:
       prefix: (prefix_ #f) force: (force? #f)
       optimize: (optimize #t) debug: (debug 'env)
       static: (static #t) static-debug: (static-debug #f)
-      verbose: (verbose #f) build-deps: (build-deps_ #f)
+      verbose: (verbose_ #f) build-deps: (build-deps_ #f)
       parallelize: (parallelize_ #f))
     (def gerbil-path (getenv "GERBIL_PATH" "~/.gerbil"))
     (def srcdir (or srcdir_ (error "srcdir must be specified")))
@@ -111,6 +111,11 @@ TODO:
     (def libdir-prefix (if prefix (path-expand prefix libdir) libdir))
     (def build-deps (path-expand (or build-deps_ "build-deps") srcdir))
     (def parallelize (gerbil-build-cores parallelize))
+    (def verbose
+      (cond
+       (verbose_)
+       ((getenv "GERBIL_BUILD_VERBOSE" #f) => string->number)
+       (else #f)))
     (struct-instance-init!
       self
       srcdir libdir bindir prefix force? optimize debug static static-debug verbose build-deps
@@ -592,6 +597,9 @@ TODO:
   (match spec
     ((? string? modf)
      (gxc-compile modf #f settings #t))
+    ([gxc: modf [submodules: submodules . _] . opts]
+     (for-each (cut build <> settings) submodules)
+     (gxc-compile modf opts settings #t))
     ([gxc: modf . opts]
      (gxc-compile modf opts settings #t))
     ([gsc: modf . opts]
@@ -604,6 +612,7 @@ TODO:
     ([static-exe: modf . opts]
      (compile-static-exe modf opts settings))
     ([static-include: file]
+     (copy-target file settings)
      (copy-static file settings))
     ([copy: file]
      (copy-compiled file settings))
@@ -771,6 +780,17 @@ TODO:
     (delete-file spath))
   (copy-file file spath))
 
+(def (copy-target file settings)
+  (let* ((libdir (settings-libdir-prefix settings))
+         (srcdir (settings-srcdir settings))
+         (spath (path-expand file srcdir))
+         (tpath (path-expand file libdir)))
+    (message "... copy static include to target directory " file)
+    (create-directory* (path-directory tpath))
+    (when (file-exists? tpath)
+      (delete-file tpath))
+    (copy-file spath tpath)))
+
 (def (copy-compiled file settings)
   (def srcpath (source-path file #f settings))
   (def libpath (library-path file #f settings))

src/std/net/httpd-test.ss

@@ -13,7 +13,7 @@
   (test-suite "test :std/net/httpd"
 
     (def server-address
-      "127.0.0.1:9999")
+      "127.0.0.1:19999")
 
     (def server-url
       (string-append "http://" server-address))

src/std/os/socket.ss

@@ -92,6 +92,34 @@
         SO_TIMESTAMP
         SO_USELOOPBACK
 
+        IPPROTO_IP
+        IP_ADD_MEMBERSHIP
+        IP_DROP_MEMBERSHIP
+        IP_ADD_SOURCE_MEMBERSHIP
+        IP_DROP_SOURCE_MEMBERSHIP
+        IP_BLOCK_SOURCE
+        IP_UNBLOCK_SOURCE
+        IP_FREEBIND
+        IPPROTO_IP IP_HDRINCL
+        IP_MTU
+        IP_MTU_DISCOVER
+        IP_MULTICAST_ALL
+        IP_MULTICAST_IF
+        IP_MULTICAST_LOOP
+        IP_MULTICAST_TTL
+        IP_NODEFRAG
+        IP_OPTIONS
+        IP_PKTINFO
+        IP_RECVERR
+        IP_RECVORIGDSTADDR
+        IP_RECVOPTS
+        IP_RECVTOS
+        IP_RECVTTL
+        IP_RETOPTS
+        IP_ROUTER_ALERT
+        IP_TOS
+        IP_TTL
+
         IPPROTO_IPV6
         IPV6_ADDRFORM
         IPV6_ADD_MEMBERSHIP
@@ -365,7 +393,7 @@
       (error "Unknown address family" sa saf)))))
 
 ;;; sockopts
-(def (socket-getsockopt sock level opt . args)
+(def (socket-getsockopt sock level opt)
   (cond
    ((hash-get socket-sockopts level)
     => (lambda (ht)
@@ -374,14 +402,14 @@
            => (match <>
                 ((values getf setf)
                  (if getf
-                   (apply getf sock level opt args)
+                   (getf sock level opt)
                    (error "No getsockopt operation defined for option" level opt)))))
           (else
            (error "Unknown socket option" level opt)))))
    (else
     (error "Unknown socket level" level opt))))
 
-(def (socket-setsockopt sock level opt val . args)
+(def (socket-setsockopt sock level opt val)
   (cond
    ((hash-get socket-sockopts level)
     => (lambda (ht)
@@ -390,7 +418,7 @@
            => (match <>
                 ((values getf setf)
                  (if setf
-                   (apply setf sock level opt val args)
+                   (setf sock level opt val)
                    (error "No setsockopt operation defined for option" level opt)))))
           (else
            (error "Unknown socket option" level opt)))))
@@ -479,8 +507,8 @@
   (match ips
     ((cons maddr ifindex)
      (let (maddr (ip6-address maddr))
-     (check-os-error (_setsockopt_mreq6 (fd-e sock) level opt maddr ifindex)
-       (socket-setsockopt sock level opt ips))))
+       (check-os-error (_setsockopt_mreq6 (fd-e sock) level opt maddr ifindex)
+         (socket-setsockopt sock level opt ips))))
     (else
      (error "Bad argument; expected pair of ip6 addresses" ips))))