adding initial stubber with partial posix and net modules

Makefile

@@ -11,7 +11,9 @@ INCDIR   ?= $(PREFIX)/include/chibi
 MODDIR   ?= $(PREFIX)/share/chibi
 LIBDIR   ?= $(PREFIX)/lib/chibi
 
-DESTDIR ?=
+DESTDIR  ?=
+
+GENSTUBS ?= ./tools/genstubs.scm
 
 ifndef PLATFORM
 ifeq ($(shell uname),Darwin)
@@ -50,7 +52,8 @@ endif
 
 all: chibi-scheme$(EXE) libs
 
-libs: lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO)
+libs: lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \
+	lib/chibi/net$(SO) lib/chibi/posix$(SO)
 
 ifeq ($(USE_BOEHM),1)
 GCLDFLAGS := -lgc
@@ -92,7 +95,10 @@ chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
 chibi-scheme-static$(EXE): main.o eval.o sexp.o
 	$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS)
 
-lib/srfi/%$(SO): lib/srfi/%.c $(INCLUDES)
+%.c: %.stub chibi-scheme$(EXE) $(GENSTUBS)
+	$(GENSTUBS) $<
+
+lib/%$(SO): lib/%.c $(INCLUDES)
 	$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme
 
 clean:

lib/chibi/net.module

@@ -0,0 +1,10 @@
+
+(define-module (chibi net)
+  (export sockaddr? addressinfo? get-address-info socket connect with-net-io
+          address-info-family address-info-socket-type address-info-protocol
+          address-info-address address-info-address-length address-info-next)
+  (import (scheme))
+  (import (chibi posix))
+  (include-shared "net")
+  (include "net.scm"))
+

lib/chibi/net.scm

