;;; Foreign function interface for CLISP
;;; Bruno Haible 13.7.1994

;; A foreign function description is written as a Lisp file,
;; and when compiled it produces a .c file which is then compiled
;; by the C compiler and may be linked together with lisp.a.

;; A foreign function description looks like this:
;; (WITHIN-EXTERNAL-MODULE module-name {form}*)
;; The module name is an arbitrary string, but by convention it will bear
;; some relation with the name of the Lisp file containing this.
;; (Foreign function modules are entirely orthogonal to the package system.)
;; The forms are normal Lisp forms, as well as special FFI forms.

;; These are the special FFI forms. We have taken a pragmatic approach:
;; the only foreign language we support for now is C.

;; (DEF-C-VAR name {option}*)
;;   option ::=
;;       (:name <c-name>)
;;     | (:type <c-type>)
;;     | (:read-only <boolean>)
;;
;; (DEF-CALL-OUT name {option}*)
;;   option ::=
;;       (:name <c-name>)
;;     | (:arguments {(arg-name <c-type> [<param-mode>])}*)
;;     | (:return-type <c-type>)
;;     | (:callback <boolean>)
;;
;; (DEF-CALL-IN name {option}*)
;;   option ::=
;;       (:name <c-name>)
;;     | (:arguments {(arg-name <c-type> [<param-mode>])}*)
;;     | (:return-type c-type)
;;
;; name is any Lisp symbol.
;;
;; c-name is a string.
;;
;; A <param-mode> is
;; either :READ-ONLY -- the caller passes information to the callee
;; or :WRITE-ONLY -- the callee passes information back to the caller on return
;; or :READ-WRITE -- both.
;;
;; A <c-type> is either a <simple-c-type> or the name of a type defined by
;; DEF-C-TYPE.
;;
;; The simple C types are these:
;;
;;  Lisp name     Lisp equiv           C equiv        ILU equiv
;;   nil           NIL                  void                             (o)
;;   boolean       (MEMBER NIL T)       int            BOOLEAN
;;   character     STRING-CHAR          char           SHORT CHARACTER
;;   char          INTEGER              signed char
;;   uchar         INTEGER              unsigned char
;;   short         INTEGER              short
;;   ushort        INTEGER              unsigned short
;;   int           INTEGER              int
;;   uint          INTEGER              unsigned int
;;   long          INTEGER              long
;;   ulong         INTEGER              unsigned long
;;   uint8         (UNSIGNED-BYTE 8)    uint8          BYTE
;;   sint8         (SIGNED-BYTE 8)      sint8
;;   uint16        (UNSIGNED-BYTE 16)   uint16         SHORT CARDINAL
;;   sint16        (SIGNED-BYTE 16)     sint16         SHORT INTEGER
;;   uint32        (UNSIGNED-BYTE 32)   uint32         CARDINAL
;;   sint32        (SIGNED-BYTE 32)     sint32         INTEGER
;;   uint64        (UNSIGNED-BYTE 64)   uint64         LONG CARDINAL     (*)
;;   sint64        (SIGNED-BYTE 64)     sint64         LONG INTEGER      (*)
;;   single-float  SINGLE-FLOAT         float
;;   double-float  DOUBLE-FLOAT         double
;; (o) as a result type only.
;; (*) does not work on all platforms.
;;
;; (DEF-C-TYPE name type-description)
;;   type-description ::=
;;       <c-type>
;;     | C-STRING
;;     | (C-STRUCT (<ident> <c-type>)*)
;;     | (C-UNION (<ident> <c-type>)*)
;;     | (C-ARRAY <c-type> dimensions)
;;         dimensions ::= number | ({number}*)
;;     | (C-PTR <c-type>)

(in-package "FFI")

(export '(within-external-module
          def-c-var def-call-out def-call-in def-c-type
          nil boolean character char uchar short ushort int uint long ulong
          uint8 sint8 uint16 sint16 uint32 sint32 uint64 sint64
          single-float double-float
          c-string c-struct c-union c-array c-ptr
)        )

