1;;;; File: standard.scm
2;;;; Copyright (C) 2004-2006 Andreas Rottmann
3;;;;
4;;;; based upon G-Wrap 1.3.4,
5;;;;   Copyright (C) 1996, 1997,1998 Christopher Lee
6;;;;   Copyright (C) 1999, 2000, 2001, 2002 Rob Browning
7;;;;
8;;;; This program is free software; you can redistribute it and/or
9;;;; modify it under the terms of the GNU Lesser General Public
10;;;; License as published by the Free Software Foundation; either
11;;;; version 2, or (at your option) any later version.
12;;;;
13;;;; This program is distributed in the hope that it will be useful,
14;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16;;;; Lesser General Public License for more details.
17;;;;
18;;;; You should have received a copy of the GNU Lesser General Public
19;;;; License along with this software; see the file COPYING.  If not,
20;;;; write to the Free Software Foundation, 675 Mass Ave, Cambridge,
21;;;; MA 02139, USA.
22;;;;
23
24;;; Commentary:
25;;
26; Guile-specific part of the standard wrapset.
27;;
28;;; Code:
29
30(define-module (g-wrap guile ws standard)
31  #:use-module (oop goops)
32  #:use-module (g-wrap)
33  #:use-module (g-wrap c-codegen)
34  #:use-module (g-wrap util)
35  #:use-module (g-wrap rti)
36  #:use-module (g-wrap c-types)
37  #:use-module (g-wrap ws standard)
38  #:use-module (g-wrap guile))
39
40
41;;; standard wrapset
42
43(define-class <gw-guile-ctype-void> (<gw-ctype-void> <gw-guile-rti-type>))
44(define-class <gw-guile-ctype-mchars> (<gw-ctype-mchars> <gw-guile-rti-type>))
45
46(define-class <standard-wrapset> (<gw-guile-wrapset>
47				  <gw-standard-wrapset>)
48   #:id 'standard
49   #:types `((void ,<gw-guile-ctype-void>)
50	     (mchars ,<gw-guile-ctype-mchars>)))
51
52(define-method (initialize (wrapset <standard-wrapset>) initargs)
53  (next-method wrapset (append '(#:module (g-wrap gw standard) #:shlib-abs? #t) initargs))
54
55  ;; SCM - pass scheme pointers through unmolested.
56  (wrap-simple-type! wrapset
57		     #:name 'scm
58		     #:c-type-name "SCM"
59		     #:type-check '("1")
60		     #:ffspec 'pointer ;; FIXME: not accurate
61		     #:unwrap '(c-var " = " scm-var ";\n")
62		     #:wrap '(scm-var " = " c-var ";\n"))
63
64  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
65  ;; <gw:wct> - wrapped c pointer type object
66  (wrap-simple-type! wrapset
67		     #:name '<gw:wct>
68		     #:c-type-name "SCM"
69		     #:type-check '("gw_wct_p(" scm-var ")")
70		     #:unwrap '(c-var " = " scm-var ";\n")
71		     #:wrap '(scm-var " = " c-var ";\n")
72		     #:ffspec 'pointer) ;; not accurate
73
74  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
75  ;; <gw:wcp> - wrapped c pointer object
76  (wrap-simple-type! wrapset
77		     #:name '<gw:wcp>
78		     #:c-type-name "SCM"
79		     #:type-check '("gw_wcp_p(" scm-var ")")
80		     #:unwrap '(c-var " = " scm-var ";\n")
81		     #:wrap '(scm-var " = " c-var ";\n")
82		     #:ffspec 'pointer) ;; not accurate
83
84  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
85  ;; <gw:void*> - wrapped c pointer object
86  (wrap-as-wct! wrapset
87		#:name '<gw:void*>
88		#:c-type-name "void *"
89		#:c-const-type-name "const void *")
90
91  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
92  ;; Wrapped functions...
93
94  (wrap-function! wrapset
95		  #:name  'gw:wct?
96		  #:returns 'bool
97		  #:c-name "gw_wct_p"
98		  #:arguments '((scm obj))
99		  #:description "Is obj a gw:wct?")
100
101  (wrap-function! wrapset
102		  #:name 'gw:wcp?
103		  #:returns 'bool
104		  #:c-name "gw_wcp_p"
105		  #:arguments '((scm obj))
106		  #:description "Is obj a gw:wcp?")
107
108  (wrap-function! wrapset
109		  #:name 'gw:wcp-is-of-type?
110		  #:returns 'bool
111		  #:c-name "gw_wcp_is_of_type_p"
112		  #:arguments '((<gw:wct> type) (<gw:wcp> wcp))
113		  #:description
114"Returns #f iff the given wcp is not of the type specified.  type must be a
115g-wrap wrapped c type object, usually available via global bindings.  For
116example (gw:wcp-is-a? <gw:void*> foo)")
117
118  (wrap-function! wrapset
119		  #:name 'gw:wcp-coerce
120		  #:returns '<gw:wcp>
121		  #:c-name "gw_wcp_coerce"
122		  #:arguments '((<gw:wcp> wcp) (<gw:wct> new-type))
123		  #:description "Coerce the given wcp to new-type.  This can be dangerous, so be careful.")
124
125  (wrap-function! wrapset
126		  #:name '%gw:procedure->method-public
127		  #:returns 'void
128		  #:arguments '((scm proc) (scm class_name)
129				(scm generic-name) (scm n_req_args)
130				(scm use_optional_args))
131		  #:c-name "gw_guile_procedure_to_method_public"))
132
133(define-method (add-type! (wrapset <standard-wrapset>)
134			  (type <gw-guile-simple-rti-type>))
135  (let ((info (assq-ref
136	       '((scm) (<gw:wct>) (<gw:wcp>)
137		 (bool #f
138		       (c-var "= SCM_NFALSEP(" scm-var ");\n")
139		       (scm-var "= (" c-var ") ? SCM_BOOL_T : SCM_BOOL_F;\n")
140		       <boolean>)
141
142		 (char ("SCM_NFALSEP(scm_char_p(" scm-var "))")
143		       (c-var "= SCM_CHAR(" scm-var ");\n")
144		       (scm-var "= SCM_MAKE_CHAR(" c-var ");\n")
145		       <char>)
146
147		 (unsigned-char ("SCM_NFALSEP(scm_char_p(" scm-var "))")
148				(c-var "= SCM_CHAR(" scm-var ");\n")
149				(scm-var "= SCM_MAKE_CHAR(" c-var ");\n")
150				<char>)
151
152		 (float ("SCM_NFALSEP(scm_number_p(" scm-var "))")
153			(c-var "= (float)scm_to_double (" scm-var ");\n")
154			(scm-var "= scm_from_double((double)" c-var ");\n")
155			<real>)
156
157		 (double ("SCM_NFALSEP(scm_number_p(" scm-var "))\n")
158			 (c-var "= scm_to_double (" scm-var ");\n")
159			 (scm-var "= scm_from_double (" c-var ");\n")
160			 <real>))
161	       (name type))))
162    (cond ((null? info)
163	   (next-method))
164	  ((not info)
165	   ;; FIXME: Use a condition
166	   (error "attempt to wrap unknown simple type" (name type)))
167	  (else
168	   (slot-set! type 'type-check (list-ref info 0))
169	   (slot-set! type 'unwrap (list-ref info 1))
170	   (slot-set! type 'wrap (list-ref info 2))
171	   (slot-set! type 'class-name (list-ref info 3))
172	   (next-method)))))
173
174
175;;;
176;;; <gw-guile-ctype-void>
177;;;
178
179(define-method (wrap-value-cg (type <gw-guile-ctype-void>)
180			      (value <gw-value>) error-var
181			      (inlined? <boolean>))
182  (list (scm-var value) " = SCM_UNSPECIFIED;\n"))
183
184(define-method (post-call-result-cg (type <gw-guile-ctype-void>)
185				    (result <gw-value>)
186				    status-var)
187  (list (scm-var result) " = SCM_UNSPECIFIED;\n"))
188
189;;;
190;;; <gw-guile-ranged-integer-type>
191;;;
192(define-class <gw-guile-ranged-integer-type> (<gw-ranged-integer-type>
193					      <gw-guile-rti-type>)
194  (wrap #:init-keyword #:wrap)
195  (unwrap #:init-keyword #:unwrap))
196
197(define <ranged-integer-type> <gw-guile-ranged-integer-type>) ; Lazy ;)
198
199;; Returns a string, representing the guile "name" of the type. The
200;; "name" will be used to build the names of the conversion functions
201;; for that type. This means the types don't have to exactly match,
202;; but the "name" returned must indictate a type large enough to hold
203;; the type @var{type}.
204(define (ranged-integer-name type)
205  (let ((special (assq-ref '((unsigned-short . "ushort")
206			     (unsigned-int . "uint")
207			     (unsigned-long . "ulong")
208			     (long-long . "long_long")
209			     (unsigned-long-long . "ulong_long")
210			     (int8 . "short")
211			     (int16 . "int")
212			     (int32 . "long")
213			     (int64 . "long_long")
214			     (unsigned-int8 . "ushort")
215			     (unsigned-int16 . "uint")
216			     (size_t . "ulong")
217			     (ssize_t . "long")
218			     (unsigned-int32 . "ulong")
219			     (unsigned-int64 . "ulong_long"))
220			   (name type))))
221    (if special
222	special
223	(symbol->string (name type)))))
224
225(define-method (wrap-ranged-integer-type! (wrapset <standard-wrapset>) . args)
226  (let* ((type (apply make <ranged-integer-type> args))
227	 (name (ranged-integer-name type)))
228    (slot-set! type 'wrap (string-append "scm_from_" name))
229    (slot-set! type 'unwrap (string-append "scm_to_" name))
230    (slot-set! type 'class-name '<integer>)
231    (add-type! wrapset type)))
232
233(define-method (add-type! (wrapset <standard-wrapset>)
234			  (type <ranged-integer-type>))
235  (next-method)
236  (slot-set! wrapset 'use-limits? #t))
237
238(define-method (initialize (type <ranged-integer-type>) initargs)
239  (next-method)
240  (let ((c-sym-name (any-str->c-sym-str (c-type-name type))))
241    (slot-set! type 'min-var
242	       (gen-c-tmp (string-append "range_minval" c-sym-name)))
243    (slot-set! type 'max-var
244	       (gen-c-tmp (string-append "range_minval" c-sym-name)))))
245
246(define-method (wrap-value-cg (type <ranged-integer-type>)
247			      (value <gw-value>)
248			      error-var
249			      (inlined? <boolean>))
250  (list (scm-var value) " = " (slot-ref type 'wrap) "(" (var value) ");\n"))
251
252(define-method (unwrap-value-cg (type <ranged-integer-type>)
253				(value <gw-value>)
254				error-var
255				(inlined? <boolean>))
256  (let ((scm-var (scm-var value))
257	(c-var (var value))
258	(minvar (slot-ref type 'min-var))
259	(maxvar (slot-ref type 'max-var)))
260    (list "if(SCM_FALSEP(scm_integer_p(" scm-var ")))"
261	  `(gw:error ,error-var type ,(wrapped-var value))
262	  (if (slot-ref type 'min)
263	      (list
264	       "else if(SCM_FALSEP(scm_geq_p(" scm-var ", " minvar "))"
265	       "        || SCM_FALSEP(scm_leq_p(" scm-var ", " maxvar ")))")
266	      (list
267	       "else if(SCM_NFALSEP(scm_negative_p(" scm-var "))"
268	       "        || SCM_FALSEP(scm_leq_p(" scm-var ", " maxvar ")))"))
269	  `(gw:error ,error-var range ,(wrapped-var value))
270	  "else {\n"
271	  ;; here we pass NULL and 0 as the callers because we've already
272	  ;; checked the bounds on the argument
273	  "  " c-var " = " (slot-ref type 'unwrap) "(" scm-var ");\n"
274	  "}\n")))
275
276
277(define-method (global-declarations-cg
278				       (wrapset <gw-guile-wrapset>)
279				       (type <ranged-integer-type>))
280;  (format #t "global-declarations-cg/guile-wrapset~%")
281  (list
282   (next-method)
283   (if (slot-ref type 'min)
284       (list "static SCM " (slot-ref type 'min-var) ";\n")
285       '())
286   "static SCM " (slot-ref type 'max-var) ";\n"))
287
288(define (minmax-var-init-cg type)
289  (let ((minvar (slot-ref type 'min-var))
290	(maxvar (slot-ref type 'max-var))
291	(minval (slot-ref type 'min))
292	(maxval (slot-ref type 'max)))
293    (list
294     (if minval
295	 (list minvar " = " (slot-ref type 'wrap) "(" minval ");\n"
296	       "scm_gc_protect_object(" minvar ");\n")
297	 '())
298     maxvar " = " (slot-ref type 'wrap) "(" maxval ");\n"
299     "scm_gc_protect_object(" maxvar ");\n")))
300
301(define-method (initializations-cg (wrapset <gw-guile-wrapset>)
302				   (type <ranged-integer-type>)
303				   error-var)
304  (list
305   (next-method)
306   (minmax-var-init-cg type)))
307
308(define-method (client-global-declarations-cg (wrapset <gw-guile-wrapset>)
309					      (type <ranged-integer-type>))
310  (global-declarations-cg wrapset type))
311
312(define-method (client-initializations-cg (wrapset <gw-guile-wrapset>)
313					  (type <ranged-integer-type>)
314					  error-var)
315  (minmax-var-init-cg type))
316
317
318;;;
319;;; <gw-guile-ctype-mchars>
320;;;
321
322(define-method (initialize (self <gw-guile-ctype-mchars>) initargs)
323  (next-method self (append '(#:class-name <string>) initargs)))
324
325(define-method (parse-typespec-option! (typespec <gw-typespec>)
326				       (type <gw-guile-ctype-mchars>)
327				       (option <symbol>))
328  (next-method)
329  (if (eq? 'null-ok option)
330      (add-option! typespec 'unspecialized))) ;; can't pass #f for <string>
331
332(define-method (wrap-value-cg (type <gw-guile-ctype-mchars>)
333			      (value <gw-value>)
334			      error-var
335			      (inlined? <boolean>))
336  (list
337   "if (" (var value) " == NULL) " (scm-var value) " = SCM_BOOL_F;\n"
338   "else "
339   (scm-var  value)
340   (let* ((ts (typespec value))
341	  (opts (if ts (options ts) '())))
342     ;; When the string is `out' and `caller-owned', we must take the C
343     ;; string, i.e., take control over its underlying memory.
344     (if (and (memq 'caller-owned opts) (memq 'out opts))
345	 " = scm_take_locale_string ("
346	 " = scm_from_locale_string ("))
347   (var value) ");\n"))
348
349(define-method (unwrap-value-cg (type <gw-guile-ctype-mchars>)
350				(value <gw-value>)
351				error-var
352				(inlined? <boolean>))
353  (let ((c-var (var value))
354	(scm-var (scm-var value))
355	(c-size-var (gen-c-tmp "_size")))
356    (let ((unwrap-code
357	   (list
358	    "if (scm_is_string (" scm-var ")) {\n"
359	    ;; We can't use `scm_i_string_chars ()' here because it returns a
360	    ;; non-zero terminated string.  So, no matter whether VALUE is
361	    ;; caller-owned or not, we have to allocate a new string a free
362	    ;; it afterwards.
363	    (if (not inlined?)
364		;; allocate a new C string on the heap.
365		(list c-var " = scm_to_locale_string ("scm-var");\n")
366
367		;; allocate a new C string on the stack rather.
368		(list "{\n"
369		      "size_t "c-size-var " = "
370		      "scm_c_string_length ("scm-var");\n"
371		      c-var " = alloca ("c-size-var" + 1);\n"
372		      "scm_to_locale_stringbuf ("scm-var", (char*)"c-var",\n"
373		      "                         "c-size-var");\n"
374		      "((char*)"c-var")["c-size-var"] = '\\0';\n"
375		      "}\n"))
376
377	    "} else\n"
378	    "{  " c-var " = NULL;\n"
379	    `(gw:error ,error-var type ,(wrapped-var value))
380	    "\n}\n")))
381      (if-typespec-option
382       value 'null-ok
383       (list "if (SCM_FALSEP(" scm-var "))\n"
384	     "  " c-var " = NULL;\n"
385	     "else {"
386	     unwrap-code
387	     "}\n")
388       unwrap-code))))
389
390(define-method (destroy-value-cg (type <gw-guile-ctype-mchars>)
391				 (value <gw-value>)
392				 error-var
393				 (inlined? <boolean>))
394  ;; `destroy-value-cg' is not called on `out' values that have just been
395  ;; passed to `wrap-value-cg', so we don't have to worry about this case.
396  (if-typespec-option value 'caller-owned
397		      (if (not inlined?)
398			  (list "\n{\n"
399				"/* Free the string that was allocated "
400				"by `scm_to_locale_string ()' \n"
401				"   in `unwrap-value'.  */\n"
402				"if ("(var value)" != NULL)\n"
403				"  free ((char*)"(var value)");\n"
404				"}\n")
405			  '())
406		      '()))
407