From 77f2990f28439f525eb117aad93045ade0010f77 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Fri, 25 Dec 2009 21:11:56 +0900
Subject: [PATCH] factoring (chibi posix) into filesystem, process and time
 modules. the time module is garbage, because libc time handling is garbage.
 the signal handling is still experimental, use at your own risk. still need a
 host module for user/group and other host information.

---
 Makefile                    |   3 +-
 include/chibi/sexp.h        |   1 +
 lib/chibi/filesystem.module |  22 ++++
 lib/chibi/filesystem.scm    |  39 +++++++
 lib/chibi/filesystem.stub   |  88 +++++++++++++++
 lib/chibi/posix.module      |  12 --
 lib/chibi/posix.scm         |  10 --
 lib/chibi/posix.stub        |  40 -------
 lib/chibi/process.module    |  17 +++
 lib/chibi/process.stub      |  69 ++++++++++++
 lib/chibi/time.module       |  11 ++
 lib/chibi/time.stub         |  45 ++++++++
 lib/srfi/1.module           |   2 +-
 tools/genstubs.scm          | 219 +++++++++++++++++++++++++++---------
 14 files changed, 461 insertions(+), 117 deletions(-)
 create mode 100644 lib/chibi/filesystem.module
 create mode 100644 lib/chibi/filesystem.scm
 create mode 100644 lib/chibi/filesystem.stub
 delete mode 100644 lib/chibi/posix.module
 delete mode 100644 lib/chibi/posix.scm
 delete mode 100644 lib/chibi/posix.stub
 create mode 100644 lib/chibi/process.module
 create mode 100644 lib/chibi/process.stub
 create mode 100644 lib/chibi/time.module
 create mode 100644 lib/chibi/time.stub

diff --git a/Makefile b/Makefile
index 3aa63400..a10c3e0e 100644
--- a/Makefile
+++ b/Makefile
@@ -83,7 +83,8 @@ all: chibi-scheme$(EXE) libs
 COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \
 	lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \
 	lib/chibi/ast$(SO) lib/chibi/net$(SO) \
-	lib/chibi/posix$(SO) lib/chibi/heap-stats$(SO)
+	lib/chibi/filesystem$(SO) lib/chibi/process$(SO) \
+	lib/chibi/time$(SO) lib/chibi/heap-stats$(SO)
 
 libs: $(COMPILED_LIBS)
 
diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h
index 30c542bd..73c78efb 100644
--- a/include/chibi/sexp.h
+++ b/include/chibi/sexp.h
@@ -696,6 +696,7 @@ enum sexp_context_globals {
   SEXP_G_OOM_ERROR,             /* out of memory exception object */
   SEXP_G_OOS_ERROR,             /* out of stack exception object */
   SEXP_G_OPTIMIZATIONS,
+  SEXP_G_SIGNAL_HANDLERS,
   SEXP_G_CONFIG_ENV,
   SEXP_G_MODULE_PATH,
   SEXP_G_QUOTE_SYMBOL,
diff --git a/lib/chibi/filesystem.module b/lib/chibi/filesystem.module
new file mode 100644
index 00000000..fe0fbdcf
--- /dev/null
+++ b/lib/chibi/filesystem.module
@@ -0,0 +1,22 @@
+
+(define-module (chibi filesystem)
+  (export open-input-file-descriptor open-output-file-descriptor
+          duplicate-file-descriptor duplicate-file-descriptor-to
+          close-file-descriptor renumber-file-descriptor
+          delete-file link-file symbolic-link-file rename-file
+          directory-files create-directory delete-directory
+          file-status
+          file-device               file-inode
+          file-mode                 file-num-links
+          file-owner                file-group
+          file-represented-device   file-size
+          file-block-size           file-num-blocks
+          file-access-time file-modification-time file-change-time
+          file-regular?    file-directory?        file-character?
+          file-block?      file-fifo?             file-link?
+          file-socket?
+          )
+  (import-immutable (scheme))
+  (include-shared "filesystem")
+  (include "filesystem.scm"))
+
diff --git a/lib/chibi/filesystem.scm b/lib/chibi/filesystem.scm
new file mode 100644
index 00000000..b3995221
--- /dev/null
+++ b/lib/chibi/filesystem.scm
@@ -0,0 +1,39 @@
+
+(define (directory-fold dir kons knil)
+  (let ((dir (opendir dir)))
+    (let lp ((res knil))
+      (let ((file (readdir dir)))
+        (if file (lp (kons (dirent-name file) res)) res)))))
+
+(define (directory-files dir)
+  (directory-fold dir cons '()))
+
+(define (renumber-file-descriptor old new)
+  (and (duplicate-file-descriptor-to old new)
+       (close-file-descriptor old)))
+
+(define (file-status file)
+  (if (string? file) (stat file) (fstat file)))
+
+(define (file-device x) (stat-dev (if (stat? x) x (file-status x))))
+(define (file-inode x) (stat-ino (if (stat? x) x (file-status x))))
+(define (file-mode x) (stat-mode (if (stat? x) x (file-status x))))
+(define (file-num-links x) (stat-nlinks (if (stat? x) x (file-status x))))
+(define (file-owner x) (stat-uid (if (stat? x) x (file-status x))))
+(define (file-group x) (stat-gid (if (stat? x) x (file-status x))))
+(define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x))))
+(define (file-size x) (stat-size (if (stat? x) x (file-status x))))
+(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x))))
+(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x))))
+(define (file-access-time x) (stat-atime (if (stat? x) x (file-status x))))
+(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x))))
+(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x))))
+
+(define (file-regular? x) (S_ISREG (file-mode x)))
+(define (file-directory? x) (S_ISDIR (file-mode x)))
+(define (file-character? x) (S_ISCHR (file-mode x)))
+(define (file-block? x) (S_ISBLK (file-mode x)))
+(define (file-fifo? x) (S_ISFIFO (file-mode x)))
+(define (file-link? x) (S_ISLNK (file-mode x)))
+(define (file-socket? x) (S_ISSOCK (file-mode x)))
+
diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub
new file mode 100644
index 00000000..ebd2f7be
--- /dev/null
+++ b/lib/chibi/filesystem.stub
@@ -0,0 +1,88 @@
+
+(c-system-include "sys/types.h")
+(c-system-include "unistd.h")
+(c-system-include "dirent.h")
+
+(define-c-struct DIR
+  finalizer: closedir)
+
+(define-c-struct dirent
+  (string d_name dirent-name))
+
+(define-c-struct stat
+  predicate: stat?
+  (dev_t      st_dev      stat-dev)
+  (ino_t      st_ino      stat-ino)
+  (mode_t     st_mode     stat-mode)
+  (nlink_t    st_nlink    stat-nlinks)
+  (uid_t      st_uid      stat-uid)
+  (gid_t      st_gid      stat-gid)
+  (dev_t      st_rdev     stat-rdev)
+  (off_t      st_size     stat-size)
+  (blksize_t  st_blksize  stat-blksize)
+  (blkcnt_t   st_blocks   stat-blocks)
+  (time_t     st_atime    stat-atime)
+  (time_t     st_mtime    stat-mtime)
+  (time_t     st_ctime    stat-ctime))
+
+(define-c boolean S_ISREG (mode_t))
+(define-c boolean S_ISDIR (mode_t))
+(define-c boolean S_ISCHR (mode_t))
+(define-c boolean S_ISBLK (mode_t))
+(define-c boolean S_ISFIFO (mode_t))
+(define-c boolean S_ISLNK (mode_t))
+(define-c boolean S_ISSOCK (mode_t))
+
+;;(define-c-const int ("S_IFMT"))
+(define-c-const int (file/socket "S_IFSOCK"))
+(define-c-const int (file/link "S_IFLNK"))
+(define-c-const int (file/regular "S_IFREG"))
+(define-c-const int (file/block "S_IFBLK"))
+(define-c-const int (file/directory "S_IFDIR"))
+(define-c-const int (file/character "S_IFCHR"))
+(define-c-const int (file/fifo "S_IFIFO"))
+(define-c-const int (file/suid "S_ISUID"))
+(define-c-const int (file/sgid "S_ISGID"))
+(define-c-const int (file/sticky "S_ISVTX"))
+;;(define-c-const int ("S_IRWXU"))
+(define-c-const int (perm/user-read "S_IRUSR"))
+(define-c-const int (perm/user-write "S_IWUSR"))
+(define-c-const int (perm/user-execute "S_IXUSR"))
+;;(define-c-const int ("S_IRWXG"))
+(define-c-const int (perm/group-read "S_IRGRP"))
+(define-c-const int (perm/group-write "S_IWGRP"))
+(define-c-const int (perm/group-execute "S_IXGRP"))
+;;(define-c-const int ("S_IRWXO"))
+(define-c-const int (perm/others-read "S_IROTH"))
+(define-c-const int (perm/others-write "S_IWOTH"))
+(define-c-const int (perm/others-execute "S_IXOTH"))
+
+(define-c errno stat (string (result stat)))
+(define-c errno fstat (int (result stat)))
+(define-c errno (file-link-status "lstat") (string (result stat)))
+
+(define-c input-port (open-input-file-descriptor "fdopen")
+  (int (value "r" string)))
+(define-c output-port (open-output-file-descriptor "fdopen")
+  (int (value "w" string)))
+
+(define-c errno (delete-file "unlink") (string))
+(define-c errno (link-file "link") (string string))
+(define-c errno (symbolic-link-file "symlink") (string string))
+(define-c errno (rename-file "rename") (string string))
+
+(define-c non-null-string (current-directory "getcwd")
+  ((result (array char (auto-expand arg1))) (value 256 int)))
+
+(define-c errno (create-directory "mkdir") (string int))
+(define-c errno (delete-directory "rmdir") (string))
+
+(define-c (free DIR) opendir (string))
+(define-c dirent readdir ((link DIR)))
+
+(define-c int (duplicate-file-descriptor "dup") (int))
+(define-c errno (duplicate-file-descriptor-to "dup2") (int int))
+(define-c errno (close-file-descriptor "close") (int))
+
+(define-c errno (open-pipe "pipe") ((result (array int 2))))
+(define-c errno (make-fifo "mkfifo") (string (default #o644 int)))
diff --git a/lib/chibi/posix.module b/lib/chibi/posix.module
deleted file mode 100644
index af726ff4..00000000
--- a/lib/chibi/posix.module
+++ /dev/null
@@ -1,12 +0,0 @@
-
-(define-module (chibi posix)
-  (export open-input-fd open-output-fd pipe
-          delete-file link-file symbolic-link-file rename-file
-          directory-files create-directory delete-directory
-          current-seconds
-          waitpid exit
-          )
-  (import-immutable (scheme))
-  (include-shared "posix")
-  (include "posix.scm"))
-
diff --git a/lib/chibi/posix.scm b/lib/chibi/posix.scm
deleted file mode 100644
index ed5fa780..00000000
--- a/lib/chibi/posix.scm
+++ /dev/null
@@ -1,10 +0,0 @@
-
-(define (directory-fold dir kons knil)
-  (let ((dir (opendir dir)))
-    (let lp ((res knil))
-      (let ((file (readdir dir)))
-        (if file (lp (kons (dirent-name file) res)) res)))))
-
-(define (directory-files dir)
-  (directory-fold dir cons '()))
-
diff --git a/lib/chibi/posix.stub b/lib/chibi/posix.stub
deleted file mode 100644
index 25dd5dbd..00000000
--- a/lib/chibi/posix.stub
+++ /dev/null
@@ -1,40 +0,0 @@
-
-(c-system-include "sys/types.h")
-(c-system-include "sys/wait.h")
-(c-system-include "time.h")
-(c-system-include "unistd.h")
-(c-system-include "dirent.h")
-
-(define-c-struct DIR
-  finalizer: closedir)
-
-(define-c-struct dirent
-  (string d_name dirent-name))
-
-(define-c input-port (open-input-fd "fdopen") (int (value "r" string)))
-(define-c output-port (open-output-fd "fdopen") (int (value "w" string)))
-
-(define-c errno (delete-file "unlink") (string))
-(define-c errno (link-file "link") (string string))
-(define-c errno (symbolic-link-file "symlink") (string string))
-(define-c errno (rename-file "rename") (string string))
-
-(define-c non-null-string (current-directory "getcwd")
-  ((result (array char (auto-expand arg1))) (value 256 int)))
-(define-c errno (create-directory "mkdir") (string int))
-(define-c errno (delete-directory "rmdir") (string))
-
-(define-c (free DIR) opendir (string))
-(define-c dirent readdir ((link DIR)))
-
-(define-c int (duplicate-fd "dup") (int))
-
-(define-c pid_t fork ())
-(define-c pid_t waitpid (int (result int) int))
-(define-c void exit (int))
-(define-c int (execute execvp) (string (array string)))
-
-(define-c errno pipe ((result (array int 2))))
-
-(define-c time_t (current-seconds "time") ((value NULL)))
-
diff --git a/lib/chibi/process.module b/lib/chibi/process.module
new file mode 100644
index 00000000..3e3f2cdb
--- /dev/null
+++ b/lib/chibi/process.module
@@ -0,0 +1,17 @@
+
+(define-module (chibi process)
+  (export exit sleep fork kill execute waitpid
+          set-signal-action! make-signal-set signal-set-contains?
+          signal-set-fill! signal-set-add! signal-set-delete!
+          current-signal-mask
+          signal-mask-block! signal-mask-unblock! signal-mask-set!
+          signal/hang-up    signal/interrupt   signal/quit
+          signal/illegal    signal/abort       signal/fpe
+          signal/kill       signal/segv        signal/pipe
+          signal/alarm      signal/term        signal/user1
+          signal/user2      signal/child       signal/continue
+          signal/stop       signal/tty-stop    signal/tty-input
+          signal/tty-output)
+  (import-immutable (scheme))
+  (include-shared "process"))
+
diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub
new file mode 100644
index 00000000..baa5a7a5
--- /dev/null
+++ b/lib/chibi/process.stub
@@ -0,0 +1,69 @@
+
+(c-system-include "sys/types.h")
+(c-system-include "sys/wait.h")
+(c-system-include "signal.h")
+(c-system-include "unistd.h")
+
+(define-c-struct siginfo
+  predicate: signal-info?
+  (int      si_signo    signal-number)
+  (int      si_errno    signal-error-number)
+  (int      si_code     signal-code)
+  (pid_t    si_pid      signal-pid)
+  (uid_t    si_uid      signal-uid)
+  (int      si_status   signal-status)
+  (clock_t  si_utime    signal-user-time)
+  (clock_t  si_stime    signal-system-time))
+
+(define-c-type sigset_t
+  predicate: signal-set?)
+
+(define-c-const int (signal/hang-up "SIGHUP"))
+(define-c-const int (signal/interrupt "SIGINT"))
+(define-c-const int (signal/quit "SIGQUIT"))
+(define-c-const int (signal/illegal "SIGILL"))
+(define-c-const int (signal/abort "SIGABRT"))
+(define-c-const int (signal/fpe "SIGFPE"))
+(define-c-const int (signal/kill "SIGKILL"))
+(define-c-const int (signal/segv "SIGSEGV"))
+(define-c-const int (signal/pipe "SIGPIPE"))
+(define-c-const int (signal/alarm "SIGALRM"))
+(define-c-const int (signal/term "SIGTERM"))
+(define-c-const int (signal/user1"SIGUSR1"))
+(define-c-const int (signal/user2 "SIGUSR2"))
+(define-c-const int (signal/child "SIGCHLD"))
+(define-c-const int (signal/continue "SIGCONT"))
+(define-c-const int (signal/stop "SIGSTOP"))
+(define-c-const int (signal/tty-stop "SIGTSTP"))
+(define-c-const int (signal/tty-input "SIGTTIN"))
+(define-c-const int (signal/tty-output "SIGTTOU"))
+
+(c-include "signal.c")
+
+(define-c sexp (set-signal-action! "sexp_set_signal_action")
+  ((value ctx sexp) sexp  sexp))
+
+(define-c errno (make-signal-set "sigemptyset") ((result sigset_t)))
+(define-c errno (signal-set-fill! "sigfillset") (sigset_t))
+(define-c errno (signal-set-add! "sigaddset") (sigset_t int))
+(define-c errno (signal-set-delete! "sigaddset") (sigset_t int))
+(define-c boolean (signal-set-contains? "sigismember") (sigset_t int))
+
+(define-c errno (signal-mask-block! "sigprocmask")
+  ((value SIG_BLOCK int) sigset_t (value NULL sigset_t)))
+(define-c errno (signal-mask-unblock! "sigprocmask")
+  ((value SIG_UNBLOCK int) sigset_t (value NULL sigset_t)))
+(define-c errno (signal-mask-set! "sigprocmask")
+  ((value SIG_SETMASK int) sigset_t (value NULL sigset_t)))
+(define-c errno (current-signal-mask "sigprocmask")
+  ((value SIG_BLOCK int) (value NULL sigset_t) (result sigset_t)))
+
+(define-c pid_t fork ())
+;;(define-c pid_t wait ((result int)))
+(define-c pid_t waitpid (int (result int) int))
+(define-c errno kill (int int))
+;;(define-c errno raise (int))
+(define-c unsigned-int sleep (unsigned-int))
+(define-c void exit (int))
+(define-c int (execute execvp) (string (array string)))
+
diff --git a/lib/chibi/time.module b/lib/chibi/time.module
new file mode 100644
index 00000000..84f2b800
--- /dev/null
+++ b/lib/chibi/time.module
@@ -0,0 +1,11 @@
+
+(define-module (chibi time)
+  (export current-seconds get-time-of-day set-time-of-day!
+          seconds->time seconds->string time->seconds time->string
+          timeval-seconds timeval-microseconds
+          timezone-offset timezone-dst-time
+          time-second time-minute time-hour time-day time-month time-year
+          time-day-of-week time-day-of-year time-dst?)
+  (import-immutable (scheme))
+  (include-shared "time"))
+
diff --git a/lib/chibi/time.stub b/lib/chibi/time.stub
new file mode 100644
index 00000000..b2d444a8
--- /dev/null
+++ b/lib/chibi/time.stub
@@ -0,0 +1,45 @@
+
+(c-system-include "time.h")
+(c-system-include "sys/time.h")
+
+(define-c-struct tm
+  (int     tm_sec    time-second)
+  (int     tm_min    time-minute)
+  (int     tm_hour   time-hour)
+  (int     tm_mday   time-day)
+  (int     tm_mon    time-month)
+  (int     tm_year   time-year)
+  (int     tm_wday   time-day-of-week)
+  (int     tm_yday   time-day-of-year)
+  (int     tm_isdst  time-dst?))
+
+(define-c-struct timeval
+  predicate: timeval?
+  (time_t  tv_sec          timeval-seconds)
+  (int     tv_usec         timeval-microseconds))
+
+(define-c-struct timezone
+  predicate: timezone?
+  (int     tz_minuteswest  timezone-offset)
+  (int     tz_dsttime      timezone-dst-time))
+
+(define-c time_t (current-seconds "time") ((value NULL)))
+
+(define-c errno (get-time-of-day "gettimeofday")
+  ((result timeval) (result timezone)))
+
+(define-c errno (set-time-of-day! "settimeofday")
+  ((maybe-null timeval) (maybe-null default NULL timezone)))
+
+(define-c non-null-pointer (seconds->time "localtime_r")
+  ((pointer time_t) (result tm)))
+
+(define-c time_t (time->seconds "mktime")
+  (tm))
+
+(define-c non-null-string (seconds->string "ctime_r")
+  ((pointer time_t) (result (array char 64))))
+
+(define-c non-null-string (time->string "asctime_r")
+  (tm (result (array char 64))))
+
diff --git a/lib/srfi/1.module b/lib/srfi/1.module
index 8d341b6b..3d3da044 100644
--- a/lib/srfi/1.module
+++ b/lib/srfi/1.module
@@ -18,7 +18,7 @@
    lset<= lset= lset-adjoin lset-union lset-union! lset-intersection
    lset-intersection! lset-difference lset-difference! lset-xor lset-xor!
    lset-diff+intersection lset-diff+intersection!)
-  (import-immutable (scheme))
+  (import (scheme))
   (include "1/predicates.scm"
            "1/selectors.scm"
            "1/search.scm"
diff --git a/tools/genstubs.scm b/tools/genstubs.scm
index 9f33ef91..c679c30c 100755
--- a/tools/genstubs.scm
+++ b/tools/genstubs.scm
@@ -139,6 +139,7 @@
 
 (define *types* '())
 (define *funcs* '())
+(define *consts* '())
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; type objects
@@ -202,10 +203,12 @@
 ;; type predicates
 
 (define (signed-int-type? type)
-  (memq type '(signed-char short int long)))
+  (memq type '(signed-char short int long boolean)))
 
 (define (unsigned-int-type? type)
-  (memq type '(unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t)))
+  (memq type '(unsigned-char unsigned-short unsigned-int unsigned-long
+               size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t
+               uid_t gid_t pid_t blksize_t blkcnt_t sigval_t)))
 
 (define (int-type? type)
   (or (signed-int-type? type) (unsigned-int-type? type)))
@@ -214,14 +217,23 @@
   (memq type '(float double long-double long-long-double)))
 
 (define (string-type? type)
-  (memq type '(char* string env-string non-null-string)))
+  (or (memq type '(char* string env-string non-null-string))
+      (and (vector? type)
+           (type-array type)
+           (not (type-pointer? type))
+           (eq? 'char (type-base type)))))
 
 (define (error-type? type)
-  (memq type '(errno non-null-string)))
+  (memq type '(errno non-null-string non-null-pointer)))
 
 (define (array-type? type)
   (and (type-array type) (not (eq? 'char (type-base type)))))
 
+(define (basic-type? type)
+  (let ((type (parse-type type)))
+    (and (not (type-array type))
+         (not (assq (type-base type) *types*)))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; function objects
 
@@ -250,7 +262,7 @@
           (cond
            ((type-result? type)
             (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args))
-           ((type-value type)
+           ((and (type-value type) (not (type-default? type)))
             (lp (cdr ls) (+ i 1) results (cons type c-args) s-args))
            (else
             (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args)))
@@ -303,10 +315,8 @@
       (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))))))
+       ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect))))
+       (else (lp from (+ i 1) res))))))
 
 (define (string-scan c str . o)
   (let ((limit (string-length str)))
@@ -349,9 +359,21 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; naming
 
+(define (c-char? c)
+  (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?))))
+
+(define (c-escape str)
+  (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)))
+       ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect)))))
+       (else (lp from (+ i 1) res))))))
+
 (define (mangle x)
   (string-replace
-   (string-replace (string-replace (x->string x) #\- "_") #\? "_p")
+   (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p")
    #\! "_x"))
 
 (define (generate-stub-name sym)
@@ -367,20 +389,38 @@
   (apply cat args)
   (newline))
 
+(define (c-include header)
+  (cat "\n#include \"" header "\"\n"))
+
 (define (c-system-include header)
   (cat "\n#include <" header ">\n"))
 
+(define (parse-struct-like ls)
+  (map (lambda (x) (if (pair? x) (cons (parse-type (car x)) (cdr x)) x)) ls))
+
+(define-syntax define-struct-like
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (set! *types*
+           `((,(cadr expr)
+              ,@(parse-struct-like (cddr expr)))
+             ,@*types*))
+     `(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n"))))
+
 (define-syntax define-c-struct
   (er-macro-transformer
    (lambda (expr rename compare)
-     (set! *types*
-           (cons (map (lambda (x)
-                        (if (pair? x)
-                            (cons (parse-type (car x)) (cdr x))
-                            x))
-                      (cdr expr))
-                 *types*))
-     `(cat "\nstatic sexp_uint_t " ,(type-id-name (cadr expr)) ";\n"))))
+     `(define-struct-like ,(cadr expr) type: struct ,@(cddr expr)))))
+
+(define-syntax define-c-class
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     `(define-struct-like ,(cadr expr) type: class ,@(cddr expr)))))
+
+(define-syntax define-c-type
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     `(define-struct-like ,(cadr expr) ,@(cddr expr)))))
 
 (define-syntax define-c
   (er-macro-transformer
@@ -388,6 +428,12 @@
      (set! *funcs* (cons (parse-func (cdr expr)) *funcs*))
      #f)))
 
+(define-syntax define-c-const
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (set! *consts*
+           (cons (cons (parse-type (cadr expr)) (cddr expr)) *consts*)))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; C code generation
 
@@ -398,6 +444,8 @@
       (cat "((" val "), SEXP_VOID)"))
      ((or (eq? base 'sexp) (error-type? base))
       (cat val))
+     ((eq? base 'boolean)
+      (cat "sexp_make_boolean(" val ")"))
      ((eq? base 'time_t)
       (cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))"))
      ((int-type? base)
@@ -422,7 +470,11 @@
          (ctype
           (cat "sexp_make_cpointer(ctx, "  (type-id-name base) ", "
                val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", "
-               (if (type-free? type) 1 0) ")"))
+               (if (or (type-free? type)
+                       (and (type-result? type) (not (basic-type? type))))
+                   1
+                   0)
+               ")"))
          (else
           (error "unknown type" base))))))))
 
@@ -432,8 +484,10 @@
     (cond
      ((eq? base 'sexp)
       (cat val))
+     ((eq? base 'boolean)
+      (cat "sexp_truep(" val ")"))
      ((eq? base 'time_t)
-      (cat "sexp_uint_value(sexp_unshift_epoch(" val "))"))
+      (cat "sexp_unshift_epoch(sexp_uint_value(" val "))"))
      ((signed-int-type? base)
       (cat "sexp_sint_value(" val ")"))
      ((unsigned-int-type? base)
@@ -462,6 +516,7 @@
      ((float-type? base) "sexp_flonump")
      ((string-type? base) "sexp_stringp")
      ((eq? base 'char) "sexp_charp")
+     ((eq? base 'boolean) "sexp_booleanp")
      (else #f))))
 
 (define (type-name type)
@@ -469,6 +524,7 @@
    (cond
     ((int-type? base) "integer")
     ((float-type? base) "flonum")
+    ((eq? 'boolean base) "int")
     (else base))))
 
 (define (base-type-c-name base)
@@ -479,12 +535,15 @@
 (define (type-c-name type)
   (let* ((type (parse-type type))
          (base (type-base type))
-         (struct? (assq base *types*)))
+         (type-spec (assq base *types*))
+         (struct-type
+          (cond ((and type-spec (memq 'type: type-spec)) => cadr)
+                (else #f))))
     (string-append
      (if (type-const? type) "const " "")
-     (if struct? "struct " "")
+     (if struct-type (string-append (symbol->string struct-type) " ") "")
      (string-replace (base-type-c-name base) #\- " ")
-     (if struct? "*" "")
+     (if type-spec "*" "")
      (if (type-pointer? type) "*" ""))))
 
 (define (check-type arg type)
@@ -515,7 +574,7 @@
          (array (type-array type))
          (base-type (type-base type)))
     (cond
-     (array
+     ((and array (not (string-type? type)))
       (cond
        ((number? array)
         (cat "  if (!sexp_listp(ctx, " arg ")"
@@ -544,9 +603,11 @@
          "  if (! " (lambda () (check-type arg type)) ")\n"
          "    return sexp_type_exception(ctx, \"not "
          (definite-article (type-name type)) "\", " arg ");\n"))
+       ((eq? 'sexp base-type))
+       ((string-type? type)
+        (write-validator arg 'string))
        (else
-        (if (not (eq? 'sexp (type-base type)))
-            (display "WARNING: don't know how to validate: " (current-error-port)))
+        (display "WARNING: don't know how to validate: " (current-error-port))
         (write type (current-error-port))
         (newline (current-error-port))
         (write type)))))))
@@ -588,7 +649,9 @@
          (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars))
          (sexps (if preserve-res? '() '("res")))
          (num-gc-vars (length gc-vars))
-         (ints (if (or return-res? (eq? 'non-null-string (type-base ret-type)))
+         (ints (if (or return-res?
+                       (memq (type-base ret-type)
+                             '(non-null-string non-null-pointer)))
                    '()
                    '("err")))
          (ints (if (or (array-type? ret-type)
@@ -596,8 +659,9 @@
                        (any array-type? scheme-args))
                    (cons "i" ints)
                    ints)))
-    (if(eq? 'non-null-string (type-base ret-type))
-        (cat "  char *err;\n"))
+    (case (type-base ret-type)
+      ((non-null-string) (cat "  char *err;\n"))
+      ((non-null-pointer) (cat "  void *err;\n")))
     (cond
      ((pair? ints)
       (cat "  int " (car ints))
@@ -624,6 +688,13 @@
      (append (if (type-array ret-type) (list ret-type) '())
              results
              (remove type-result? (filter type-array scheme-args))))
+    (for-each
+     (lambda (arg)
+       (cond
+        ((and (type-pointer? arg) (basic-type? arg))
+         (cat "  " (type-c-name (type-base arg))
+              " tmp" (type-index arg) ";\n"))))
+     scheme-args)
     (cond
      ((pair? sexps)
       (cat "  sexp " (car sexps))
@@ -657,7 +728,7 @@
               ";\n"
               "  tmp" (type-index a) " = buf" (type-index a) ";\n"))))
      (cond
-      ((and (not (type-result? a)) (type-array a))
+      ((and (not (type-result? a)) (type-array a) (not (string-type? a)))
        (if (not (number? (type-array a)))
            (cat "  tmp" (type-index a)
                 " = (" (type-c-name (type-base a)) "*) malloc("
@@ -670,9 +741,45 @@
             ";\n"
             "  }\n")
        (if (not (number? (type-array a)))
-           (cat "  tmp" (type-index a) "[i] = NULL;\n")))))
+           (cat "  tmp" (type-index a) "[i] = NULL;\n")))
+      ((and (type-result? a) (not (basic-type? a))
+            (not (type-free? a)) (not (type-auto-expand? a))
+            (or (not (type-array a))
+                (not (integer? (get-array-length func a)))))
+       (cat "  tmp" (type-index a) " = malloc(sizeof(tmp" (type-index a)
+            "[0]));\n"))
+      ((and (type-pointer? a) (basic-type? a))
+       (cat "  tmp" (type-index a) " = "
+            (lambda ()
+              (scheme->c-converter
+               a
+               (string-append "arg" (type-index-string a))))
+            ";\n"))))
    (func-c-args func)))
 
+(define (write-actual-parameter func arg)
+  (cond
+   ((and (not (type-default? arg)) (type-value arg))
+    => (lambda (x)
+         (cond
+          ((any (lambda (y)
+                  (and (type-array y)
+                       (eq? x (get-array-length func y))))
+                (func-c-args func))
+           => (lambda (y) (cat "len" (type-index y))))
+          (else (write x)))))
+   ((or (type-result? arg) (type-array arg))
+    (cat (if (or (type-pointer? arg) (type-free? arg) (basic-type? arg))
+             "&"
+             "")
+         "tmp" (type-index arg)))
+   ((and (type-pointer? arg) (basic-type? arg))
+    (cat "&tmp" (type-index arg)))
+   (else
+    (scheme->c-converter
+     arg
+     (string-append "arg" (type-index-string arg))))))
+
 (define (write-call func)
   (let ((ret-type (func-ret-type func))
         (c-name (func-c-name func))
@@ -691,23 +798,7 @@
        (for-each
         (lambda (arg)
           (if (> (type-index arg) 0) (cat ", "))
-          (cond
-           ((or (type-result? arg) (type-array arg))
-            (cat (if (or (type-pointer? arg) (type-array arg)) "" "&")
-                 "tmp" (type-index arg)))
-           ((type-value arg)
-            => (lambda (x)
-                 (cond
-                  ((any (lambda (y)
-                          (and (type-array y)
-                               (eq? x (get-array-length func y))))
-                        (func-c-args func))
-                   => (lambda (y) (cat "len" (type-index y))))
-                  (else (write x)))))
-           (else
-            (scheme->c-converter
-             arg
-             (string-append "arg" (type-index-string arg))))))
+          (write-actual-parameter func arg))
         c-args)
        (cat ")"))
      (cond
@@ -762,7 +853,10 @@
         (results (func-results func)))
     (if error-res?
         (cat "  if ("
-             (if (eq? 'non-null-string (type-base (func-ret-type func))) "!" "")
+             (if (memq (type-base (func-ret-type func))
+                       '(non-null-string non-null-pointer))
+                 "!"
+                 "")
              "err) {\n"
              (cond
               ((any type-auto-expand? (func-c-args func))
@@ -847,10 +941,21 @@
        "}\n\n"))
 
 (define (write-func-binding func)
-  (cat "  sexp_define_foreign(ctx, env, "
-       (lambda () (write (symbol->string (func-scheme-name func))))
-       ", " (length (func-scheme-args func))  ", "
-       (func-stub-name func) ");\n"))
+  (let ((default (and (pair? (func-scheme-args func))
+                      (type-default? (car (reverse (func-scheme-args func))))
+                      (car (reverse (func-scheme-args func))))))
+    (cat (if default
+             "  sexp_define_foreign_opt(ctx, env, "
+             "  sexp_define_foreign(ctx, env, ")
+         (lambda () (write (symbol->string (func-scheme-name func))))
+         ", " (length (func-scheme-args func))  ", "
+         (func-stub-name func)
+         (if default ", " "")
+         (if default
+             (lambda ()
+               (c->scheme-converter default (type-value default)))
+             "")
+         ");\n")))
 
 (define (write-type type)
   (let ((name (car type))
@@ -975,6 +1080,13 @@
                        *funcs*)))))))
      type)))
 
+(define (write-const const)
+  (let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const)))
+        (c-name (if (pair? (cadr const)) (cadadr const) (mangle (cadr const)))))
+    (cat "  name = sexp_intern(ctx, \"" scheme-name "\");\n"
+         "  sexp_env_define(ctx, env, name, tmp="
+         (lambda () (c->scheme-converter (car const) c-name)) ");\n")))
+
 (define (write-utilities)
   (define (input-env-string? x)
     (and (eq? 'env-string (type-base x)) (not (type-result? x))))
@@ -1001,6 +1113,7 @@
   (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-const *consts*)
   (for-each write-type *types*)
   (for-each write-func-binding *funcs*)
   (cat "  sexp_gc_release2(ctx);\n"