; The name of the FFI module being compiled:
(defvar *ffi-module* nil)

(defmacro within-external-module (module-name &body body)
  `(COMPILER-LET (*FFI-MODULE*)
     (EVAL-WHEN (COMPILE) (START-MODULE ',module-name))
     (MULTIPLE-VALUE-PROG1
       (PROGN ,@body)
       (EVAL-WHEN (COMPILE) (FINISH-MODULE))
   ) )
)

; We put everything into a structure, so that we need to bind only
; a single variable at compile time.
(defstruct ffi-module
  name
  c-name
  types
  output-stream
  (subr-list '())
  (object-list '())
)
(define-symbol-macro *name* (ffi-module-name *ffi-module*))
(define-symbol-macro *c-name* (ffi-module-c-name *ffi-module*))
(define-symbol-macro *types* (ffi-module-types *ffi-module*))
(define-symbol-macro *output-stream* (ffi-module-output-stream *ffi-module*))
(define-symbol-macro *subr-list* (ffi-module-subr-list *ffi-module*))
(define-symbol-macro *object-list* (ffi-module-object-list *ffi-module*))

; checks whether a string is a valid C identifier
(defun c-ident-p (name)
  (and (every #'(lambda (ch)
                  (and (standard-char-p ch)
                       (or (alphanumericp ch) (eql ch #\_)) ; don't allow #\$
                ) )
              name
       )
       (not (digit-char-p (char name 0)))
) )

; Convert a Lisp name to a C name.
; (Doesn't really matter how. This must just be a deterministic function.)
(defun to-c-name (name)
  (setq name (string name))
  (unless (some #'lower-case-p name) (setq name (string-downcase name)))
  (with-output-to-string (s)
    (map nil
         #'(lambda (ch)
             (if (and (standard-char-p ch) (alphanumericp ch))
               (write-char ch s)
               (format s "_~2X" (char-code ch))
           ) )
         name
) ) )

; Given a string, return it in C syntax.
(defun to-c-string (string)
  (with-output-to-string (s)
    (write-char #\" s)
    (map nil #'(lambda (c)
                 (cond ((eql c #\Null)
                        (error (DEUTSCH "Kann String ~S nicht nach C abbilden, denn es enthält ein Zeichen ~S."
                                ENGLISH "Cannot map string ~S to C since it contains a character ~S"
                                FRANCAIS "Ne peux convertir la chaîne ~S en langage C à cause d'un caractère ~S.")
                               string c
                       ))
                       ((eq c #\Newline)
                        (write-char #\\ s) (write-char #\n s)
                       )
                       ((or (eql c #\") (eql c #\\))
                        (write-char #\\ s) (write-char c s)
                       )
                       (t (write-char c s))
               ) )
             string
    )
    (write-char #\" s)
) )

; The info present for a C type.
(defstruct c-type
  name
  lisp-type
  c-name
  lisp2c-checker ; function that outputs the code to check whether an object
                 ; belongs to the correct Lisp type
  lisp2c-converter ; function that outputs the code to convert to C
  c2lisp-converter ; function that outputs the code to convert from C
)
#|
(defparameter simple-c-types
  (list
    (make-c-type
      :name 'nil
      :lisp-type 'NIL
      :c-name "void"
    )
    (make-c-type
      :name 'boolean
      :lisp-type '(MEMBER NIL T)
      :c-name "int"
      :lisp2c-checker
        #'(lambda (obj s)
            (declare (ignore obj s))
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "!nullp(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "(~A) ? T : NIL" val)
          )
    )
    (make-c-type
      :name 'character
      :lisp-type 'STRING-CHAR
      :c-name "char"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_string_char_p(~A);" obj)
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "(char)char_code(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "code_char((unsigned char)(~A))" val)
          )
    )
    (make-c-type
      :name 'uchar
      :lisp-type 'INTEGER
      :c-name "UBYTE"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_uint8(~A);" obj)
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "I_to_uint8(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "uint8_to_I(~A)" val)
          )
    )
    (make-c-type
      :name 'char
      :lisp-type 'INTEGER
      :c-name "BYTE"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_sint8(~A);" obj)
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "I_to_sint8(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "sint8_to_I(~A)" val)
          )
    )
    (make-c-type
      :name 'ushort
      :lisp-type 'INTEGER
      :c-name "unsigned short"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_uint16(~A);" obj)
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "I_to_uint16(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "uint16_to_I(~A)" val)
          )
    )
    (make-c-type
      :name 'short
      :lisp-type 'INTEGER
      :c-name "short"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_sint16(~A);" obj)
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "I_to_sint16(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "sint16_to_I(~A)" val)
          )
    )
    (make-c-type
      :name 'uint
      :lisp-type 'INTEGER
      :c-name "unsigned int"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_uint(~A);" obj)
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "I_to_uint(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "uint_to_I(~A)" val)
          )
    )
    (make-c-type
      :name 'int
      :lisp-type 'INTEGER
      :c-name "int"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_sint(~A);" obj)
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "I_to_sint(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "sint_to_I(~A)" val)
          )
    )
    (make-c-type
      :name 'ulong
      :lisp-type 'INTEGER
      :c-name "unsigned long"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_ulong(~A);" obj)
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "I_to_ulong(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "ulong_to_I(~A)" val)
          )
    )
    (make-c-type
      :name 'long
      :lisp-type 'INTEGER
      :c-name "long"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_slong(~A);" obj)
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "I_to_slong(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "slong_to_I(~A)" val)
          )
    )
    (make-c-type
      :name 'uint8
      :lisp-type '(UNSIGNED-BYTE 8)
      :c-name "uint8"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_uint8(~A);" obj)
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "I_to_uint8(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "uint8_to_I(~A)" val)
          )
    )
    (make-c-type
      :name 'sint8
      :lisp-type '(SIGNED-BYTE 8)
      :c-name "sint8"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_sint8(~A);" obj)
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "I_to_sint8(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "sint8_to_I(~A)" val)
          )
    )
    (make-c-type
      :name 'uint16
      :lisp-type '(UNSIGNED-BYTE 16)
      :c-name "uint16"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_uint16(~A);" obj)
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "I_to_uint16(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "uint16_to_I(~A)" val)
          )
    )
    (make-c-type
      :name 'sint16
      :lisp-type '(SIGNED-BYTE 16)
      :c-name "sint16"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_sint16(~A);" obj)
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "I_to_sint16(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "sint16_to_I(~A)" val)
          )
    )
    (make-c-type
      :name 'uint32
      :lisp-type '(UNSIGNED-BYTE 32)
      :c-name "uint32"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_uint32(~A);" obj)
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "I_to_uint32(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "uint32_to_I(~A)" val)
          )
    )
    (make-c-type
      :name 'sint32
      :lisp-type '(SIGNED-BYTE 32)
      :c-name "sint32"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_sint32(~A);" obj)
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "I_to_sint32(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "sint32_to_I(~A)" val)
          )
    )
    (make-c-type
      :name 'uint64
      :lisp-type '(UNSIGNED-BYTE 64)
      :c-name "uint64"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_uint64(~A);" obj)
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "I_to_uint64(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "uint64_to_I(~A)" val)
          )
    )
    (make-c-type
      :name 'sint64
      :lisp-type '(SIGNED-BYTE 64)
      :c-name "sint64"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_sint64(~A);" obj)
          )
      :lisp2c-converter
        #'(lambda (obj s)
            (format s "I_to_sint64(~A)" obj)
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "sint64_to_I(~A)" val)
          )
    )
    (make-c-type
      :name 'single-float
      :lisp-type 'SINGLE-FLOAT
      :c-name "float"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_ffloat(~A);" obj)
          )
      :lisp2c-converter
        "FF_to_c_float(~A,(ffloatjanus*)&~A)" ??
      :c2lisp-converter
        #'(lambda (val s)
            (format s "c_float_to_FF((ffloatjanus*)&~A)" val)
          )
    )
    (make-c-type
      :name 'double-float
      :lisp-type 'DOUBLE-FLOAT
      :c-name "double"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "check_dfloat(~A);" obj)
          )
      :lisp2c-converter
        "DF_to_c_double(~A,(dfloatjanus*)&~A)" ??
      :c2lisp-converter
        #'(lambda (val s)
            (format s "c_double_to_DF((dfloatjanus*)&~A)" val)
          )
    )
    (make-c-type
      :name 'c-string
      :lisp-type 'STRING
      :c-name "char*"
      :lisp2c-checker
        #'(lambda (obj s)
            (format s "~A = string_to_asciz(~A);" obj obj) ; GC ??
          )
      :lisp2c-converter
        #'(lambda (obj s)
            ;Trick with_string_0 wie in stdwin.d ??
          )
      :c2lisp-converter
        #'(lambda (val s)
            (format s "asciz_to_string(~A)" val)
          )
    )
) )

(defun lookup-c-type (name)
  (or (find name simple-c-types :key #'c-type-name)
      (gethash name *types*)
      (error (DEUTSCH "Unbekannter FFI-Typ ~S."
              ENGLISH "Unknown FFI type ~S"
              FRANCAIS "Type de FFI inconnu: ~S")
             name
      )
) )

(defun parse-c-type (typespec &key maybe-nil maybe-incomplete)
  (if (atom typespec)
    (if (symbolp typespec)
      (progn
        (when (and (eq typespec 'nil) (not maybe-nil))
          (error (DEUTSCH "FFI-Typ NIL ist hier nicht erlaubt."
                  ENGLISH "FFI type NIL is not allowed here."
                  FRANCAIS "Type de FFI NIL n'est pas permis ici.")
        ) )
        (or (find typespec simple-c-types :key #'c-type-name)
            (gethash typespec *types*)
            (if maybe-incomplete
              (make-c-type
                :name typespec
                :lisp-type 'NIL
                :c-name (to-c-name typespec)
              )
              (error (DEUTSCH "Unvollständiger FFI-Typ ~S ist hier nicht erlaubt."
                      ENGLISH "Incomplete FFI type ~S is not allowed here."
                      FRANCAIS "Le type de FFI ~S n'est pas complet, ce qui n'est pas permis ici.")
                     typespec
      ) )   ) )
      (error (DEUTSCH "FFI-Typ muß ein Symbol sein, nicht ~S."
              ENGLISH "FFI type should be a symbol, not ~S"
              FRANCAIS "Un type FFi doit être un symbole et non ~S")
             typespec
    ) )
    (case (first typespec)
      (C-STRUCT
      (C-UNION
      (C-ARRAY
      (C-PTR



;;     | (C-STRUCT (<ident> <c-type>)*)
;;     | (C-UNION (<ident> <c-type>)*)
;;     | (C-ARRAY <c-type> dimensions)
;;         dimensions ::= number | ({number}*)
;;     | (C-PTR <c-type>)

;; (DEF-C-TYPE name type-description)
;;   type-description ::=
;;       <c-type>
;;     | C-STRING
;;     | (C-STRUCT (<ident> <c-type>)*)
;;     | (C-UNION (<ident> <c-type>)*)
;;     | (C-ARRAY <c-type> dimensions)
;;         dimensions ::= number | ({number}*)
;;     | (C-PTR <c-type>)
;;
;; (DEF-C-VAR name {option}*)
;;   option ::=
;;       (:name <c-name>)
;;     | (:type <c-type>)
;;     | (:read-only <boolean>)
;;
;; (DEF-CALL-OUT name {option}*)
;;   option ::=
;;       (:name <c-name>)
;;     | (:arguments {(arg-name <c-type> [<param-mode>])}*)
;;     | (:return-type <c-type>)
;;     | (:callback <boolean>)
;;
;; (DEF-CALL-IN name {option}*)
;;   option ::=
;;       (:name <c-name>)
;;     | (:arguments {(arg-name <c-type> [<param-mode>])}*)
;;     | (:return-type c-type)
;;
;; name is any Lisp symbol.
;;
;; c-name is a string.
;;
;; A <param-mode> is
;; either :READ-ONLY -- the caller passes information to the callee
;; or :WRITE-ONLY -- the callee passes information back to the caller on return
;; or :READ-WRITE -- both.
;;

(defun parse-foreign-name (language name)
  (unless (stringp name)
    (error (DEUTSCH "Der Name muß ein String sein, nicht ~S."
            ENGLISH "The name must be a string, not ~S"
            FRANCAIS "Le nom doit être une chaîne et non ~S.")
           name
  ) )
  (when (or (equal language "C") (equal language "C++"))
    (return-from parse-foreign-name
      (if (c-ident-p name)
        name
        (error (DEUTSCH "Der Name ~S ist kein gültiger C-Identifier."
                ENGLISH "The name ~S is not a valid C identifier"
                FRANCAIS "Le nom ~S n'est pas valable en langage C.")
               name
  ) ) ) )
)

(defun parse-foreign (caller lisp-name arglist)
  (if (and (consp arglist) (eq (first arglist) ':FOREIGN))
    (if (and (consp (cdr arglist)) (listp (second arglist))
             (eql (second arglist) 2)
        )
      (let ((language (first (second arglist)))
            (name (second (second arglist))))
        (values (parse-foreign-language language)
                (parse-foreign-name language name)
                (cddr arglist)
      ) )
      (error (DEUTSCH "~S ~S: Syntaxfehler nach ~S."
              ENGLISH "~S ~S: syntax error after ~S"
              FRANCAIS "~S ~S : Syntaxe inadmissible après ~S.")
             caller lisp-name ':FOREIGN
    ) )
    (values "C" (to-c-name lisp-name) arglist)
) )

(defun foreign-type-info (type)
  (if (eq type 'nil)
    (error (DEUTSCH "FFI-Typ NIL ist hier nicht erlaubt."
            ENGLISH "FFI type NIL is not allowed here"
            FRANCAIS "Le type de FFI NIL n'est pas permis ici.")
    )
    (foreign-rtype-info type)
) )

(defmacro define-external-variable (name &rest args)
  (multiple-value-bind (foreign-language foreign-name arglist)
      (parse-foreign 'define-external-variable name args)
    (declare (ignore foreign-language))
    (unless (and (consp arglist) (null (cdr arglist)))
      (error (DEUTSCH "~S ~S: Syntaxfehler."
              ENGLISH "~S ~S: syntax error"
              FRANCAIS "~S ~S : Syntaxe inadmissible.")
             'define-external-variable name
    ) )
    (let* ((getter-function-name (sys::symbol-suffix name "%GETTER%"))
           (setter-function-name (sys::symbol-suffix name "%SETTER%"))
           (result-type (first arglist))
           (result-type-info (foreign-type-info result-type))
           (code
             (concatenate 'string
               (format nil "~%LISPFUNN(~A,0)~%{ extern ~A ~A; value1 = ~?; mv_count=1; }~%"
                           (to-c-name getter-function-name)
                           (third result-type-info) foreign-name
                           (seventh result-type-info) (list foreign-name)
               )
               (format nil "~%LISPFUNN(~A,1)~%{ extern ~A ~A; var reg1 object obj = popSTACK(); ~? ~A = ~?; value1 = obj; mv_count=1; }~%"
                           (to-c-name setter-function-name)
                           (third result-type-info) foreign-name
                           (fourth result-type-info) (list "obj")
                           foreign-name (fifth result-type-info) (list "obj")
             ) )
           )
           (subrs (list (list getter-function-name "LISPFUNN(~A,0)" (to-c-name getter-function-name))
                        (list setter-function-name "LISPFUNN(~A,1)" (to-c-name setter-function-name))
           )      )
          )
      `(PROGN
         (EVAL-WHEN (COMPILE)
           (WRITE-STRING ',code *FFI-OUTPUT-STREAM*)
           (NOTE-SUBRS ',subrs)
         )
         (DEFSETF ,getter-function-name ,setter-function-name)
         (DEFINE-SYMBOL-MACRO ,name (,getter-function-name))
         ',name
       )
) ) )

