home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / clisp / src / archive / clisp.faslsp.lha / foreign1.lsp < prev    next >
Lisp/Scheme  |  1996-07-27  |  50KB  |  1,180 lines
  1. ;;; Foreign function interface for CLISP
  2. ;;; Bruno Haible 19.2.1995
  3.  
  4. (in-package "FFI" :use '("LISP"))
  5.  
  6. (export '(def-c-type def-c-var def-c-call-out def-call-out def-c-call-in def-call-in
  7.           nil boolean character char uchar short ushort int uint long ulong
  8.           uint8 sint8 uint16 sint16 uint32 sint32 uint64 sint64
  9.           single-float double-float
  10.           c-pointer c-string c-struct c-union c-array c-array-max c-function c-ptr c-ptr-null c-array-ptr
  11.           def-c-enum def-c-struct element deref slot cast typeof sizeof bitsizeof
  12.           validp
  13.           #+AMIGA def-lib-call-out
  14. )        )
  15.  
  16. (eval-when (load compile eval)
  17.   (import (find-symbol "*COUTPUT-FILE*" "COMPILER"))
  18.   (import (find-symbol "*COUTPUT-STREAM*" "COMPILER"))
  19.   (import (find-symbol "*FFI-MODULE*" "COMPILER"))
  20.   (import (find-symbol "FINALIZE-COUTPUT-FILE" "COMPILER"))
  21.   (import (find-symbol "DEPARSE-C-TYPE" "SYSTEM")) ; called by DESCRIBE
  22.   (import (find-symbol "FOREIGN-FUNCTION-SIGNATURE" "SYSTEM")) ; called by SYS::FUNCTION-SIGNATURE
  23. )
  24.  
  25. ;; These constants are defined in spvw.d.
  26. ;; We declare them here only to avoid warnings.
  27. #-FFI
  28. (progn
  29.   (defvar fv-flag-readonly)
  30.   (defvar fv-flag-malloc-free)
  31.   (defvar ff-flag-alloca)
  32.   (defvar ff-flag-malloc-free)
  33.   (defvar ff-flag-out)
  34.   (defvar ff-flag-in-out)
  35.   (defvar ff-language-asm)
  36.   (defvar ff-language-c)
  37.   (defvar ff-language-ansi-c)
  38. )
  39.  
  40. ;; ============================ helper functions ============================
  41.  
  42. ; Determines whether a name is a valid C identifier.
  43. (defun c-ident-p (name)
  44.   (and (> (length name) 0)
  45.        (every #'(lambda (c)
  46.                  ;(and (standard-char-p ch)
  47.                  ;     (or (alphanumericp ch) (eql ch #\_)) ; don't allow #\$
  48.                  ;)
  49.                   (or (char<= #\A c #\Z) (char<= #\a c #\z) (char<= #\0 c #\9)
  50.                       (char= #\_ c)
  51.                 ) )
  52.               name
  53.        )
  54.        (not (char<= #\0 (char name 0) #\9))
  55.        ; must not be a reserved word:
  56.        (not (gethash name
  57.                      (load-time-value
  58.                        (let* ((reserved-list
  59.                                 '("auto" "break" "case" "char" "continue"
  60.                                   "default" "do" "double" "else" "enum" "extern"
  61.                                   "float" "for" "goto" "if" "int" "long"
  62.                                   "register" "return" "short" "sizeof" "static"
  63.                                   "struct" "switch" "typedef" "union" "unsigned"
  64.                                   "void" "while"
  65.                               )  )
  66.                               (reserved-table (make-hash-table :test #'equal)))
  67.                          (dolist (w reserved-list)
  68.                            (setf (gethash w reserved-table) 'T)
  69.                          )
  70.                          reserved-table
  71.        )    )        ) )
  72. ) )
  73.  
  74. ; Given a string, return it in C syntax.
  75. (defun to-c-string (string)
  76.   (with-output-to-string (s)
  77.     (write-char #\" s)
  78.     (map nil #'(lambda (c)
  79.                  (cond ((eql c #\Null)
  80.                         (error 
  81.                          #L{
  82.                          DEUTSCH "Kann String ~S nicht nach C abbilden, denn es enthält ein Zeichen ~S."
  83.                          ENGLISH "Cannot map string ~S to C since it contains a character ~S"
  84.                          FRANCAIS "Ne peux convertir la chaîne ~S en langage C à cause d'un caractère ~S."
  85.                          }
  86.                          string c
  87.                        ))
  88.                        ((eq c #\Newline)
  89.                         (write-char #\\ s) (write-char #\n s)
  90.                        )
  91.                        ((or (eql c #\") (eql c #\\))
  92.                         (write-char #\\ s) (write-char c s)
  93.                        )
  94.                        (t (write-char c s))
  95.                ) )
  96.              string
  97.     )
  98.     (write-char #\" s)
  99. ) )
  100.  
  101. #+AMIGA
  102. (defconstant *registers*
  103.   '#(:D0 :D1 :D2 :D3 :D4 :D5 :D6 :D7 :A0 :A1 :A2 :A3 :A4 :A5 :A6)
  104. )
  105.  
  106. ;; ============================ C types ============================
  107.  
  108. ;: The table of C types.
  109. (defvar *c-type-table* (make-hash-table :test #'eq))
  110.  
  111. ; simple C types
  112. (dolist (c-type
  113.           '(nil boolean character char uchar short ushort int uint long ulong
  114.             uint8 sint8 uint16 sint16 uint32 sint32 uint64 sint64
  115.             single-float double-float
  116.             c-pointer c-string
  117.         )  )
  118.   (setf (gethash c-type *c-type-table*) c-type)
  119. )
  120.  
  121. ; Parse a C type specification. If name is /= NIL, it will be assigned to name.
  122. (defun parse-c-type (typespec &optional (name nil))
  123.   (if (atom typespec)
  124.     (if (symbolp typespec)
  125.       (multiple-value-bind (c-type found) (gethash typespec *c-type-table*)
  126.         (unless found
  127.           (error 
  128.            #L{
  129.            DEUTSCH "Unvollständiger FFI-Typ ~S ist hier nicht erlaubt."
  130.            ENGLISH "Incomplete FFI type ~S is not allowed here."
  131.            FRANCAIS "Le type de FFI ~S n'est pas complet, ce qui n'est pas permis ici."
  132.            }
  133.            typespec
  134.         ) )
  135.         (when name (setf (gethash name *c-type-table*) c-type))
  136.         c-type
  137.       )
  138.       (error 
  139.        #L{
  140.        DEUTSCH "FFI-Typ muß ein Symbol sein, nicht ~S."
  141.        ENGLISH "FFI type should be a symbol, not ~S"
  142.        FRANCAIS "Un type FFi doit être un symbole et non ~S"
  143.        }
  144.        typespec
  145.     ) )
  146.     (flet ((invalid (typespec)
  147.              (error 
  148.               #L{
  149.               DEUTSCH "Ungültiger FFI-Typ: ~S"
  150.               ENGLISH "Invalid FFI type: ~S"
  151.               FRANCAIS "Type FFI inadmissible: ~S"
  152.               }
  153.               typespec
  154.           )) )
  155.       (case (first typespec)
  156.         (C-STRUCT
  157.           (let* ((n (- (length typespec) 2))
  158.                  (c-type (make-array (+ n 3))))
  159.             (unwind-protect
  160.               (progn
  161.                 (when name (setf (gethash name *c-type-table*) c-type))
  162.                 (setf (svref c-type 0) (first typespec))
  163.                 (setf (subseq c-type 3)
  164.                       (mapcar #'(lambda (subspec)
  165.                                   (unless (and (consp subspec)
  166.                                                (eql (length subspec) 2)
  167.                                                (symbolp (first subspec))
  168.                                           )
  169.                                     (error 
  170.                                      #L{
  171.                                      DEUTSCH "Ungültige ~S-Komponente: ~S"
  172.                                      ENGLISH "Invalid ~S component: ~S"
  173.                                      FRANCAIS "Composant de ~S inadmissible: ~S"
  174.                                      }
  175.                                      'c-struct subspec
  176.                                   ) )
  177.                                   (parse-c-type (second subspec))
  178.                                 )
  179.                               (cddr typespec)
  180.                 )     )
  181.                 (setf (svref c-type 1) ; slots
  182.                       (map 'vector #'first (cddr typespec))
  183.                 )
  184.                 (setf (svref c-type 2) ; constructor
  185.                       (let ((class (second typespec)))
  186.                         (case (second typespec)
  187.                           (VECTOR #'vector)
  188.                           (LIST #'list)
  189.                           (t (let* ((slots (mapcar #'first (cddr typespec)))
  190.                                     (vars (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) slots))
  191.                                     h
  192.                                    )
  193.                                (eval `(FUNCTION
  194.                                         (LAMBDA ,vars
  195.                                           (DECLARE (COMPILE))
  196.                                           ,(if (and (setq h (get class 'sys::defstruct-description))
  197.                                                     (setq h (svref h 2))
  198.                                                )
  199.                                              ; h is the keyword constructor for the structure
  200.                                              `(,h ,@(mapcan #'(lambda (s v)
  201.                                                                 (list (intern (symbol-name s) compiler::*keyword-package*)
  202.                                                                       v
  203.                                                               ) )
  204.                                                             slots vars
  205.                                                     )
  206.                                               )
  207.                                              ; no keyword constructor found -> use CLOS:SLOT-VALUE instead
  208.                                              (let ((ivar (gensym)))
  209.                                                `(LET ((,ivar (CLOS:MAKE-INSTANCE ',class)))
  210.                                                   ,@(mapcar #'(lambda (s v)
  211.                                                                 `(SETF (CLOS:SLOT-VALUE ,ivar ',s) ,v)
  212.                                                               )
  213.                                                             slots vars
  214.                                                     )
  215.                                                   ,ivar
  216.                                                 )
  217.                                            ) )
  218.                                       ) )
  219.                 )     ) ) )  ) )
  220.               )
  221.               (when name (setf (gethash name *c-type-table*) nil))
  222.             )
  223.             (when name (setf (gethash name *c-type-table*) c-type))
  224.             c-type
  225.         ) )
  226.         (C-UNION
  227.           (let* ((n (1- (length typespec)))
  228.                  (c-type (make-array (+ n 2))))
  229.             (unwind-protect
  230.               (progn
  231.                 (when name (setf (gethash name *c-type-table*) c-type))
  232.                 (setf (svref c-type 0) (first typespec))
  233.                 (setf (subseq c-type 2)
  234.                       (mapcar #'(lambda (subspec)
  235.                                   (unless (and (consp subspec)
  236.                                                (eql (length subspec) 2)
  237.                                                (symbolp (first subspec))
  238.                                           )
  239.                                     (error 
  240.                                      #L{
  241.                                      DEUTSCH "Ungültige ~S-Komponente: ~S"
  242.                                      ENGLISH "Invalid ~S component: ~S"
  243.                                      FRANCAIS "Composant de ~S inadmissible: ~S"
  244.                                      }
  245.                                      'c-union subspec
  246.                                   ) )
  247.                                   (parse-c-type (second subspec))
  248.                                 )
  249.                               (rest typespec)
  250.                 )     )
  251.                 (setf (svref c-type 1) (map 'vector #'first (rest typespec)))
  252.               )
  253.               (when name (setf (gethash name *c-type-table*) nil))
  254.             )
  255.             (when name (setf (gethash name *c-type-table*) c-type))
  256.             c-type
  257.         ) )
  258.         (C-ARRAY
  259.           (unless (eql (length typespec) 3) (invalid typespec))
  260.           (let ((dimensions (third typespec)))
  261.             (unless (listp dimensions) (setq dimensions (list dimensions)))
  262.             (unless (every #'(lambda (dim) (typep dim '(integer 0 *))) dimensions)
  263.               (invalid typespec)
  264.             )
  265.             (let ((c-type (make-array (+ 2 (length dimensions)))))
  266.               (unwind-protect
  267.                 (progn
  268.                   (when name (setf (gethash name *c-type-table*) c-type))
  269.                   (setf (svref c-type 0) 'C-ARRAY)
  270.                   (setf (svref c-type 1) (parse-c-type (second typespec)))
  271.                   (setf (subseq c-type 2) dimensions)
  272.                 )
  273.                 (when name (setf (gethash name *c-type-table*) nil))
  274.               )
  275.               (when name (setf (gethash name *c-type-table*) c-type))
  276.               c-type
  277.         ) ) )
  278.         (C-ARRAY-MAX
  279.           (unless (eql (length typespec) 3) (invalid typespec))
  280.           (let ((maxdim (third typespec)))
  281.             (unless (typep maxdim '(integer 0 *)) (invalid typespec))
  282.             (let ((c-type (make-array 3)))
  283.               (unwind-protect
  284.                 (progn
  285.                   (when name (setf (gethash name *c-type-table*) c-type))
  286.                   (setf (svref c-type 0) 'C-ARRAY-MAX)
  287.                   (setf (svref c-type 1) (parse-c-type (second typespec)))
  288.                   (setf (svref c-type 2) maxdim)
  289.                 )
  290.                 (when name (setf (gethash name *c-type-table*) nil))
  291.               )
  292.               (when name (setf (gethash name *c-type-table*) c-type))
  293.               c-type
  294.         ) ) )
  295.         (C-FUNCTION
  296.           (let ((c-type (parse-c-function
  297.                           (parse-options (rest typespec) '(:arguments :return-type :language) typespec)
  298.                           typespec
  299.                ))       )
  300.             (when name (setf (gethash name *c-type-table*) c-type))
  301.             c-type
  302.         ) )
  303.         (C-PTR
  304.           (unless (eql (length typespec) 2) (invalid typespec))
  305.           (let ((c-type (make-array 2)))
  306.             (unwind-protect
  307.               (progn
  308.                 (when name (setf (gethash name *c-type-table*) c-type))
  309.                 (setf (svref c-type 0) 'C-PTR)
  310.                 (setf (svref c-type 1) (parse-c-type (second typespec)))
  311.               )
  312.               (when name (setf (gethash name *c-type-table*) nil))
  313.             )
  314.             (when name (setf (gethash name *c-type-table*) c-type))
  315.             c-type
  316.         ) )
  317.         (C-PTR-NULL
  318.           (unless (eql (length typespec) 2) (invalid typespec))
  319.           (let ((c-type (make-array 2)))
  320.             (unwind-protect
  321.               (progn
  322.                 (when name (setf (gethash name *c-type-table*) c-type))
  323.                 (setf (svref c-type 0) 'C-PTR-NULL)
  324.                 (setf (svref c-type 1) (parse-c-type (second typespec)))
  325.               )
  326.               (when name (setf (gethash name *c-type-table*) nil))
  327.             )
  328.             (when name (setf (gethash name *c-type-table*) c-type))
  329.             c-type
  330.         ) )
  331.         (C-ARRAY-PTR
  332.           (unless (eql (length typespec) 2) (invalid typespec))
  333.           (let ((c-type (make-array 2)))
  334.             (unwind-protect
  335.               (progn
  336.                 (when name (setf (gethash name *c-type-table*) c-type))
  337.                 (setf (svref c-type 0) 'C-ARRAY-PTR)
  338.                 (setf (svref c-type 1) (parse-c-type (second typespec)))
  339.               )
  340.               (when name (setf (gethash name *c-type-table*) nil))
  341.             )
  342.             (when name (setf (gethash name *c-type-table*) c-type))
  343.             c-type
  344.         ) )
  345.         (t (invalid typespec))
  346.       )
  347. ) ) )
  348.  
  349. (defun parse-options (options keywords whole)
  350.   (let ((alist '()))
  351.     (dolist (option options)
  352.       (unless (and (consp option) (member (first option) keywords))
  353.         (error 
  354.          #L{
  355.          DEUTSCH "Ungültige Option in ~S: ~S"
  356.          ENGLISH "Invalid option in ~S: ~S"
  357.          FRANCAIS "Option invalide dans ~S: ~S"
  358.          }
  359.          whole option
  360.       ) )
  361.       (when (assoc (first option) alist)
  362.         (error 
  363.          #L{
  364.          DEUTSCH "Nur eine ~S-Option ist erlaubt: ~S"
  365.          ENGLISH "Only one ~S option is allowed: ~S"
  366.          FRANCAIS "Une seule option ~S est permise: ~S"
  367.          }
  368.          (first option) whole
  369.       ) )
  370.       (push option alist)
  371.     )
  372.     alist
  373. ) )
  374.  
  375. (defun parse-c-function (alist whole)
  376.   (vector
  377.     'C-FUNCTION
  378.     (parse-c-type (or (second (assoc ':return-type alist)) 'nil))
  379.     (coerce (mapcap #'(lambda (argspec)
  380.                         (unless (and (listp argspec)
  381.                                      (symbolp (first argspec))
  382.                                      (<= 2 (length argspec) #-AMIGA 4 #+AMIGA 5)
  383.                                 )
  384.                           (error 
  385.                            #L{
  386.                            DEUTSCH "Ungültige Parameter-Spezifikation in ~S: ~S"
  387.                            ENGLISH "Invalid parameter specification in ~S: ~S"
  388.                            FRANCAIS "Spécification invalide d'argument dans ~S: ~S"
  389.                            }
  390.                            whole argspec
  391.                         ) )
  392.                         (let* ((argtype (parse-c-type (second argspec)))
  393.                                (argmode (if (cddr argspec) (third argspec) ':IN))
  394.                                (argalloc (if (cdddr argspec)
  395.                                            (fourth argspec)
  396.                                            (if (or (eq argtype 'C-STRING)
  397.                                                    (and (simple-vector-p argtype)
  398.                                                         (case (svref argtype 0) ((C-PTR C-PTR-NULL C-ARRAY-PTR) t))
  399.                                                    )
  400.                                                    (eq argmode ':OUT)
  401.                                                )
  402.                                              ':ALLOCA
  403.                                              ':NONE
  404.                               ))         ) )
  405.                           (list argtype
  406.                                 (+ (ecase argmode
  407.                                      ((:IN :READ-ONLY) 0)
  408.                                      ((:OUT :WRITE-ONLY) ff-flag-out)
  409.                                      ((:IN-OUT :READ-WRITE) ff-flag-in-out)
  410.                                    )
  411.                                    (ecase argalloc
  412.                                      (:NONE 0)
  413.                                      (:ALLOCA ff-flag-alloca)
  414.                                      (:MALLOC-FREE ff-flag-malloc-free)
  415.                                    )
  416.                                    #+AMIGA
  417.                                    (if (cddddr argspec)
  418.                                      (ash (1+ (position (fifth argspec) *registers*)) 8)
  419.                                      0
  420.                                    )
  421.                       ) ) )     )
  422.                     (or (rest (assoc ':arguments alist)) '())
  423.             )
  424.             'simple-vector
  425.     )
  426.     (+ (let ((rettype (assoc ':return-type alist)))
  427.          (if (cddr rettype)
  428.            (ecase (third rettype)
  429.              (:NONE 0)
  430.              (:MALLOC-FREE ff-flag-malloc-free)
  431.            )
  432.            0
  433.        ) )
  434.        (let ((languages (assoc ':language alist)))
  435.          (if languages
  436.            (reduce #'+ (rest languages)
  437.                    :key #'(lambda (lang)
  438.                             (ecase lang
  439.                               (:C ff-language-c)
  440.                               (:STDC ff-language-ansi-c)
  441.            )              ) )
  442.            ff-language-c ; Default is K&R C
  443.        ) )
  444.     )
  445. ) )
  446.  
  447. (defun parse-foreign-name (name)
  448.   (unless (stringp name)
  449.     (error 
  450.      #L{
  451.      DEUTSCH "Der Name muß ein String sein, nicht ~S."
  452.      ENGLISH "The name must be a string, not ~S"
  453.      FRANCAIS "Le nom doit être une chaîne et non ~S."
  454.      }
  455.      name
  456.   ) )
  457.   (if (c-ident-p name)
  458.     name
  459.     (error 
  460.      #L{
  461.      DEUTSCH "Der Name ~S ist kein gültiger C-Identifier."
  462.      ENGLISH "The name ~S is not a valid C identifier"
  463.      FRANCAIS "Le nom ~S n'est pas valable en langage C."
  464.      }
  465.      name
  466. ) ) )
  467.  
  468. (defun check-symbol (whole &optional (name (second whole)))
  469.   (unless (symbolp name)
  470.     (sys::error-of-type 'program-error
  471.       #L{
  472.       DEUTSCH "~S: Das ist kein Symbol: ~S"
  473.       ENGLISH "~S: this is not a symbol: ~S"
  474.       FRANCAIS "~S : Ceci n'est pas un symbole: ~S"
  475.       }
  476.       (first whole) name
  477. ) ) )
  478.  
  479. (defmacro DEF-C-TYPE (&whole whole name typespec)
  480.   (check-symbol whole)
  481.   `(EVAL-WHEN (LOAD COMPILE EVAL)
  482.      (PARSE-C-TYPE ',typespec ',name)
  483.      ',name
  484.    )
  485. )
  486.  
  487. ; Convert back a C type from internal (vector) to external (list)
  488. ; representation. Both representations may be circular.
  489. (defun deparse-c-type (ctype)
  490.   (let ((alist '()))
  491.     (labels ((deparse (ctype)
  492.                (or (cdr (assoc ctype alist :test #'eq))
  493.                    (if (symbolp ctype)
  494.                      ; <simple-c-type>, c-pointer, c-string
  495.                      (progn (push (cons ctype ctype) alist) ctype)
  496.                      (let ((typespec (list (svref ctype 0))))
  497.                        (push (cons ctype typespec) alist)
  498.                        (ecase (svref ctype 0)
  499.                          ; #(c-struct slots constructor <c-type>*)
  500.                          (C-STRUCT
  501.                            (setf (rest typespec)
  502.                                  (cons (let ((constructor (svref ctype 2)))
  503.                                          (cond ((eql constructor #'vector) 'vector)
  504.                                                ((eql constructor #'list) 'list)
  505.                                                (t 'nil)
  506.                                        ) )
  507.                                        (map 'list #'(lambda (slot slottype)
  508.                                                       (list slot (deparse slottype))
  509.                                                     )
  510.                                             (svref ctype 1) (subseq ctype 3)
  511.                          ) )     )     )
  512.                          ; #(c-union alternatives <c-type>*)
  513.                          (C-UNION
  514.                            (setf (rest typespec)
  515.                                  (map 'list #'(lambda (alt alttype)
  516.                                                 (list alt (deparse alttype))
  517.                                               )
  518.                                       (svref ctype 1) (subseq ctype 2)
  519.                          ) )     )
  520.                          ; #(c-array <c-type> number*)
  521.                          (C-ARRAY
  522.                            (setf (rest typespec)
  523.                                  (list (deparse (svref ctype 1))
  524.                                        (let ((dimensions (subseq ctype 2)))
  525.                                          (if (eql (length dimensions) 1)
  526.                                            (elt dimensions 0)
  527.                                            (coerce dimensions 'list)
  528.                          ) )     )     ) )
  529.                          ; #(c-array-max <c-type> number)
  530.                          (C-ARRAY-MAX
  531.                            (setf (rest typespec)
  532.                                  (list (deparse (svref ctype 1)) (svref ctype 2))
  533.                          ) )
  534.                          ; #(c-function <c-type> #({<c-type> flags}*) flags)
  535.                          (C-FUNCTION
  536.                            (setf (rest typespec)
  537.                                  (list (list ':arguments
  538.                                              (do ((args (coerce (svref ctype 2) 'list) (cddr args))
  539.                                                   (i 1 (+ i 1))
  540.                                                   (argspecs '()))
  541.                                                  ((null args) (nreverse argspecs))
  542.                                                (let ((argtype (first args))
  543.                                                      (argflags (second args)))
  544.                                                  (push `(,(intern (format nil "arg~D" i) compiler::*keyword-package*)
  545.                                                          ,(deparse argtype)
  546.                                                          ,(cond ((not (zerop (logand argflags ff-flag-out))) ':OUT)
  547.                                                                 ((not (zerop (logand argflags ff-flag-in-out))) ':IN-OUT)
  548.                                                                 (t ':IN)
  549.                                                           )
  550.                                                          ,(cond ((not (zerop (logand argflags ff-flag-alloca))) ':ALLOCA)
  551.                                                                 ((not (zerop (logand argflags ff-flag-malloc-free))) ':MALLOC-FREE)
  552.                                                                 (t ':NONE)
  553.                                                           )
  554.                                                          #+AMIGA
  555.                                                          ,@(let ((h (logand (ash argflags -8) #xF)))
  556.                                                              (if (not (zerop h))
  557.                                                                (list (svref *registers* (- h 1)))
  558.                                                                '()
  559.                                                            ) )
  560.                                                         )
  561.                                                        argspecs
  562.                                        )     ) ) )
  563.                                        (list ':return-type
  564.                                              (deparse (svref ctype 1))
  565.                                              (if (zerop (logand (svref ctype 3) ff-flag-malloc-free)) ':NONE ':MALLOC-FREE)
  566.                                        )
  567.                                        (cons ':language
  568.                                              (append
  569.                                                (if (not (zerop (logand (svref ctype 3) ff-language-c))) '(:C) '())
  570.                                                (if (not (zerop (logand (svref ctype 3) ff-language-ansi-c))) '(:STDC) '())
  571.                                  )     )     )
  572.                          ) )
  573.                          ; #(c-ptr <c-type>)
  574.                          (C-PTR
  575.                            (setf (rest typespec) (list (deparse (svref ctype 1))))
  576.                          )
  577.                          ; #(c-ptr-null <c-type>)
  578.                          (C-PTR-NULL
  579.                            (setf (rest typespec) (list (deparse (svref ctype 1))))
  580.                          )
  581.                          ; #(c-array-ptr <c-type>)
  582.                          (C-ARRAY-PTR
  583.                            (setf (rest typespec) (list (deparse (svref ctype 1))))
  584.                          )
  585.                        )
  586.                        typespec
  587.             )) )   ) )
  588.       (deparse ctype)
  589. ) ) )
  590.  
  591. ;; ============================ module ============================
  592.  
  593. ; Data belonging to the FFI module being compiled:
  594. (defvar *ffi-module* nil)
  595.  
  596. ; We put everything into a structure, so that COMPILE-FILE needs to bind only
  597. ; a single variable at compile time.
  598. (defstruct ffi-module
  599.   name
  600.   c-name
  601.   (object-table (make-hash-table :test #'equal))
  602.   (variable-list '())
  603.   (function-list '())
  604. )
  605. (define-symbol-macro *name*
  606.           (ffi-module-name *ffi-module*)
  607. )
  608. (define-symbol-macro *c-name*
  609.           (ffi-module-c-name *ffi-module*)
  610. )
  611. (define-symbol-macro *object-table*
  612.           (ffi-module-object-table *ffi-module*)
  613. )
  614. (define-symbol-macro *variable-list*
  615.           (ffi-module-variable-list *ffi-module*)
  616. )
  617. (define-symbol-macro *function-list*
  618.           (ffi-module-function-list *ffi-module*)
  619. )
  620.  
  621. ; Convert a file name to a C module name.
  622. ; This must agree with some sed command in clisp-link.in.
  623. (defun to-module-name (name)
  624.   (map 'string #'(lambda (c)
  625.                    (if (or (char<= #\A c #\Z) (char<= #\a c #\z) (char<= #\0 c #\9) (char= c #\_))
  626.                      c
  627.                      #\_
  628.                  ) )
  629.        name
  630. ) )
  631.  
  632. ; Convert a Lisp name to a C name.
  633. ; (Doesn't really matter how. This must just be a deterministic function.)
  634. (defun to-c-name (name)
  635.   (setq name (string name))
  636.   (unless (some #'lower-case-p name) (setq name (string-downcase name)))
  637.   (if (c-ident-p name)
  638.     name
  639.     (with-output-to-string (s)
  640.       (format s "_lisp__")
  641.       (map nil
  642.            #'(lambda (ch)
  643.                (if (and (standard-char-p ch) (alphanumericp ch))
  644.                  (write-char ch s)
  645.                  (format s "_~2X" (char-code ch))
  646.              ) )
  647.            name
  648. ) ) ) )
  649.  
  650.  
  651. (defun complex-c-type-value (c-type)
  652.   (and (simple-vector-p c-type) (plusp (length c-type))
  653.        (svref c-type 0)))
  654.  
  655. (defun struct-c-type-p (c-type)
  656.   (let ((complex-type (complex-c-type-value c-type)))
  657.     (eq 'c-struct complex-type)))
  658.  
  659. (defun union-c-type-p (c-type)
  660.   (let ((complex-type (complex-c-type-value c-type)))
  661.     (eq 'c-union complex-type)))
  662.  
  663. ; Convert a C type to its C representation, only for the purpose of taking
  664. ; "sizeof".
  665. (defun to-c-typedecl (c-type name &optional typename)
  666.   (case c-type
  667.     ((nil) (format nil "void ~A" name))
  668.     (boolean (format nil "int ~A" name))
  669.     (character (format nil "char ~A" name))
  670.     ((char sint8) (format nil "sint8 ~A" name))
  671.     ((uchar uint8) (format nil "uint8 ~A" name))
  672.     ((short sint16) (format nil "sint16 ~A" name))
  673.     ((ushort uint16) (format nil "uint16 ~A" name))
  674.     (int (format nil "int ~A" name))
  675.     (uint (format nil "unsigned int ~A" name))
  676.     (long (format nil "long ~A" name))
  677.     (ulong (format nil "unsigned long ~A" name))
  678.     (sint32 (format nil "sint32 ~A" name))
  679.     (uint32 (format nil "uint32 ~A" name))
  680.     (sint64 (format nil "sint64 ~A" name))
  681.     (uint64 (format nil "uint64 ~A" name))
  682.     (single-float (format nil "float ~A" name))
  683.     (double-float (format nil "double ~A" name))
  684.     ((c-pointer c-string) (format nil "void* ~A" name))
  685.     (t (case (complex-c-type-value c-type)
  686.          (c-struct
  687.            (format nil "struct ~A { ~{~A; ~}} ~A"
  688.                        (if typename typename "")
  689.                        (mapcar #'(lambda (subtype)
  690.                                    (to-c-typedecl subtype (symbol-name (gensym "g")))
  691.                                  )
  692.                                (cdddr (coerce c-type 'list))
  693.                        )
  694.                        name
  695.          ) )
  696.          (c-union
  697.            (format nil "union ~A { ~{~A; ~}} ~A"
  698.                        (if typename typename "")
  699.                        (mapcar #'(lambda (subtype)
  700.                                    (to-c-typedecl subtype (symbol-name (gensym "g")))
  701.                                  )
  702.                                (cddr (coerce c-type 'list))
  703.                        )
  704.                        name
  705.          ) )
  706.          (c-array
  707.            (to-c-typedecl (svref c-type 1)
  708.                           (format nil "(~A)~{[~D]~}" name (cddr (coerce c-type 'list)))
  709.          ) )
  710.          (c-array-max
  711.            (to-c-typedecl (svref c-type 1)
  712.                           (format nil "(~A)[~D]" name (svref c-type 2))
  713.          ) )
  714.          ((c-function c-ptr c-ptr-null c-array-ptr) (format nil "void* ~A" name))
  715.          (t (error 
  716.              #L{
  717.              DEUTSCH "ungültiger Typ für externe Daten: ~S"
  718.              ENGLISH "illegal foreign data type ~S"
  719.              FRANCAIS "type invalide de données externes : ~S"
  720.              }
  721.              c-type
  722. ) ) )  ) )  )
  723.  
  724. (defun prepare-module ()
  725.   (unless *ffi-module*
  726.     (setq *ffi-module*
  727.           (let ((module-name (pathname-name *coutput-file*)))
  728.             (make-ffi-module :name module-name
  729.                              :c-name (to-module-name module-name))
  730.     ) )
  731.     (format *coutput-stream* "extern object module__~A__object_tab[];~%" *c-name*)
  732. ) )
  733. (defun finalize-coutput-file ()
  734.   (when *ffi-module*
  735.     (format *coutput-stream* "~%")
  736.     (format *coutput-stream* "subr_ module__~A__subr_tab[1];~%" *c-name*)
  737.     (format *coutput-stream* "uintC module__~A__subr_tab_size = 0;~%" *c-name*)
  738.     (format *coutput-stream* "subr_initdata module__~A__subr_tab_initdata[1];~%" *c-name*)
  739.     (format *coutput-stream* "~%")
  740.     (let ((count (hash-table-count *object-table*)))
  741.       (if (zerop count)
  742.         (progn
  743.           (format *coutput-stream* "object module__~A__object_tab[1];~%" *c-name*)
  744.           (format *coutput-stream* "object_initdata module__~A__object_tab_initdata[1];~%" *c-name*)
  745.         )
  746.         (let ((v (make-array count)))
  747.           (format *coutput-stream* "object module__~A__object_tab[~D];~%" *c-name* count)
  748.           (format *coutput-stream* "object_initdata module__~A__object_tab_initdata[~D] = {~%" *c-name* count)
  749.           (dohash (key value *object-table*)
  750.             (declare (ignore key))
  751.             (setf (svref v (cdr value)) (car value))
  752.           )
  753.           (map nil #'(lambda (initstring)
  754.                        (format *coutput-stream* "  { ~A },~%" (to-c-string initstring))
  755.                      )
  756.                    v
  757.           )
  758.           (format *coutput-stream* "};~%")
  759.       ) )
  760.       (format *coutput-stream* "uintC module__~A__object_tab_size = ~D;~%" *c-name* count)
  761.     )
  762.     (format *coutput-stream* "~%")
  763.     (setq *variable-list* (nreverse (delete-duplicates *variable-list* :key #'first :test #'equal)))
  764.     (dolist (variable *variable-list*)
  765.       (format *coutput-stream* "extern ~A;~%"
  766.               (to-c-typedecl (second variable) (first variable))
  767.     ) )
  768.     (setq *function-list* (nreverse (delete-duplicates *function-list* :key #'first :test #'equal)))
  769.     (dolist (function *function-list*)
  770.       (format *coutput-stream* "extern ~A;~%"
  771.               (to-c-typedecl (svref (second function) 1)
  772.                              (format nil "(~A)()" (first function))
  773.     ) )       )
  774.     (format *coutput-stream* "
  775. void module__~A__init_function_1(module)
  776.   var module_* module;
  777. { }~%"
  778.             *c-name*
  779.     )
  780.     (format *coutput-stream* "
  781. void module__~A__init_function_2(module)
  782.   var module_* module;
  783. {~%"
  784.             *c-name*
  785.     )
  786.     (dolist (variable *variable-list*)
  787.       (format *coutput-stream* "  register_foreign_variable(&~A,~A,~D,sizeof(~A));~%"
  788.               (first variable) (to-c-string (first variable)) (third variable) (first variable)
  789.     ) )
  790.     (dolist (function *function-list*)
  791.       (format *coutput-stream* "  register_foreign_function(&~A,~A,~D);~%"
  792.               (first function) (to-c-string (first function)) (svref (second function) 3)
  793.     ) )
  794.     (format *coutput-stream* "}~%")
  795. ) )
  796.  
  797. ; Allocate a new object in the module's object_tab.
  798. (defun new-object (read-only-p initstring)
  799.   (when read-only-p
  800.     (let ((h (gethash initstring *object-table*)))
  801.       (when h
  802.         (return-from new-object (cdr h)) ; no need to allocate a new one
  803.   ) ) )
  804.   (let ((index (hash-table-count *object-table*)))
  805.     (setf (gethash (if read-only-p initstring (gensym)) *object-table*)
  806.           (cons initstring index)
  807.     )
  808.     index
  809. ) )
  810.  
  811. ; Pass an object from the compilation environment to the module.
  812. (defun pass-object (object)
  813.   (new-object t
  814.               (let ((*package* compiler::*keyword-package*))
  815.                 (write-to-string object :readably t :pretty nil)
  816. ) )           )
  817.  
  818. ; Convert an object's index to a C lvalue.
  819. (defun object-to-c-value (index)
  820.   (format nil "module__~A__object_tab[~D]" *c-name* index)
  821. )
  822.  
  823. ;; ============================ named C variables ============================
  824.  
  825. (defun foreign-name (lisp-name name-option)
  826.   (if name-option
  827.     (parse-foreign-name (second name-option))
  828.     (to-c-name lisp-name)
  829. ) )
  830.  
  831. (defmacro DEF-C-VAR (&whole whole name &rest options)
  832.   (check-symbol whole)
  833.   (let* ((alist (parse-options options '(:name :type :read-only :alloc) whole))
  834.          (c-name (foreign-name name (assoc ':name alist)))
  835.          (type (second (or (assoc ':type alist)
  836.                            (sys::error-of-type 'program-error
  837.                              #L{
  838.                              DEUTSCH "~S: ~S-Option fehlt in ~S."
  839.                              ENGLISH "~S: ~S option missing in ~S"
  840.                              FRANCAIS "~S: option ~S manque dans ~S"
  841.                              }
  842.                              'def-c-var ':type whole
  843.          )     )       )   )
  844.          (read-only (second (assoc ':read-only alist)))
  845.          (flags (+ (if read-only fv-flag-readonly 0)
  846.                    (let ((alloc (assoc ':alloc alist)))
  847.                      (if (cdr alloc)
  848.                        (ecase (second alloc)
  849.                          (:NONE 0)
  850.                          (:MALLOC-FREE fv-flag-malloc-free)
  851.                        )
  852.                        0
  853.                    ) )
  854.          )      )
  855.          #|
  856.          (getter-function-name (sys::symbol-suffix name "%GETTER%"))
  857.          (setter-function-name (sys::symbol-suffix name "%SETTER%"))
  858.          |#
  859.         )
  860.     `(PROGN
  861.        (EVAL-WHEN (COMPILER::COMPILE-ONCE-ONLY) (NOTE-C-VAR ',c-name ',type ',flags))
  862.        #|
  863.        (LET ((FVAR (FFI::LOOKUP-FOREIGN-VARIABLE ',c-name (PARSE-C-TYPE ',type))))
  864.          (DEFUN ,getter-function-name () (FFI::FOREIGN-VALUE FVAR))
  865.          ; Install a setter even if the variable is read-only.
  866.          ; When called, it will print a comprehensible error message.
  867.          (DEFUN ,setter-function-name (VALUE) (FFI::SET-FOREIGN-VALUE FVAR VALUE))
  868.        )
  869.        (DEFSETF ,getter-function-name ,setter-function-name)
  870.        (DEFINE-SYMBOL-MACRO ,name (,getter-function-name))
  871.        |#
  872.        (SYSTEM::%PUT ',name 'FOREIGN-VARIABLE
  873.          (LOAD-TIME-VALUE
  874.            (FFI::LOOKUP-FOREIGN-VARIABLE ',c-name (PARSE-C-TYPE ',type))
  875.        ) )
  876.        (DEFINE-SYMBOL-MACRO ,name
  877.          (FFI::FOREIGN-VALUE (LOAD-TIME-VALUE (GET ',name 'FOREIGN-VARIABLE)))
  878.        )
  879.        ',name
  880.      )
  881. ) )
  882.  
  883. (defun note-c-var (c-name type flags)
  884.   (when (compiler::prepare-coutput-file)
  885.     (prepare-module)
  886.     (push (list c-name (parse-c-type type) flags) *variable-list*)
  887. ) )
  888.  
  889. (defsetf ffi::foreign-value ffi::set-foreign-value)
  890.  
  891. ;; ============================ named C functions ============================
  892.  
  893. (defmacro DEF-C-CALL-OUT (name &rest options)
  894.   `(DEF-CALL-OUT ,name ,@options (:LANGUAGE :C))
  895. )
  896.  
  897. (defmacro DEF-CALL-OUT (&whole whole name &rest options)
  898.   (check-symbol whole)
  899.   (let* ((alist (parse-options options '(:name :arguments :return-type :language) whole))
  900.          (c-name (foreign-name name (assoc ':name alist))))
  901.     (setq alist (remove (assoc ':name alist) alist))
  902.     `(PROGN
  903.        (EVAL-WHEN (COMPILER::COMPILE-ONCE-ONLY) (NOTE-C-FUN ',c-name ',alist ',whole))
  904.        (LET ()
  905.          (SYSTEM::REMOVE-OLD-DEFINITIONS ',name)
  906.          (EVAL-WHEN (COMPILE) (COMPILER::C-DEFUN ',name))
  907.          (SYSTEM::%PUTD ',name
  908.            (FFI::LOOKUP-FOREIGN-FUNCTION ',c-name
  909.                                          (PARSE-C-FUNCTION ',alist ',whole)
  910.        ) ) )
  911.        ',name
  912.      )
  913. ) )
  914.  
  915. (defun note-c-fun (c-name alist whole)
  916.   (when (compiler::prepare-coutput-file)
  917.     (prepare-module)
  918.     (push (list c-name (parse-c-function alist whole)) *function-list*)
  919. ) )
  920.  
  921. #+AMIGA
  922. (defmacro DEF-LIB-CALL-OUT (&whole whole name library &rest options)
  923.   (check-symbol whole)
  924.   (let* ((alist (parse-options options '(:name :offset :arguments :return-type) whole))
  925.          (c-name (foreign-name name (assoc ':name alist)))
  926.          (offset (second (assoc ':offset alist))))
  927.     `(LET ()
  928.        (SYSTEM::REMOVE-OLD-DEFINITIONS ',name)
  929.        (EVAL-WHEN (COMPILE) (COMPILER::C-DEFUN ',name))
  930.        (SYSTEM::%PUTD ',name
  931.          (FFI::FOREIGN-LIBRARY-FUNCTION ',c-name
  932.           (FFI::FOREIGN-LIBRARY ',library)
  933.           ',offset
  934.           (PARSE-C-FUNCTION ',(remove (assoc ':name alist) alist) ',whole)))
  935.        ',name
  936. ) )  )
  937.  
  938. (defmacro DEF-C-CALL-IN (name &rest options)
  939.   `(DEF-CALL-IN ,name ,@options (:LANGUAGE :C))
  940. )
  941.  
  942. (defmacro DEF-CALL-IN (&whole whole name &rest options)
  943.   (check-symbol whole)
  944.   (let* ((alist (parse-options options '(:name :arguments :return-type :language) whole))
  945.          (c-name (foreign-name name (assoc ':name alist))))
  946.     (setq alist (remove (assoc ':name alist) alist))
  947.     `(PROGN
  948.        (EVAL-WHEN (COMPILER::COMPILE-ONCE-ONLY) (NOTE-C-CALL-IN ',name ',c-name ',alist ',whole))
  949.        ',name
  950.      )
  951. ) )
  952.  
  953. (defun return-typename (c-name)
  954.   (format nil "~A_return" c-name))
  955.  
  956. (defun note-c-call-in (name c-name alist whole)
  957.   (when (compiler::prepare-coutput-file)
  958.     (prepare-module)
  959.     (let* ((fvd (parse-c-function alist whole))
  960.            (rettype (svref fvd 1))
  961.            (args (svref fvd 2))
  962.            (flags (svref fvd 3))
  963.            (argtypes (do ((i 0 (+ i 2))
  964.                           (l '()))
  965.                          ((>= i (length args)) (nreverse l))
  966.                        (push (svref args i) l)
  967.            )         )
  968.            (argflags (do ((i 1 (+ i 2))
  969.                           (l '()))
  970.                          ((>= i (length args)) (nreverse l))
  971.                        (push (svref args i) l)
  972.            )         )
  973.            (argnames (mapcar #'(lambda (argtype) (declare (ignore argtype))
  974.                                  (symbol-name (gensym "g"))
  975.                                )
  976.                              argtypes
  977.           ))         )
  978.       (terpri *coutput-stream*)
  979.       (flet ((print-complex-typedef (keyword)
  980.                (format *coutput-stream* "~A;~%" (to-c-typedecl rettype "" (return-typename c-name)))
  981.                (format *coutput-stream* "~%global ~A ~A ~A " keyword (return-typename c-name) c-name)))
  982.         (cond ((struct-c-type-p rettype) (print-complex-typedef "struct"))
  983.               ((union-c-type-p rettype) (print-complex-typedef "union"))
  984.               (t (format *coutput-stream* "~%global ~A "
  985.                          (to-c-typedecl rettype (format nil "(~A)" c-name))))))
  986.       (if (not (zerop (logand flags ff-language-ansi-c)))
  987.         ; ANSI C parameter declarations
  988.         (progn
  989.           (format *coutput-stream* "(")
  990.           (if argtypes
  991.             (do ((argtypesr argtypes (cdr argtypesr))
  992.                  (argnamesr argnames (cdr argnamesr)))
  993.                 ((null argtypesr))
  994.               (format *coutput-stream* "~A" (to-c-typedecl (car argtypesr) (car argnamesr)))
  995.               (when (cdr argtypesr) (format *coutput-stream* ", "))
  996.             )
  997.             (format *coutput-stream* "void")
  998.           )
  999.           (format *coutput-stream* ")")
  1000.         )
  1001.         ; K&R C parameter declarations
  1002.         (progn
  1003.           (format *coutput-stream* "(")
  1004.           (do ((argnamesr argnames (cdr argnamesr)))
  1005.               ((null argnamesr))
  1006.             (format *coutput-stream* "~A" (car argnamesr))
  1007.             (when (cdr argnamesr) (format *coutput-stream* ", "))
  1008.           )
  1009.           (format *coutput-stream* ")")
  1010.           (do ((argtypesr argtypes (cdr argtypesr))
  1011.                (argnamesr argnames (cdr argnamesr)))
  1012.               ((null argtypesr))
  1013.             (format *coutput-stream* "~%  ~A;" (to-c-typedecl (car argtypesr) (car argnamesr)))
  1014.         ) )
  1015.       )
  1016.       (format *coutput-stream* "~%{~%")
  1017.       (let ((inargcount 0) (outargcount (if (eq rettype 'NIL) 0 1)))
  1018.         (mapc #'(lambda (argtype argflag argname)
  1019.                   (when (zerop (logand argflag ff-flag-out))
  1020.                     (format *coutput-stream* "  pushSTACK(convert_from_foreign(~A,&~A));~%" (object-to-c-value (pass-object argtype)) argname)
  1021.                     (incf inargcount)
  1022.                   )
  1023.                   (unless (zerop (logand argflag (logior ff-flag-out ff-flag-in-out)))
  1024.                     (incf outargcount)
  1025.                 ) )
  1026.               argtypes argflags argnames
  1027.         )
  1028.         (format *coutput-stream* "  funcall(~A,~D);~%" (object-to-c-value (pass-object name)) inargcount)
  1029.         (unless (eq rettype 'NIL)
  1030.           (format *coutput-stream* " {~%")
  1031.           (cond ((struct-c-type-p rettype)
  1032.                  (format *coutput-stream* "  var struct ~A ~A;~%" (return-typename c-name) "retval"))
  1033.                 ((union-c-type-p rettype)
  1034.                  (format *coutput-stream* "  var union ~A ~A;~%" (return-typename c-name) "retval"))
  1035.                 (t (format *coutput-stream* "  var ~A;~%" (to-c-typedecl rettype "retval"))))
  1036.           (format *coutput-stream* "  ~A(~A,value1,&retval);~%"
  1037.                   (if (zerop (logand flags ff-flag-malloc-free)) "convert_to_foreign_nomalloc" "convert_to_foreign_mallocing")
  1038.                   (object-to-c-value (pass-object rettype))
  1039.         ) )
  1040.         (let ((outargcount (if (eq rettype 'NIL) 0 1)))
  1041.           (mapc #'(lambda (argtype argflag argname)
  1042.                     (unless (zerop (logand argflag (logior ff-flag-out ff-flag-in-out)))
  1043.                       (unless (and (simple-vector-p argtype) (eql (length argtype) 2) 
  1044.                                    (or (eq (svref argtype 0) 'C-PTR) (eq (svref argtype 0) 'C-PTR-NULL)))
  1045.                         (error 
  1046.                          #L{
  1047.                          DEUTSCH "~S: :OUT-Argument ist kein Pointer: ~S"
  1048.                          ENGLISH "~S: :OUT argument is not a pointer: ~S"
  1049.                          FRANCAIS "~S : paramètre :OUT n'est pas indirecte: ~S"
  1050.                          }
  1051.                          'DEF-CALL-IN argtype
  1052.                       ) )
  1053.                       (format *coutput-stream* "  ~A~A(~A,~A,~A);~%"
  1054.                               (if (eql outargcount 0) "" (format nil "if (mv_count >= ~D) " (+ outargcount 1)))
  1055.                               (if (zerop (logand argflag ff-flag-malloc-free)) "convert_to_foreign_nomalloc" "convert_to_foreign_mallocing")
  1056.                               (object-to-c-value (pass-object (svref argtype 1)))
  1057.                               (if (eql outargcount 0) "value1" (format nil "mv_space[~D]" outargcount))
  1058.                               argname
  1059.                       )
  1060.                       (incf outargcount)
  1061.                   ) )
  1062.                 argtypes argflags argnames
  1063.         ) )
  1064.         (unless (eq rettype 'NIL)
  1065.           (format *coutput-stream* "  return retval;~%")
  1066.           (format *coutput-stream* " }~%")
  1067.       ) )
  1068.       (format *coutput-stream* "}~%")
  1069. ) ) )
  1070.  
  1071. ;; ===========================================================================
  1072.  
  1073. ; Called by SYS::FUNCTION-SIGNATURE.
  1074. (defun foreign-function-signature (obj)
  1075.   (let* ((arg-vector (sys::%record-ref obj 3))
  1076.          (l (length arg-vector))
  1077.          (inargcount 0))
  1078.     (do ((i 1 (+ i 2)))
  1079.         ((>= i l))
  1080.       (when (zerop (logand ff-flag-out (svref arg-vector i))) (incf inargcount))
  1081.     )
  1082.     inargcount
  1083. ) )
  1084.  
  1085. (defmacro def-c-enum (&whole whole name &rest items)
  1086.   (check-symbol whole)
  1087.   (let ((forms '())
  1088.         (next-value 0))
  1089.     (dolist (item items)
  1090.       (when (consp item)
  1091.         (when (rest item) (setq next-value (second item)))
  1092.         (setq item (first item))
  1093.       )
  1094.       (push `(DEFCONSTANT ,item ,next-value) forms)
  1095.       (setq next-value `(1+ ,item))
  1096.     )
  1097.     `(PROGN ,@(nreverse forms) ',name)
  1098. ) )
  1099.  
  1100. (defmacro def-c-struct (name &rest slots)
  1101.   `(PROGN
  1102.      (DEFSTRUCT ,name ,@(mapcar #'first slots))
  1103.      (DEF-C-TYPE ,name (C-STRUCT ,name ,@slots))
  1104.    )
  1105. )
  1106.  
  1107. ; In order for ELEMENT, DEREF, SLOT to be SETFable, I make them macros.
  1108. ; (element (foreign-value x) ...) --> (foreign-value (%element x ...))
  1109. ; (deref (foreign-value x))       --> (foreign-value (%deref x))
  1110. ; (slot (foreign-value x) ...)    --> (foreign-value (%slot x ...))
  1111. (flet ((err (whole)
  1112.          (sys::error-of-type 'program-error
  1113.            #L{
  1114.            DEUTSCH "~S ist nur nach ~S erlaubt: ~S"
  1115.            ENGLISH "~S is only allowed after ~S: ~S"
  1116.            FRANCAIS "~S n'est permis qu'après ~S: ~S"
  1117.            }
  1118.            (first whole) 'FOREIGN-VALUE whole
  1119.       )) )
  1120.   (defmacro element (place &rest indices &environment env)
  1121.     (setq place (macroexpand place env))
  1122.     (if (and (consp place) (eq (first place) 'FOREIGN-VALUE) (eql (length place) 2))
  1123.       `(FOREIGN-VALUE (%ELEMENT ,(second place) ,@indices))
  1124.       (err `(element ,place ,@indices))
  1125.   ) )
  1126.   (defmacro deref (place &environment env)
  1127.     (setq place (macroexpand place env))
  1128.     (if (and (consp place) (eq (first place) 'FOREIGN-VALUE) (eql (length place) 2))
  1129.       `(FOREIGN-VALUE (%DEREF ,(second place)))
  1130.       (err `(deref ,place))
  1131.   ) )
  1132.   (defmacro slot (place slotname &environment env)
  1133.     (setq place (macroexpand place env))
  1134.     (if (and (consp place) (eq (first place) 'FOREIGN-VALUE) (eql (length place) 2))
  1135.       `(FOREIGN-VALUE (%SLOT ,(second place) ,slotname))
  1136.       (err `(slot ,place ,slotname))
  1137.   ) )
  1138.   (defmacro cast (place type &environment env)
  1139.     (setq place (macroexpand place env))
  1140.     (if (and (consp place) (eq (first place) 'FOREIGN-VALUE) (eql (length place) 2))
  1141.       `(FOREIGN-VALUE (%CAST ,(second place) (PARSE-C-TYPE ,type)))
  1142.       (err `(cast ,place ,type))
  1143.   ) )
  1144.   ; Similarly for TYPEOF.
  1145.   ; (typeof (foreign-value x)) --> (deparse-c-type (foreign-type x))
  1146.   (defmacro typeof (place &environment env)
  1147.     (setq place (macroexpand place env))
  1148.     (if (and (consp place) (eq (first place) 'FOREIGN-VALUE) (eql (length place) 2))
  1149.       `(DEPARSE-C-TYPE (FOREIGN-TYPE ,(second place)))
  1150.       (err `(typeof ,place))
  1151.   ) )
  1152. )
  1153.  
  1154. ; Similar tricks are being played for SIZEOF, BITSIZEOF. They are macros which
  1155. ; work on <c-place>s. If the argument is not a <c-place>, they behave like
  1156. ; ordinary functions.
  1157. ; (sizeof (foreign-value x))  --> (sizeof (typeof (foreign-value x)))
  1158. ;                             --> (sizeof (deparse-c-type (foreign-type x)))
  1159. ;                             --> (%sizeof (foreign-type x))
  1160. ; (sizeof (deparse-c-type y)) --> (%sizeof y)
  1161. ; (sizeof z)                  --> (%sizeof (parse-c-type z))
  1162. (defmacro sizeof (place &environment env)
  1163.   (setq place (macroexpand place env))
  1164.   (if (and (consp place) (eq (first place) 'FOREIGN-VALUE) (eql (length place) 2))
  1165.     `(%SIZEOF (FOREIGN-TYPE ,(second place)))
  1166.     (if (and (consp place) (eq (first place) 'DEPARSE-C-TYPE) (eql (length place) 2))
  1167.       `(%SIZEOF ,(second place))
  1168.       `(%SIZEOF (PARSE-C-TYPE ,place))
  1169. ) ) )
  1170. (defmacro bitsizeof (place &environment env)
  1171.   (setq place (macroexpand place env))
  1172.   (if (and (consp place) (eq (first place) 'FOREIGN-VALUE) (eql (length place) 2))
  1173.     `(%BITSIZEOF (FOREIGN-TYPE ,(second place)))
  1174.     (if (and (consp place) (eq (first place) 'DEPARSE-C-TYPE) (eql (length place) 2))
  1175.       `(%BITSIZEOF ,(second place))
  1176.       `(%BITSIZEOF (PARSE-C-TYPE ,place))
  1177. ) ) )
  1178.  
  1179. ;; ===========================================================================
  1180.