@@ -0,0 +1,20 @@
+
+(define (with-net-io host service proc)
+  (let lp ((addr (get-address-info host service #f)))
+    (if (not addr)
+        (error "couldn't find address" host service)
+        (let ((sock (socket (address-info-family addr)
+                            (address-info-socket-type addr)
+                            (address-info-protocol addr))))
+          (if (negative? sock)
+              (lp (address-info-next addr))
+              (if (negative?
+                   (connect sock
+                            (address-info-address addr)
+                            (address-info-address-length addr)))
+                  (lp (address-info-next addr))
+                  (let ((in (open-input-fd sock))
+                        (out (open-output-fd sock)))
+                    (let ((res (proc in out)))
+                      (close-input-port in)
+                      res))))))))

lib/chibi/net.stub

@@ -0,0 +1,26 @@
+
+(c-system-include "sys/types.h")
+(c-system-include "sys/socket.h")
+(c-system-include "netdb.h")
+
+(define-c-struct sockaddr
+  predicate:   sockaddr?)
+
+(define-c-struct addrinfo
+  finalizer: freeaddrinfo
+  predicate: address-info?
+  (int       ai_family    address-info-family)
+  (int       ai_socktype  address-info-socket-type)
+  (int       ai_protocol  address-info-protocol)
+  (sockaddr  ai_addr      address-info-address)
+  (size_t    ai_addrlen   address-info-address-length)
+  (addrinfo  ai_next      address-info-next))
+
+(define-c errno (get-address-info getaddrinfo)
+  (string string (maybe-null addrinfo) (result free addrinfo)))
+
+(define-c int bind (int sockaddr int))
+(define-c int listen (int int))
+(define-c int socket (int int int))
+(define-c int connect (int sockaddr int))
+

lib/chibi/posix.module

@@ -0,0 +1,8 @@
+
+(define-module (chibi posix)
+  (export open-input-fd open-output-fd
+          delete-file link-file symbolic-link rename-file
+          create-directory delete-directory)
+  (import (scheme))
+  (include-shared "posix"))
+

lib/chibi/posix.stub

@@ -0,0 +1,18 @@
+
+(c-system-include "sys/types.h")
+(c-system-include "unistd.h")
+
+(define-c input-port (open-input-fd fdopen) (int (value "r")))
+(define-c output-port (open-output-fd fdopen) (int (value "w")))
+
+(define-c errno (delete-file unlink) (string))
+(define-c errno (link-file link) (string string))
+(define-c errno (symbolic-link symlink) (string string))
+(define-c errno (rename-file rename) (string string))
+
+(define-c errno (create-directory mkdir) (string int))
+(define-c errno (delete-directory rmdir) (string))
+
+(define-c int (duplicate-fd dup) (int))
+;;(define-c errno pipe ((array int 2)))
+

sexp.c

@@ -308,6 +308,8 @@ sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) {
 
 sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) {
   sexp ls;
+  if (! sexp_oportp(out))
+    out = sexp_make_output_port(ctx, stderr, SEXP_FALSE);
   sexp_write_string(ctx, "ERROR", out);
   if (sexp_exceptionp(exn)) {
     if (sexp_procedurep(sexp_exception_procedure(exn))) {

tools/genstubs.scm

@@ -0,0 +1,451 @@
+#! chibi-scheme -s
+
+(define types '())
+(define funcs '())
+
+(define (cat . args)
+  (for-each (lambda (x) (if (procedure? x) (x) (display x))) args))
+
+(define (x->string x)
+  (cond ((string? x) x)
+        ((symbol? x) (symbol->string x))
+        ((number? x) (number->string x))
+        (else (error "non-stringable object" x))))
+
+(define (strip-extension path)
+  (let lp ((i (- (string-length path) 1)))
+    (cond ((<= i 0) path)
+          ((eq? #\. (string-ref path i)) (substring path 0 i))
+          (else (lp (- i 1))))))
+
+(define (string-concatenate-reverse ls)
+  (cond ((null? ls) "")
+        ((null? (cdr ls)) (car ls))
+        (else (string-concatenate (reverse ls)))))
+
+(define (string-replace str c r)
+  (let ((len (string-length str)))
+    (let lp ((from 0) (i 0) (res '()))
+      (define (collect) (if (= i from) res (cons (substring str from i) res)))
+      (cond
+       ((>= i len) (string-concatenate-reverse (collect)))
+       ((eqv? c (string-ref str i))
+        (lp (+ i 1) (+ i 1) (cons r (collect))))
+       (else
+        (lp from (+ i 1) res))))))
+
+(define (mangle x)
+  (string-replace
+   (string-replace (string-replace (x->string x) #\- "_") #\? "_p")
+   #\! "_x"))
+
+(define (func-name func)
+  (caddr func))
+
+(define (func-scheme-name x)
+  (if (pair? x) (car x) x))
+
+(define (func-c-name x)
+  (if (pair? x) (cadr x) x))
+
+(define (stub-name sym)
+  (string-append "sexp_" (mangle sym) "_stub"))
+
+(define (type-id-name sym)
+  (string-append "sexp_" (mangle sym) "_type_id"))
+
+(define (signed-int-type? type)
+  (memq type '(short int long)))
+
+(define (unsigned-int-type? type)
+  (memq type '(unsigned-short unsigned-int unsigned-long size_t)))
+
+(define (int-type? type)
+  (or (signed-int-type? type) (unsigned-int-type? type)))
+
+(define (float-type? type)
+  (memq type '(float double long-double)))
+
+(define (c-declare . args)
+  (apply cat args)
+  (newline))
+
+(define (c-system-include header)
+  (cat "\n#include <" header ">\n"))
+
+(define-syntax define-c-struct
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (set! types (cons (cdr expr) types))
+     `(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n"))))
+
+(define-syntax define-c
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (set! funcs (cons (cons (stub-name (func-scheme-name (caddr expr)))
+                             (cdr expr))
+                       funcs))
+     #f)))
+
+(define (delq x ls)
+  (cond ((not (pair? ls)) ls)
+        ((eq? x (car ls)) (cdr ls))
+        (else (cons (car ls) (delq x (cdr ls))))))
+
+(define (without-mod x ls)
+  (let ((res (delq x ls)))
+    (if (and (pair? res) (null? (cdr res)))
+        (car res)
+        res)))
+
+(define (with-parsed-type type proc)
+  (let* ((free? (and (pair? type) (memq 'free type)))
+         (type (if free? (without-mod 'free type) type))
+         (const? (and (pair? type) (memq 'const type)))
+         (type (if const? (without-mod 'const type) type))
+         (null-ptr? (and (pair? type) (memq 'maybe-null type)))
+         (type (if null-ptr? (without-mod 'maybe-null type) type))
+         (pointer? (and (pair? type) (memq 'pointer type)))
+         (type (if pointer? (without-mod 'pointer type) type))
+         (result? (and (pair? type) (memq 'result type)))
+         (type (if result? (without-mod 'result type) type)))
+    (proc type free? const? null-ptr? pointer? result?)))
+
+(define (c->scheme-converter type val)
+  (with-parsed-type
+   type
+   (lambda (type free? const? null-ptr? pointer? result?)
+     (cond
+      ((memq type '(sexp errno))
+       (cat val))
+      ((int-type? type)
+       (cat "sexp_make_integer(ctx, " val ")"))
+      ((eq? 'string type)
+       (cat "sexp_c_string(ctx, " val ", -1)"))
+      ((eq? 'input-port type)
+       (cat "sexp_make_input_port(ctx, " val ", SEXP_FALSE)"))
+      ((eq? 'output-port type)
+       (cat "sexp_make_output_port(ctx, " val ", SEXP_FALSE)"))
+      (else
+       (let ((ctype (assq type types)))
+         (cond
+          (ctype
+           (cat "sexp_make_cpointer(ctx, "  (type-id-name type) ", "
+                val ", " (if free? 1 0) ")"))
+          (else
+           (error "unknown type" type)))))))))
+
+(define (scheme->c-converter type val)
+  (with-parsed-type
+   type
+   (lambda (type free? const? null-ptr? pointer? result?)
+     (cond
+      ((eq? 'sexp type)
+       (cat val))
+      ((signed-int-type? type)
+       (cat "sexp_sint_value(" val ")"))
+      ((unsigned-int-type? type)
+       (cat "sexp_uint_value(" val ")"))
+      ((eq? 'string type)
+       (cat "sexp_string_data(" val ")"))
+      (else
+       (let ((ctype (assq type types)))
+         (cond
+          (ctype
+           (cat (if null-ptr?
+                    "sexp_cpointer_maybe_null_value"
+                    "sexp_cpointer_value")
+                "(" val ")"))
+          (else
+           (error "unknown type" type)))))))))
+
+(define (type-predicate type)
+  (with-parsed-type
+   type
+   (lambda (type free? const? null-ptr? pointer? result?)
+     (cond
+      ((int-type? type) "sexp_exact_integerp")
+      ((float-type? type) "sexp_flonump")
+      ((eq? 'string type) "sexp_stringp")
+      (else #f)))))
+
+(define (type-name type)
+  (with-parsed-type
+   type
+   (lambda (type free? const? null-ptr? pointer? result?)
+     (cond
+       ((int-type? type) "integer")
+       ((float-type? type) "flonum")
+       (else type)))))
+
+(define (type-c-name type)
+  (with-parsed-type
+   type
+   (lambda (base-type free? const? null-ptr? pointer? result?)
+     (let ((struct? (assq base-type types)))
+       (string-append
+        (if const? "const " "")
+        (if struct? "struct " "")
+        (string-replace (symbol->string base-type) #\- #\space)
+        (if struct? "*" "")
+        (if pointer? "*" ""))))))
+
+(define (check-type arg type)
+  (with-parsed-type
+   type
+   (lambda (base-type free? const? null-ptr? pointer? result?)
+     (cond
+      ((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type))
+       (cat (type-predicate type) "(" arg ")"))
+      (else
+       (cond
+        ((assq base-type types)
+         (cat
+          (if null-ptr? "(" "")
+          "(sexp_pointerp(" arg  ")"
+          " && (sexp_pointer_tag(" arg  ") == " (type-id-name base-type) "))"
+          (lambda () (if null-ptr? (cat " || sexp_not(" arg "))")))))
+        (else
+         (display "WARNING: don't know how to check: " (current-error-port))
+         (write type (current-error-port))
+         (newline (current-error-port))
+         (cat "1"))))))))
+
+(define (validate-type arg type)
+  (with-parsed-type
+   type
+   (lambda (base-type free? const? null-ptr? pointer? result?)
+     (cond
+      ((or (int-type? base-type) (float-type? base-type) (eq? 'string base-type))
+       (cat
+        "  if (! " (lambda () (check-type arg type)) ")\n"
+        "    return sexp_type_exception(ctx, \"not a " (type-name type) "\", "
+        arg ");\n"))
+      (else
+       (cond
+        ((assq base-type types)
+         (cat
+          "  if (! " (lambda () (check-type arg type)) ")\n"
+          "    return sexp_type_exception(ctx, \"not a " type "\", " arg ");\n"))
+        (else
+         (display "WARNING: don't know how to validate: " (current-error-port))
+         (write type (current-error-port))
+         (newline (current-error-port))
+         (write type))))))))
+
+(define (get-func-result func)
+  (let lp ((ls (cadddr func)))
+    (and (pair? ls)
+         (if (memq 'result (car ls))
+             (car ls)
+             (lp (cdr ls))))))
+
+(define (get-func-args func)
+  (let lp ((ls (cadddr func)) (res '()))
+    (if (pair? ls)
+        (if (and (pair? (car ls))
+                 (or (memq 'result (car ls)) (memq 'value (car ls))))
+            (lp (cdr ls) res)
+            (lp (cdr ls) (cons (car ls) res)))
+        (reverse res))))
+
+(define (write-func func)
+  (let ((ret-type (cadr func))
+        (result (get-func-result func))
+        (args (get-func-args func)))
+    (cat "static sexp " (car func) "(sexp ctx, ")
+    (let lp ((ls args) (i 0))
+      (cond ((pair? ls)
+             (cat "sexp arg" i (if (pair? (cdr ls)) ", " ""))
+             (lp (cdr ls) (+ i 1)))))
+    (cat ") {\n  sexp res;\n")
+    (if (eq? 'errno ret-type) (cat "  int err;\n"))
+    (if result (cat "  " (type-c-name result) " tmp;\n"))
+    (let lp ((ls args) (i 0))
+      (cond ((pair? ls)
+             (validate-type (string-append "arg" (number->string i)) (car ls))
+             (lp (cdr ls) (+ i 1)))))
+    (cat (if (eq? 'errno ret-type) "  err = " "  res = "))
+    (c->scheme-converter
+     ret-type
+     (lambda ()
+       (cat (func-c-name (func-name func)) "(")
+       (let lp ((ls (cadddr func)) (i 0))
+         (cond ((pair? ls)
+                (cat (cond
+                      ((eq? (car ls) result)
+                       "&tmp")
+                      ((and (pair? (car ls)) (memq 'value (car ls)))
+                       => (lambda (x) (write (cadr x)) ""))
+                      (else
+                       (lambda ()
+                         (scheme->c-converter
+                          (car ls)
+                          (string-append "arg" (number->string i))))))
+                     (if (pair? (cdr ls)) ", " ""))
+                (lp (cdr ls) (+ i 1)))))
+       (cat ")")))
+    (cat ";\n")
+    (if (eq? 'errno ret-type)
+        (if result
+            (cat "  res = (err ? SEXP_FALSE : "
+                 (lambda () (c->scheme-converter result "tmp"))
+                 ");\n")
+            (cat "  res = sexp_make_boolean(! err);\n")))
+    (cat "  return res;\n"
+         "}\n\n")))
+
+(define (write-func-binding func)
+  (cat "  sexp_define_foreign(ctx, env, "
+       (lambda () (write (symbol->string (func-scheme-name (func-name func)))))
+       ", " (length (get-func-args func))  ", " (car func) ");\n"))
+
+(define (write-type type)
+  (let ((name (car type))
+        (type (cdr type)))
+    (with-parsed-type
+     type
+     (lambda (base-type free? const? null-ptr? pointer? result?)
+       (cat "  name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n"
+            "  " (type-id-name name)
+            " = sexp_unbox_fixnum(sexp_register_c_type(ctx, name, "
+            (cond ((memq 'finalizer: base-type)
+                   => (lambda (x) (stub-name (cadr x))))
+                  (else "sexp_finalize_c_type"))
+            "));\n")
+       (cond
+        ((memq 'predicate: base-type)
+         => (lambda (x)
+              (let ((pred (cadr x)))
+                (cat "  tmp = sexp_make_type_predicate(ctx, name, "
+                     "sexp_make_fixnum(" (type-id-name name) "));\n"
+                     "  name = sexp_intern(ctx, \"" pred "\");\n"
+                     "  sexp_env_define(ctx, env, name, tmp);\n")))))))))
+
+(define (type-getter-name type name field)
+  (string-append "sexp_" (x->string (type-name name))
+                 "_get_" (x->string (cadr field))))
+
+(define (write-type-getter type name field)
+  (cat "static sexp " (type-getter-name type name field)
+       " (sexp ctx, sexp x) {\n"
+       (lambda () (validate-type "x" name))
+       "  return "
+       (lambda () (c->scheme-converter
+               (car field)
+               (string-append "((struct " (mangle name) "*)"
+                              "sexp_cpointer_value(x))->"
+                              (x->string (cadr field)))))
+       ";\n"
+       "}\n\n"))
+
+(define (type-setter-name type name field)
+  (string-append "sexp_" (x->string (type-name name))
+                 "_set_" (x->string (car field))))
+
+(define (write-type-setter type name field)
+  (cat "static sexp " (type-setter-name type name field)
+       " (sexp ctx, sexp x, sexp v) {\n"
+       (lambda () (validate-type "x" name))
+       (lambda () (validate-type "v" (car field)))
+       "  "
+       (lambda () (c->scheme-converter
+               (car field)
+               (string-append "((struct " (mangle name) "*)"
+                              "sexp_cpointer_value(x))->"
+                              (x->string (cadr field)))))
+       " = v;\n"
+       "  return SEXP_VOID;"
+       "}\n\n"))
+
+(define (write-type-funcs type)
+  (let ((name (car type))
+        (type (cdr type)))
+    (with-parsed-type
+     type
+     (lambda (base-type free? const? null-ptr? pointer? result?)
+       (cond
+        ((memq 'finalizer: base-type)
+         => (lambda (x)
+              (cat "static sexp " (stub-name (cadr x))
+                   " (sexp ctx, sexp x) {\n"
+                   "  if (sexp_cpointer_freep(x))\n"
+                   "    " (cadr x) "(sexp_cpointer_value(x));\n"
+                   "  return SEXP_VOID;\n"
+                   "}\n\n"))))
+       (cond
+        ((memq 'constructor: base-type)
+         => (lambda (x)
+              (let ((make (caadr x))
+                    (args (cdadr x)))
+                (cat "static sexp " (stub-name make)
+                     " (sexp ctx"
+                     (lambda () (for-each (lambda (x) (cat ", sexp " x)) args))
+                     ") {\n"
+                     "  struct " (type-name name) " *r;\n"
+                     "  sexp res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer) + sizeof(struct " (type-name name) "), "
+                     (type-id-name name)
+                     ");\n"
+                     "  sexp_cpointer_value(res) = sexp_cpointer_body(res);\n"
+                     "  r = sexp_cpointer_value(res);\n"
+                     "  return res;\n"
+                     "}\n\n")
+                (set! funcs
+                      (cons (list (stub-name make) 'void make args) funcs))))))
+       (for-each
+        (lambda (field)
+          (cond
+           ((and (pair? field) (pair? (cdr field)))
+            (cond
+             ((and (pair? (cddr field)) (caddr field))
+              (write-type-getter type name field)
+              (set! funcs
+                    (cons (list (type-getter-name type name field)
+                                (car field) (caddr field) (list name))
+                          funcs))))
+            (cond
+             ((and (pair? (cddr field))
+                   (pair? (cdddr field))
+                   (car (cdddr field)))
+              (write-type-setter type name field)
+              (set! funcs
+                    (cons (list (type-setter-name type name field)
+                                (car field) (cadddr field)
+                                (list name (car field)))
+                          funcs))
+              )))))
+        base-type)))))
+
+(define (write-init)
+  (newline)
+  (for-each write-func funcs)
+  (for-each write-type-funcs types)
+  (cat "sexp sexp_init_library (sexp ctx, sexp env) {\n"
+       "  sexp_gc_var2(name, tmp);\n"
+       "  sexp_gc_preserve2(ctx, name, tmp);\n")
+  (for-each write-type types)
+  (for-each write-func-binding funcs)
+  (cat "  sexp_gc_release2(ctx);\n"
+       "  return SEXP_VOID;\n"
+       "}\n\n"))
+
+(define (generate file)
+  (display "/* automatically generated by chibi genstubs */\n")
+  (c-system-include "chibi/eval.h")
+  (load file)
+  (write-init))
+
+(define (main args)
+  (case (length args)
+    ((1)
+     (with-output-to-file (string-append (strip-extension (car args)) ".c")
+       (lambda () (generate (car args)))))
+    ((2)
+     (if (equal? "-" (cadr args))
+         (generate (car args))
+         (with-output-to-file (cadr args) (lambda () (generate (car args))))))
+    (else
+     (error "usage: genstubs <file.stub> [<output.c>]"))))
+
+(main (command-line-arguments))
+