home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / D / CLISP / CLISPSRC.TAR / clisp-1995-01-01 / src / foreign.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-07-13  |  24.4 KB  |  808 lines
  1. ;;; Foreign function interface for CLISP
  2. ;;; Bruno Haible 13.7.1994
  3.  
  4. ;; A foreign function description is written as a Lisp file,
  5. ;; and when compiled it produces a .c file which is then compiled
  6. ;; by the C compiler and may be linked together with lisp.a.
  7.  
  8. ;; A foreign function description looks like this:
  9. ;; (WITHIN-EXTERNAL-MODULE module-name {form}*)
  10. ;; The module name is an arbitrary string, but by convention it will bear
  11. ;; some relation with the name of the Lisp file containing this.
  12. ;; (Foreign function modules are entirely orthogonal to the package system.)
  13. ;; The forms are normal Lisp forms, as well as special FFI forms.
  14.  
  15. ;; These are the special FFI forms. We have taken a pragmatic approach:
  16. ;; the only foreign language we support for now is C.
  17.  
  18. ;; (DEF-C-VAR name {option}*)
  19. ;;   option ::=
  20. ;;       (:name <c-name>)
  21. ;;     | (:type <c-type>)
  22. ;;     | (:read-only <boolean>)
  23. ;;
  24. ;; (DEF-CALL-OUT name {option}*)
  25. ;;   option ::=
  26. ;;       (:name <c-name>)
  27. ;;     | (:arguments {(arg-name <c-type> [<param-mode>])}*)
  28. ;;     | (:return-type <c-type>)
  29. ;;     | (:callback <boolean>)
  30. ;;
  31. ;; (DEF-CALL-IN name {option}*)
  32. ;;   option ::=
  33. ;;       (:name <c-name>)
  34. ;;     | (:arguments {(arg-name <c-type> [<param-mode>])}*)
  35. ;;     | (:return-type c-type)
  36. ;;
  37. ;; name is any Lisp symbol.
  38. ;;
  39. ;; c-name is a string.
  40. ;;
  41. ;; A <param-mode> is
  42. ;; either :READ-ONLY -- the caller passes information to the callee
  43. ;; or :WRITE-ONLY -- the callee passes information back to the caller on return
  44. ;; or :READ-WRITE -- both.
  45. ;;
  46. ;; A <c-type> is either a <simple-c-type> or the name of a type defined by
  47. ;; DEF-C-TYPE.
  48. ;;
  49. ;; The simple C types are these:
  50. ;;
  51. ;;  Lisp name     Lisp equiv           C equiv        ILU equiv
  52. ;;   nil           NIL                  void                             (o)
  53. ;;   boolean       (MEMBER NIL T)       int            BOOLEAN
  54. ;;   character     STRING-CHAR          char           SHORT CHARACTER
  55. ;;   char          INTEGER              signed char
  56. ;;   uchar         INTEGER              unsigned char
  57. ;;   short         INTEGER              short
  58. ;;   ushort        INTEGER              unsigned short
  59. ;;   int           INTEGER              int
  60. ;;   uint          INTEGER              unsigned int
  61. ;;   long          INTEGER              long
  62. ;;   ulong         INTEGER              unsigned long
  63. ;;   uint8         (UNSIGNED-BYTE 8)    uint8          BYTE
  64. ;;   sint8         (SIGNED-BYTE 8)      sint8
  65. ;;   uint16        (UNSIGNED-BYTE 16)   uint16         SHORT CARDINAL
  66. ;;   sint16        (SIGNED-BYTE 16)     sint16         SHORT INTEGER
  67. ;;   uint32        (UNSIGNED-BYTE 32)   uint32         CARDINAL
  68. ;;   sint32        (SIGNED-BYTE 32)     sint32         INTEGER
  69. ;;   uint64        (UNSIGNED-BYTE 64)   uint64         LONG CARDINAL     (*)
  70. ;;   sint64        (SIGNED-BYTE 64)     sint64         LONG INTEGER      (*)
  71. ;;   single-float  SINGLE-FLOAT         float
  72. ;;   double-float  DOUBLE-FLOAT         double
  73. ;; (o) as a result type only.
  74. ;; (*) does not work on all platforms.
  75. ;;
  76. ;; (DEF-C-TYPE name type-description)
  77. ;;   type-description ::=
  78. ;;       <c-type>
  79. ;;     | C-STRING
  80. ;;     | (C-STRUCT (<ident> <c-type>)*)
  81. ;;     | (C-UNION (<ident> <c-type>)*)
  82. ;;     | (C-ARRAY <c-type> dimensions)
  83. ;;         dimensions ::= number | ({number}*)
  84. ;;     | (C-PTR <c-type>)
  85.  
  86. (in-package "FFI")
  87.  
  88. (export '(within-external-module
  89.           def-c-var def-call-out def-call-in def-c-type
  90.           nil boolean character char uchar short ushort int uint long ulong
  91.           uint8 sint8 uint16 sint16 uint32 sint32 uint64 sint64
  92.           single-float double-float
  93.           c-string c-struct c-union c-array c-ptr
  94. )        )
  95.  
  96. ; The name of the FFI module being compiled:
  97. (defvar *ffi-module* nil)
  98.  
  99. (defmacro within-external-module (module-name &body body)
  100.   `(COMPILER-LET (*FFI-MODULE*)
  101.      (EVAL-WHEN (COMPILE) (START-MODULE ',module-name))
  102.      (MULTIPLE-VALUE-PROG1
  103.        (PROGN ,@body)
  104.        (EVAL-WHEN (COMPILE) (FINISH-MODULE))
  105.    ) )
  106. )
  107.  
  108. ; We put everything into a structure, so that we need to bind only
  109. ; a single variable at compile time.
  110. (defstruct ffi-module
  111.   name
  112.   c-name
  113.   types
  114.   output-stream
  115.   (subr-list '())
  116.   (object-list '())
  117. )
  118. (define-symbol-macro *name* (ffi-module-name *ffi-module*))
  119. (define-symbol-macro *c-name* (ffi-module-c-name *ffi-module*))
  120. (define-symbol-macro *types* (ffi-module-types *ffi-module*))
  121. (define-symbol-macro *output-stream* (ffi-module-output-stream *ffi-module*))
  122. (define-symbol-macro *subr-list* (ffi-module-subr-list *ffi-module*))
  123. (define-symbol-macro *object-list* (ffi-module-object-list *ffi-module*))
  124.  
  125. ; checks whether a string is a valid C identifier
  126. (defun c-ident-p (name)
  127.   (and (every #'(lambda (ch)
  128.                   (and (standard-char-p ch)
  129.                        (or (alphanumericp ch) (eql ch #\_)) ; don't allow #\$
  130.                 ) )
  131.               name
  132.        )
  133.        (not (digit-char-p (char name 0)))
  134. ) )
  135.  
  136. ; Convert a Lisp name to a C name.
  137. ; (Doesn't really matter how. This must just be a deterministic function.)
  138. (defun to-c-name (name)
  139.   (setq name (string name))
  140.   (unless (some #'lower-case-p name) (setq name (string-downcase name)))
  141.   (with-output-to-string (s)
  142.     (map nil
  143.          #'(lambda (ch)
  144.              (if (and (standard-char-p ch) (alphanumericp ch))
  145.                (write-char ch s)
  146.                (format s "_~2X" (char-code ch))
  147.            ) )
  148.          name
  149. ) ) )
  150.  
  151. ; Given a string, return it in C syntax.
  152. (defun to-c-string (string)
  153.   (with-output-to-string (s)
  154.     (write-char #\" s)
  155.     (map nil #'(lambda (c)
  156.                  (cond ((eql c #\Null)
  157.                         (error (DEUTSCH "Kann String ~S nicht nach C abbilden, denn es enthΣlt ein Zeichen ~S."
  158.                                 ENGLISH "Cannot map string ~S to C since it contains a character ~S"
  159.                                 FRANCAIS "Ne peux convertir la chaεne ~S en langage C α cause d'un caractΦre ~S.")
  160.                                string c
  161.                        ))
  162.                        ((eq c #\Newline)
  163.                         (write-char #\\ s) (write-char #\n s)
  164.                        )
  165.                        ((or (eql c #\") (eql c #\\))
  166.                         (write-char #\\ s) (write-char c s)
  167.                        )
  168.                        (t (write-char c s))
  169.                ) )
  170.              string
  171.     )
  172.     (write-char #\" s)
  173. ) )
  174.  
  175. ; The info present for a C type.
  176. (defstruct c-type
  177.   name
  178.   lisp-type
  179.   c-name
  180.   lisp2c-checker ; function that outputs the code to check whether an object
  181.                  ; belongs to the correct Lisp type
  182.   lisp2c-converter ; function that outputs the code to convert to C
  183.   c2lisp-converter ; function that outputs the code to convert from C
  184. )
  185. #|
  186. (defparameter simple-c-types
  187.   (list
  188.     (make-c-type
  189.       :name 'nil
  190.       :lisp-type 'NIL
  191.       :c-name "void"
  192.     )
  193.     (make-c-type
  194.       :name 'boolean
  195.       :lisp-type '(MEMBER NIL T)
  196.       :c-name "int"
  197.       :lisp2c-checker
  198.         #'(lambda (obj s)
  199.             (declare (ignore obj s))
  200.           )
  201.       :lisp2c-converter
  202.         #'(lambda (obj s)
  203.             (format s "!nullp(~A)" obj)
  204.           )
  205.       :c2lisp-converter
  206.         #'(lambda (val s)
  207.             (format s "(~A) ? T : NIL" val)
  208.           )
  209.     )
  210.     (make-c-type
  211.       :name 'character
  212.       :lisp-type 'STRING-CHAR
  213.       :c-name "char"
  214.       :lisp2c-checker
  215.         #'(lambda (obj s)
  216.             (format s "check_string_char_p(~A);" obj)
  217.           )
  218.       :lisp2c-converter
  219.         #'(lambda (obj s)
  220.             (format s "(char)char_code(~A)" obj)
  221.           )
  222.       :c2lisp-converter
  223.         #'(lambda (val s)
  224.             (format s "code_char((unsigned char)(~A))" val)
  225.           )
  226.     )
  227.     (make-c-type
  228.       :name 'uchar
  229.       :lisp-type 'INTEGER
  230.       :c-name "UBYTE"
  231.       :lisp2c-checker
  232.         #'(lambda (obj s)
  233.             (format s "check_uint8(~A);" obj)
  234.           )
  235.       :lisp2c-converter
  236.         #'(lambda (obj s)
  237.             (format s "I_to_uint8(~A)" obj)
  238.           )
  239.       :c2lisp-converter
  240.         #'(lambda (val s)
  241.             (format s "uint8_to_I(~A)" val)
  242.           )
  243.     )
  244.     (make-c-type
  245.       :name 'char
  246.       :lisp-type 'INTEGER
  247.       :c-name "BYTE"
  248.       :lisp2c-checker
  249.         #'(lambda (obj s)
  250.             (format s "check_sint8(~A);" obj)
  251.           )
  252.       :lisp2c-converter
  253.         #'(lambda (obj s)
  254.             (format s "I_to_sint8(~A)" obj)
  255.           )
  256.       :c2lisp-converter
  257.         #'(lambda (val s)
  258.             (format s "sint8_to_I(~A)" val)
  259.           )
  260.     )
  261.     (make-c-type
  262.       :name 'ushort
  263.       :lisp-type 'INTEGER
  264.       :c-name "unsigned short"
  265.       :lisp2c-checker
  266.         #'(lambda (obj s)
  267.             (format s "check_uint16(~A);" obj)
  268.           )
  269.       :lisp2c-converter
  270.         #'(lambda (obj s)
  271.             (format s "I_to_uint16(~A)" obj)
  272.           )
  273.       :c2lisp-converter
  274.         #'(lambda (val s)
  275.             (format s "uint16_to_I(~A)" val)
  276.           )
  277.     )
  278.     (make-c-type
  279.       :name 'short
  280.       :lisp-type 'INTEGER
  281.       :c-name "short"
  282.       :lisp2c-checker
  283.         #'(lambda (obj s)
  284.             (format s "check_sint16(~A);" obj)
  285.           )
  286.       :lisp2c-converter
  287.         #'(lambda (obj s)
  288.             (format s "I_to_sint16(~A)" obj)
  289.           )
  290.       :c2lisp-converter
  291.         #'(lambda (val s)
  292.             (format s "sint16_to_I(~A)" val)
  293.           )
  294.     )
  295.     (make-c-type
  296.       :name 'uint
  297.       :lisp-type 'INTEGER
  298.       :c-name "unsigned int"
  299.       :lisp2c-checker
  300.         #'(lambda (obj s)
  301.             (format s "check_uint(~A);" obj)
  302.           )
  303.       :lisp2c-converter
  304.         #'(lambda (obj s)
  305.             (format s "I_to_uint(~A)" obj)
  306.           )
  307.       :c2lisp-converter
  308.         #'(lambda (val s)
  309.             (format s "uint_to_I(~A)" val)
  310.           )
  311.     )
  312.     (make-c-type
  313.       :name 'int
  314.       :lisp-type 'INTEGER
  315.       :c-name "int"
  316.       :lisp2c-checker
  317.         #'(lambda (obj s)
  318.             (format s "check_sint(~A);" obj)
  319.           )
  320.       :lisp2c-converter
  321.         #'(lambda (obj s)
  322.             (format s "I_to_sint(~A)" obj)
  323.           )
  324.       :c2lisp-converter
  325.         #'(lambda (val s)
  326.             (format s "sint_to_I(~A)" val)
  327.           )
  328.     )
  329.     (make-c-type
  330.       :name 'ulong
  331.       :lisp-type 'INTEGER
  332.       :c-name "unsigned long"
  333.       :lisp2c-checker
  334.         #'(lambda (obj s)
  335.             (format s "check_ulong(~A);" obj)
  336.           )
  337.       :lisp2c-converter
  338.         #'(lambda (obj s)
  339.             (format s "I_to_ulong(~A)" obj)
  340.           )
  341.       :c2lisp-converter
  342.         #'(lambda (val s)
  343.             (format s "ulong_to_I(~A)" val)
  344.           )
  345.     )
  346.     (make-c-type
  347.       :name 'long
  348.       :lisp-type 'INTEGER
  349.       :c-name "long"
  350.       :lisp2c-checker
  351.         #'(lambda (obj s)
  352.             (format s "check_slong(~A);" obj)
  353.           )
  354.       :lisp2c-converter
  355.         #'(lambda (obj s)
  356.             (format s "I_to_slong(~A)" obj)
  357.           )
  358.       :c2lisp-converter
  359.         #'(lambda (val s)
  360.             (format s "slong_to_I(~A)" val)
  361.           )
  362.     )
  363.     (make-c-type
  364.       :name 'uint8
  365.       :lisp-type '(UNSIGNED-BYTE 8)
  366.       :c-name "uint8"
  367.       :lisp2c-checker
  368.         #'(lambda (obj s)
  369.             (format s "check_uint8(~A);" obj)
  370.           )
  371.       :lisp2c-converter
  372.         #'(lambda (obj s)
  373.             (format s "I_to_uint8(~A)" obj)
  374.           )
  375.       :c2lisp-converter
  376.         #'(lambda (val s)
  377.             (format s "uint8_to_I(~A)" val)
  378.           )
  379.     )
  380.     (make-c-type
  381.       :name 'sint8
  382.       :lisp-type '(SIGNED-BYTE 8)
  383.       :c-name "sint8"
  384.       :lisp2c-checker
  385.         #'(lambda (obj s)
  386.             (format s "check_sint8(~A);" obj)
  387.           )
  388.       :lisp2c-converter
  389.         #'(lambda (obj s)
  390.             (format s "I_to_sint8(~A)" obj)
  391.           )
  392.       :c2lisp-converter
  393.         #'(lambda (val s)
  394.             (format s "sint8_to_I(~A)" val)
  395.           )
  396.     )
  397.     (make-c-type
  398.       :name 'uint16
  399.       :lisp-type '(UNSIGNED-BYTE 16)
  400.       :c-name "uint16"
  401.       :lisp2c-checker
  402.         #'(lambda (obj s)
  403.             (format s "check_uint16(~A);" obj)
  404.           )
  405.       :lisp2c-converter
  406.         #'(lambda (obj s)
  407.             (format s "I_to_uint16(~A)" obj)
  408.           )
  409.       :c2lisp-converter
  410.         #'(lambda (val s)
  411.             (format s "uint16_to_I(~A)" val)
  412.           )
  413.     )
  414.     (make-c-type
  415.       :name 'sint16
  416.       :lisp-type '(SIGNED-BYTE 16)
  417.       :c-name "sint16"
  418.       :lisp2c-checker
  419.         #'(lambda (obj s)
  420.             (format s "check_sint16(~A);" obj)
  421.           )
  422.       :lisp2c-converter
  423.         #'(lambda (obj s)
  424.             (format s "I_to_sint16(~A)" obj)
  425.           )
  426.       :c2lisp-converter
  427.         #'(lambda (val s)
  428.             (format s "sint16_to_I(~A)" val)
  429.           )
  430.     )
  431.     (make-c-type
  432.       :name 'uint32
  433.       :lisp-type '(UNSIGNED-BYTE 32)
  434.       :c-name "uint32"
  435.       :lisp2c-checker
  436.         #'(lambda (obj s)
  437.             (format s "check_uint32(~A);" obj)
  438.           )
  439.       :lisp2c-converter
  440.         #'(lambda (obj s)
  441.             (format s "I_to_uint32(~A)" obj)
  442.           )
  443.       :c2lisp-converter
  444.         #'(lambda (val s)
  445.             (format s "uint32_to_I(~A)" val)
  446.           )
  447.     )
  448.     (make-c-type
  449.       :name 'sint32
  450.       :lisp-type '(SIGNED-BYTE 32)
  451.       :c-name "sint32"
  452.       :lisp2c-checker
  453.         #'(lambda (obj s)
  454.             (format s "check_sint32(~A);" obj)
  455.           )
  456.       :lisp2c-converter
  457.         #'(lambda (obj s)
  458.             (format s "I_to_sint32(~A)" obj)
  459.           )
  460.       :c2lisp-converter
  461.         #'(lambda (val s)
  462.             (format s "sint32_to_I(~A)" val)
  463.           )
  464.     )
  465.     (make-c-type
  466.       :name 'uint64
  467.       :lisp-type '(UNSIGNED-BYTE 64)
  468.       :c-name "uint64"
  469.       :lisp2c-checker
  470.         #'(lambda (obj s)
  471.             (format s "check_uint64(~A);" obj)
  472.           )
  473.       :lisp2c-converter
  474.         #'(lambda (obj s)
  475.             (format s "I_to_uint64(~A)" obj)
  476.           )
  477.       :c2lisp-converter
  478.         #'(lambda (val s)
  479.             (format s "uint64_to_I(~A)" val)
  480.           )
  481.     )
  482.     (make-c-type
  483.       :name 'sint64
  484.       :lisp-type '(SIGNED-BYTE 64)
  485.       :c-name "sint64"
  486.       :lisp2c-checker
  487.         #'(lambda (obj s)
  488.             (format s "check_sint64(~A);" obj)
  489.           )
  490.       :lisp2c-converter
  491.         #'(lambda (obj s)
  492.             (format s "I_to_sint64(~A)" obj)
  493.           )
  494.       :c2lisp-converter
  495.         #'(lambda (val s)
  496.             (format s "sint64_to_I(~A)" val)
  497.           )
  498.     )
  499.     (make-c-type
  500.       :name 'single-float
  501.       :lisp-type 'SINGLE-FLOAT
  502.       :c-name "float"
  503.       :lisp2c-checker
  504.         #'(lambda (obj s)
  505.             (format s "check_ffloat(~A);" obj)
  506.           )
  507.       :lisp2c-converter
  508.         "FF_to_c_float(~A,(ffloatjanus*)&~A)" ??
  509.       :c2lisp-converter
  510.         #'(lambda (val s)
  511.             (format s "c_float_to_FF((ffloatjanus*)&~A)" val)
  512.           )
  513.     )
  514.     (make-c-type
  515.       :name 'double-float
  516.       :lisp-type 'DOUBLE-FLOAT
  517.       :c-name "double"
  518.       :lisp2c-checker
  519.         #'(lambda (obj s)
  520.             (format s "check_dfloat(~A);" obj)
  521.           )
  522.       :lisp2c-converter
  523.         "DF_to_c_double(~A,(dfloatjanus*)&~A)" ??
  524.       :c2lisp-converter
  525.         #'(lambda (val s)
  526.             (format s "c_double_to_DF((dfloatjanus*)&~A)" val)
  527.           )
  528.     )
  529.     (make-c-type
  530.       :name 'c-string
  531.       :lisp-type 'STRING
  532.       :c-name "char*"
  533.       :lisp2c-checker
  534.         #'(lambda (obj s)
  535.             (format s "~A = string_to_asciz(~A);" obj obj) ; GC ??
  536.           )
  537.       :lisp2c-converter
  538.         #'(lambda (obj s)
  539.             ;Trick with_string_0 wie in stdwin.d ??
  540.           )
  541.       :c2lisp-converter
  542.         #'(lambda (val s)
  543.             (format s "asciz_to_string(~A)" val)
  544.           )
  545.     )
  546. ) )
  547.  
  548. (defun lookup-c-type (name)
  549.   (or (find name simple-c-types :key #'c-type-name)
  550.       (gethash name *types*)
  551.       (error (DEUTSCH "Unbekannter FFI-Typ ~S."
  552.               ENGLISH "Unknown FFI type ~S"
  553.               FRANCAIS "Type de FFI inconnu: ~S")
  554.              name
  555.       )
  556. ) )
  557.  
  558. (defun parse-c-type (typespec &key maybe-nil maybe-incomplete)
  559.   (if (atom typespec)
  560.     (if (symbolp typespec)
  561.       (progn
  562.         (when (and (eq typespec 'nil) (not maybe-nil))
  563.           (error (DEUTSCH "FFI-Typ NIL ist hier nicht erlaubt."
  564.                   ENGLISH "FFI type NIL is not allowed here."
  565.                   FRANCAIS "Type de FFI NIL n'est pas permis ici.")
  566.         ) )
  567.         (or (find typespec simple-c-types :key #'c-type-name)
  568.             (gethash typespec *types*)
  569.             (if maybe-incomplete
  570.               (make-c-type
  571.                 :name typespec
  572.                 :lisp-type 'NIL
  573.                 :c-name (to-c-name typespec)
  574.               )
  575.               (error (DEUTSCH "UnvollstΣndiger FFI-Typ ~S ist hier nicht erlaubt."
  576.                       ENGLISH "Incomplete FFI type ~S is not allowed here."
  577.                       FRANCAIS "Le type de FFI ~S n'est pas complet, ce qui n'est pas permis ici.")
  578.                      typespec
  579.       ) )   ) )
  580.       (error (DEUTSCH "FFI-Typ mu▀ ein Symbol sein, nicht ~S."
  581.               ENGLISH "FFI type should be a symbol, not ~S"
  582.               FRANCAIS "Un type FFi doit Ωtre un symbole et non ~S")
  583.              typespec
  584.     ) )
  585.     (case (first typespec)
  586.       (C-STRUCT
  587.       (C-UNION
  588.       (C-ARRAY
  589.       (C-PTR
  590.  
  591.  
  592.  
  593. ;;     | (C-STRUCT (<ident> <c-type>)*)
  594. ;;     | (C-UNION (<ident> <c-type>)*)
  595. ;;     | (C-ARRAY <c-type> dimensions)
  596. ;;         dimensions ::= number | ({number}*)
  597. ;;     | (C-PTR <c-type>)
  598.  
  599. ;; (DEF-C-TYPE name type-description)
  600. ;;   type-description ::=
  601. ;;       <c-type>
  602. ;;     | C-STRING
  603. ;;     | (C-STRUCT (<ident> <c-type>)*)
  604. ;;     | (C-UNION (<ident> <c-type>)*)
  605. ;;     | (C-ARRAY <c-type> dimensions)
  606. ;;         dimensions ::= number | ({number}*)
  607. ;;     | (C-PTR <c-type>)
  608. ;;
  609. ;; (DEF-C-VAR name {option}*)
  610. ;;   option ::=
  611. ;;       (:name <c-name>)
  612. ;;     | (:type <c-type>)
  613. ;;     | (:read-only <boolean>)
  614. ;;
  615. ;; (DEF-CALL-OUT name {option}*)
  616. ;;   option ::=
  617. ;;       (:name <c-name>)
  618. ;;     | (:arguments {(arg-name <c-type> [<param-mode>])}*)
  619. ;;     | (:return-type <c-type>)
  620. ;;     | (:callback <boolean>)
  621. ;;
  622. ;; (DEF-CALL-IN name {option}*)
  623. ;;   option ::=
  624. ;;       (:name <c-name>)
  625. ;;     | (:arguments {(arg-name <c-type> [<param-mode>])}*)
  626. ;;     | (:return-type c-type)
  627. ;;
  628. ;; name is any Lisp symbol.
  629. ;;
  630. ;; c-name is a string.
  631. ;;
  632. ;; A <param-mode> is
  633. ;; either :READ-ONLY -- the caller passes information to the callee
  634. ;; or :WRITE-ONLY -- the callee passes information back to the caller on return
  635. ;; or :READ-WRITE -- both.
  636. ;;
  637.  
  638. (defun parse-foreign-name (language name)
  639.   (unless (stringp name)
  640.     (error (DEUTSCH "Der Name mu▀ ein String sein, nicht ~S."
  641.             ENGLISH "The name must be a string, not ~S"
  642.             FRANCAIS "Le nom doit Ωtre une chaεne et non ~S.")
  643.            name
  644.   ) )
  645.   (when (or (equal language "C") (equal language "C++"))
  646.     (return-from parse-foreign-name
  647.       (if (c-ident-p name)
  648.         name
  649.         (error (DEUTSCH "Der Name ~S ist kein gⁿltiger C-Identifier."
  650.                 ENGLISH "The name ~S is not a valid C identifier"
  651.                 FRANCAIS "Le nom ~S n'est pas valable en langage C.")
  652.                name
  653.   ) ) ) )
  654. )
  655.  
  656. (defun parse-foreign (caller lisp-name arglist)
  657.   (if (and (consp arglist) (eq (first arglist) ':FOREIGN))
  658.     (if (and (consp (cdr arglist)) (listp (second arglist))
  659.              (eql (second arglist) 2)
  660.         )
  661.       (let ((language (first (second arglist)))
  662.             (name (second (second arglist))))
  663.         (values (parse-foreign-language language)
  664.                 (parse-foreign-name language name)
  665.                 (cddr arglist)
  666.       ) )
  667.       (error (DEUTSCH "~S ~S: Syntaxfehler nach ~S."
  668.               ENGLISH "~S ~S: syntax error after ~S"
  669.               FRANCAIS "~S ~S : Syntaxe inadmissible aprΦs ~S.")
  670.              caller lisp-name ':FOREIGN
  671.     ) )
  672.     (values "C" (to-c-name lisp-name) arglist)
  673. ) )
  674.  
  675. (defun foreign-type-info (type)
  676.   (if (eq type 'nil)
  677.     (error (DEUTSCH "FFI-Typ NIL ist hier nicht erlaubt."
  678.             ENGLISH "FFI type NIL is not allowed here"
  679.             FRANCAIS "Le type de FFI NIL n'est pas permis ici.")
  680.     )
  681.     (foreign-rtype-info type)
  682. ) )
  683.  
  684. (defmacro define-external-variable (name &rest args)
  685.   (multiple-value-bind (foreign-language foreign-name arglist)
  686.       (parse-foreign 'define-external-variable name args)
  687.     (declare (ignore foreign-language))
  688.     (unless (and (consp arglist) (null (cdr arglist)))
  689.       (error (DEUTSCH "~S ~S: Syntaxfehler."
  690.               ENGLISH "~S ~S: syntax error"
  691.               FRANCAIS "~S ~S : Syntaxe inadmissible.")
  692.              'define-external-variable name
  693.     ) )
  694.     (let* ((getter-function-name (sys::symbol-suffix name "%GETTER%"))
  695.            (setter-function-name (sys::symbol-suffix name "%SETTER%"))
  696.            (result-type (first arglist))
  697.            (result-type-info (foreign-type-info result-type))
  698.            (code
  699.              (concatenate 'string
  700.                (format nil "~%LISPFUNN(~A,0)~%{ extern ~A ~A; value1 = ~?; mv_count=1; }~%"
  701.                            (to-c-name getter-function-name)
  702.                            (third result-type-info) foreign-name
  703.                            (seventh result-type-info) (list foreign-name)
  704.                )
  705.                (format nil "~%LISPFUNN(~A,1)~%{ extern ~A ~A; var reg1 object obj = popSTACK(); ~? ~A = ~?; value1 = obj; mv_count=1; }~%"
  706.                            (to-c-name setter-function-name)
  707.                            (third result-type-info) foreign-name
  708.                            (fourth result-type-info) (list "obj")
  709.                            foreign-name (fifth result-type-info) (list "obj")
  710.              ) )
  711.            )
  712.            (subrs (list (list getter-function-name "LISPFUNN(~A,0)" (to-c-name getter-function-name))
  713.                         (list setter-function-name "LISPFUNN(~A,1)" (to-c-name setter-function-name))
  714.            )      )
  715.           )
  716.       `(PROGN
  717.          (EVAL-WHEN (COMPILE)
  718.            (WRITE-STRING ',code *FFI-OUTPUT-STREAM*)
  719.            (NOTE-SUBRS ',subrs)
  720.          )
  721.          (DEFSETF ,getter-function-name ,setter-function-name)
  722.          (DEFINE-SYMBOL-MACRO ,name (,getter-function-name))
  723.          ',name
  724.        )
  725. ) ) )
  726.  
  727. (defun note-subrs (subr-list)
  728.   (setf (module-info-subr-list *ffi-module*)
  729.         (revappend subr-list (module-info-subr-list *ffi-module*))
  730. ) )
  731.  
  732. (defun start-module (module-name)
  733.   (setq *ffi-module*
  734.         (make-module-info :name module-name
  735.                           :c-name (to-c-name module-name)
  736.   )     )
  737.   (setq *ffi-output-stream* (open (merge-pathnames '#".c" module-name) :direction :output))
  738.   (format *ffi-output-stream* "#include \"clisp.h\"~%~%")
  739. )
  740.  
  741. (defun finish-module ()
  742.   (setf (module-info-subr-list *ffi-module*)
  743.         (nreverse (module-info-subr-list *ffi-module*))
  744.   )
  745.   (setf (module-info-object-list *ffi-module*)
  746.         (nreverse (module-info-object-list *ffi-module*))
  747.   )
  748.   (format *ffi-output-stream* "~%#undef LISPFUN~%#define LISPFUN LISPFUN_F~%")
  749.   ; output subr_tab:
  750.   (format *ffi-output-stream*
  751.           "~%subr_ module__~A__subr_tab[~D]"
  752.           (module-info-c-name *ffi-module*)
  753.           (max (length (module-info-subr-list *ffi-module*)) 1)
  754.   )
  755.   (when (module-info-subr-list *ffi-module*)
  756.     (format *ffi-output-stream* " = {~%")
  757.     (dolist (subr (module-info-subr-list *ffi-module*))
  758.       (apply #'format *ffi-output-stream* "  ~@?~%" (cdr subr))
  759.     )
  760.     (format *ffi-output-stream* "}")
  761.   )
  762.   (format *ffi-output-stream* ";~%")
  763.   (format *ffi-output-stream*
  764.           "~%uintC module__~A__subr_tab_size = ~D;~%"
  765.           (module-info-c-name *ffi-module*)
  766.           (length (module-info-subr-list *ffi-module*))
  767.   )
  768.   ; output object_tab:
  769.   (format *ffi-output-stream*
  770.           "~%object module__~A__object_tab[~D];~%"
  771.           (module-info-c-name *ffi-module*)
  772.           (max (length (module-info-object-list *ffi-module*)) 1)
  773.   )
  774.   (format *ffi-output-stream*
  775.           "~%uintC module__~A__object_tab_size = ~D;~%"
  776.           (module-info-c-name *ffi-module*)
  777.           (length (module-info-object-list *ffi-module*))
  778.   )
  779.   ; output subr_tab_initdata:
  780.   (format *ffi-output-stream*
  781.           "~%subr_initdata module__~A__subr_tab_initdata[~D]"
  782.           (module-info-c-name *ffi-module*)
  783.           (max (length (module-info-subr-list *ffi-module*)) 1)
  784.   )
  785.   (when (module-info-subr-list *ffi-module*)
  786.     (format *ffi-output-stream* " = {~%")
  787.     (dolist (subr (module-info-subr-list *ffi-module*))
  788.       (format *ffi-output-stream*
  789.               "{ ~A, ~A },"
  790.               (let ((pack (symbol-package (car subr))))
  791.                 (if pack (to-c-string (package-name pack)) "NULL")
  792.               )
  793.               (to-c-string (symbol-name (car subr)))
  794.     ) )
  795.     (format *ffi-output-stream* "}")
  796.   )
  797.   (format *ffi-output-stream* ";~%")
  798.   ; output the init function:
  799.   (format *ffi-output-stream*
  800.           "~%void module__~A__init_function (module) var reg3 module_* module; {~%"
  801.           (module-info-c-name *ffi-module*)
  802.   )
  803.   (format *ffi-output-stream* "}~%")
  804.   ; done.
  805.   (close *ffi-output-stream*)
  806. )
  807. |#
  808.