[plt-scheme] ipc among mzscheme processes

Anton van Straaten wrote:

> Have you seen SCOP:
> http://www.srcf.ucam.org/~dmi1000/scop/
> 
> It has bindings for Scheme, C, C++, and Java.  The Scheme bindings are
> courtesy of Sven Hartrumpf:
> http://pi7.fernuni-hagen.de/hartrumpf/scop/
> 
> It seems to be for Chicken & Bigloo, but the code looks pretty compact and
> straightforward - porting to PLT should be trivial.

Here's a cute little port...  You'll need scop_chicken.scm and scopx.scm from
Sven Hartrumpf's site.

(module scop mzscheme
  (require (lib "include.ss")
           (lib "cffi.ss" "compiler")
           "chicken.ss")
  (provide (all-defined))         ;; all the primitives get provided as well.

  (c-declare "#include <scop.h>")
  (include "scop_chicken.scm"))   ;; recursively includes scopsx.scm

This relies on the following two modules for translating a very tiny subset of
Chicken's `foreign-lambda' syntax to the PLT `c-lambda' syntax.

(module chicken mzscheme
  (require (lib "cffi.ss" "compiler"))
  (require-for-syntax "chicken-transformer.ss")
  (provide (all-defined))

  (define-syntax declare ;; ignore `declare's.

    (syntax-rules ()
      ((_ e1 e2 ...) #f)))

  (define-syntax foreign-lambda ;; to c-lambda rewrite rule.

    (lambda (stx)
      (syntax-case stx ()
        ((_ return:type f param1:type ...)
         #`(c-lambda
            #,(map (compose type-map syntax-object->datum)
                   (syntax->list (syntax (param1:type ...))))
            #,(type-map (syntax-object->datum (syntax return:type)))
            f)))))

  (define (null-pointer) #f))

(module chicken-transformer mzscheme
  (provide type-map compose)
  (define (compose f g) (lambda (x) (f (g x))))
  (define (type-map t)
    (if (pair? t)
        (case (car t)
         ((pointer c-pointer)
          `(pointer ,(symbol->string (cadr t))))
         (else (error "type not supported" t)))
        (case t
          ((c-string)  'char-string)
          ((c-pointer) 'pointer)
          ((c-string c-string*) 'char-string)
          ((nonnull-c-string)   'nonnull-char-string)
          (else t)))))

-d