(defun note-subrs (subr-list)
  (setf (module-info-subr-list *ffi-module*)
        (revappend subr-list (module-info-subr-list *ffi-module*))
) )

(defun start-module (module-name)
  (setq *ffi-module*
        (make-module-info :name module-name
                          :c-name (to-c-name module-name)
  )     )
  (setq *ffi-output-stream* (open (merge-pathnames '#".c" module-name) :direction :output))
  (format *ffi-output-stream* "#include \"clisp.h\"~%~%")
)

(defun finish-module ()
  (setf (module-info-subr-list *ffi-module*)
        (nreverse (module-info-subr-list *ffi-module*))
  )
  (setf (module-info-object-list *ffi-module*)
        (nreverse (module-info-object-list *ffi-module*))
  )
  (format *ffi-output-stream* "~%#undef LISPFUN~%#define LISPFUN LISPFUN_F~%")
  ; output subr_tab:
  (format *ffi-output-stream*
          "~%subr_ module__~A__subr_tab[~D]"
          (module-info-c-name *ffi-module*)
          (max (length (module-info-subr-list *ffi-module*)) 1)
  )
  (when (module-info-subr-list *ffi-module*)
    (format *ffi-output-stream* " = {~%")
    (dolist (subr (module-info-subr-list *ffi-module*))
      (apply #'format *ffi-output-stream* "  ~@?~%" (cdr subr))
    )
    (format *ffi-output-stream* "}")
  )
  (format *ffi-output-stream* ";~%")
  (format *ffi-output-stream*
          "~%uintC module__~A__subr_tab_size = ~D;~%"
          (module-info-c-name *ffi-module*)
          (length (module-info-subr-list *ffi-module*))
  )
  ; output object_tab:
  (format *ffi-output-stream*
          "~%object module__~A__object_tab[~D];~%"
          (module-info-c-name *ffi-module*)
          (max (length (module-info-object-list *ffi-module*)) 1)
  )
  (format *ffi-output-stream*
          "~%uintC module__~A__object_tab_size = ~D;~%"
          (module-info-c-name *ffi-module*)
          (length (module-info-object-list *ffi-module*))
  )
  ; output subr_tab_initdata:
  (format *ffi-output-stream*
          "~%subr_initdata module__~A__subr_tab_initdata[~D]"
          (module-info-c-name *ffi-module*)
          (max (length (module-info-subr-list *ffi-module*)) 1)
  )
  (when (module-info-subr-list *ffi-module*)
    (format *ffi-output-stream* " = {~%")
    (dolist (subr (module-info-subr-list *ffi-module*))
      (format *ffi-output-stream*
              "{ ~A, ~A },"
              (let ((pack (symbol-package (car subr))))
                (if pack (to-c-string (package-name pack)) "NULL")
              )
              (to-c-string (symbol-name (car subr)))
    ) )
    (format *ffi-output-stream* "}")
  )
  (format *ffi-output-stream* ";~%")
  ; output the init function:
  (format *ffi-output-stream*
          "~%void module__~A__init_function (module) var reg3 module_* module; {~%"
          (module-info-c-name *ffi-module*)
  )
  (format *ffi-output-stream* "}~%")
  ; done.
  (close *ffi-output-stream*)
)
|#
