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