← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to misc/foreign.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
misc/foreign.lsp
 
1
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
2
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
3
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
4
;;; -*- Mode: Lisp;  -*-
 
5
;;; File: foreign-interface.lisp
 
6
;;; Author: Paul Viola (viola@ai.mit.edu)
 
7
;;; Copyright (C) Paul Viola, 1993
 
8
;;;*----------------------------------------------------------------------------
 
9
;;;* FUNCTION: Code to support foreign function call interface in GCL.
 
10
;;;*
 
11
;;;* CLASSES:
 
12
;;;* 
 
13
;;;* RELATED PACKAGES:
 
14
;;;*
 
15
;;;* HISTORY:
 
16
;;;* Last edited: May  7 17:55 1993 (viola)
 
17
;;;* Created: Thu May  6 11:36:49 1993 (viola)
 
18
;;;*----------------------------------------------------------------------------
 
19
 
 
20
(in-package "USER")
 
21
 
 
22
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
23
;;; Code that makes some lucid foreign function definitions work in GCL.
 
24
 
 
25
(defparameter *lucid-to-gcl-c-types*
 
26
  '((:signed-32bit int)
 
27
    (:unsigned-32bit int)               ;I hope this is right.
 
28
    (:double-float double)
 
29
    (:single-float float)
 
30
    (:simple-string string)
 
31
    ((:pointer :signed-32bit) vector-int)
 
32
    ((:pointer :single-float) vector-single-float)
 
33
    ((:pointer :double-float) vector-double-float)
 
34
    (:null void)))
 
35
 
 
36
(defmacro def-foreign-function ((lisp-name . key-params) . c-params)
 
37
  "I wrote this so that lucid calls to foreign functions could be used directly in
 
38
GCL. "
 
39
  (progn (print lisp-name)
 
40
         `(defentry-2 ,lisp-name
 
41
           ,(loop for param in c-params
 
42
                  collect (cadr (assoc (cadr param) *lucid-to-gcl-c-types*
 
43
                                       :test #'equal)))
 
44
           ,(list (cadr (assoc (lucid-return-type key-params) *lucid-to-gcl-c-types*
 
45
                               :test #'equal))
 
46
                  (lucid-c-name key-params)))))
 
47
 
 
48
(defun lucid-return-type (key-params)
 
49
  (cadar (member :return-type key-params :key #'car)))
 
50
 
 
51
(defun lucid-c-name (key-params)
 
52
  (intern
 
53
   (string-upcase
 
54
    (subseq (cadar (member :name key-params :key #'car)) 1))))
 
55
 
 
56
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
57
;;; Using lisp strings in C is a pain.  First they need to be NULL terminated
 
58
;;; then they need to be converted into a C object.  The code below returns a
 
59
;;; C-string from a lisp routine.  This is pretty dangerous - I don't know what
 
60
;;; would happen if you tried to operate on it.
 
61
 
 
62
;;; For an array of ints.
 
63
(defCfun "object get_c_ints(s) object s;" 0
 
64
  " return(s->fixa.fixa_self);"
 
65
  )
 
66
 
 
67
(defentry get-c-ints (object) (object get_c_ints))
 
68
 
 
69
;;; For an array of single-floats.
 
70
(defCfun "object get_c_single_floats(s) object s;" 0
 
71
  " return(s->sfa.sfa_self);"
 
72
  )
 
73
 
 
74
(defentry get-c-single-floats (object) (object get_c_single_floats))
 
75
 
 
76
;;; For an array of double-floats.
 
77
(defCfun "object get_c_double_floats(s) object s;" 0
 
78
  " return(s->lfa.lfa_self);"
 
79
  )
 
80
 
 
81
(defentry get-c-double-floats (object) (object get_c_double_floats))
 
82
 
 
83
;;; For a string.
 
84
(defCfun "object get_c_string(s) object s;" 0
 
85
  " return(s->st.st_self);"
 
86
  )
 
87
(defentry get_c_string_2 (object) (object get_c_string))
 
88
 
 
89
;; make sure string is null terminated
 
90
(defun get-c-string (string)
 
91
  (get_c_string_2 (concatenate 'string string "
 
92
 
 
93
 
 
94
(defparameter *gcl-to-c-types*
 
95
  '((int int nil)
 
96
    (char char nil)
 
97
    (float float nil)
 
98
    (double double nil)
 
99
    (object object nil)
 
100
    (string object get-c-string)
 
101
    (vector-int object get-c-ints)
 
102
    (vector-single-float object get-c-single-floats)
 
103
    (vector-double-float object get-c-double-floats)))
 
104
            
 
105
(defmacro defentry-2 (func-name param-types declaration)
 
106
  "Macro enhances defentry so that composite types can be passed to C functions.
 
107
For a list of types look at *gcl-to-c-types*"
 
108
  (let ((f-name (intern (concatenate 'string (symbol-name func-name) "-2")))
 
109
        (new-types (mapcar #'(lambda (a) (cadr (assoc a *gcl-to-c-types*))) param-types))
 
110
        (param-list (mapcar #'(lambda (a) (gensym)) param-types)))
 
111
    `(progn 
 
112
      (defentry ,f-name ,new-types ,declaration)
 
113
      (defmacro ,func-name ,param-list
 
114
        (list ',f-name
 
115
              ,@(loop for p in param-list
 
116
                      for type in param-types
 
117
                      for (ntype new-type converter-func) = (assoc type *gcl-to-c-types*)
 
118
                      collect (if (null converter-func)
 
119
                                  p
 
120
                                  `(list ',converter-func ,p))))))))
 
121