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