1;;;; File: guile.scm 2;;;; Copyright (C) 2004-2007, 2010, 2011 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; This module extends the G-Wrap core with support for Guile Scheme. 27;; 28;;; Code: 29 30(define-module (g-wrap guile) 31 #:use-module (srfi srfi-1) 32 #:use-module (srfi srfi-13) 33 34 #:use-module (oop goops) 35 #:use-module (ice-9 optargs) 36 37 #:use-module (g-wrap) 38 #:use-module (g-wrap util) 39 #:use-module (g-wrap rti) 40 #:use-module (g-wrap enumeration) 41 #:use-module (g-wrap c-types) 42 #:use-module (g-wrap c-codegen) 43 44 #:export (inline-scheme 45 46 <gw-guile-wrapset> 47 module module-exports 48 add-module-export! 49 50 <gw-guile-simple-type> 51 <gw-guile-simple-rti-type> 52 <gw-guile-rti-type> 53 scm-var)) 54 55 56;;; 57;;; Utilities 58;;; 59 60(define-method (scm-var (value <gw-value>)) 61 (string-append "*(SCM *)" (wrapped-var value))) 62 63(define-class <gw-guile-function> (<gw-function>) 64 wrapper-name wrapper-namestr) 65 66(define-method (initialize (func <gw-guile-function>) initargs) 67 (next-method) 68 69 (let ((c-name (c-name func))) 70 (slot-set! func 'wrapper-name 71 (gen-c-tmp (string-append c-name "_wrapper"))) 72 (slot-set! func 'wrapper-namestr 73 (gen-c-tmp (string-append c-name "_namestr"))))) 74 75 76 77;;; 78;;; Wrapset 79;;; 80 81(define-class <gw-guile-wrapset> (<gw-rti-wrapset>) 82 (module #:init-keyword #:module #:accessor module #:init-value #f) 83 (module-exports #:getter module-exports #:init-value '()) 84 (shlib-path #:init-keyword #:shlib-path) 85 (shlib-abs? #:init-keyword #:shlib-abs? #:init-value #f) 86 87 #:language 'guile) 88 89(define-method (global-definitions-cg (wrapset <gw-guile-wrapset>)) 90 (let ((wrapset-name-c-sym (any-str->c-sym-str 91 (symbol->string (name wrapset))))) 92 (list 93 (next-method) 94 "void gw_init_wrapset_" wrapset-name-c-sym "(void);\n" 95 "void gw_init_wrapset_" wrapset-name-c-sym "(void)\n" 96 "{\n" 97 " gw_initialize_wrapset_" wrapset-name-c-sym "(NULL);\n" 98 "}\n"))) 99 100(define-method (global-declarations-cg (wrapset <gw-guile-wrapset>)) 101 (list 102 (next-method) 103 "#include <g-wrap/guile-runtime.h>\n")) 104 105(define-method (initializations-cg (wrapset <gw-guile-wrapset>) err) 106 (list 107 "gw_guile_runtime_init ();\n" 108 (next-method))) 109 110(define-method (initialize (wrapset <gw-guile-wrapset>) initargs) 111 (next-method wrapset (append (list #:function-class <gw-guile-function>) 112 initargs)) 113 (if (not (slot-bound? wrapset 'shlib-path)) 114 (slot-set! wrapset 'shlib-path 115 (string-append "libgw-guile-" 116 (symbol->string (name wrapset)))))) 117 118;;; Additional methods 119 120(define-method (add-module-export! (ws <gw-guile-wrapset>) (sym <symbol>)) 121 (slot-push! ws 'module-exports sym)) 122 123(define (scm-form-str->safe-c-str name) 124 (define (char->string-replacement char) 125 (case char 126 ((#\") "\\\"") 127 ((#\newline) "\\n") 128 (else (string char)))) 129 (apply 130 string-append 131 (map 132 char->string-replacement 133 (string->list name)))) 134 135(define-method (inline-scheme (ws <gw-guile-wrapset>) . code-chunks) 136 (map 137 (lambda (chunk) 138 (list "scm_c_eval_string(\"" 139 (scm-form-str->safe-c-str 140 (call-with-output-string 141 (lambda (port) 142 (write chunk port)))) 143 "\");\n")) 144 code-chunks)) 145 146;;; Refined methods 147 148(define-method (initializations-cg (wrapset <gw-guile-wrapset>) 149 (constant <gw-constant>) error-var) 150 (let* ((scm-var (gen-c-tmp "scm_wrapped_value")) 151 (wrap-value-code 152 (wrap-value-cg (type constant) 153 (make <gw-value> 154 #:var (value constant) 155 #:wrapped-var (string-append "&" scm-var)) 156 error-var 157 #t))) 158 (list 159 "{\n" 160 " SCM " scm-var ";\n" 161 "\n" 162 wrap-value-code 163 "if (!" `(gw:error? ,error-var) ")" 164 " scm_c_define (\"" (symbol->string (name constant)) "\", " scm-var ");\n" 165 "}\n"))) 166 167(define-method (add-constant! (wrapset <gw-guile-wrapset>) 168 (constant <gw-constant>)) 169 (next-method) 170 (add-module-export! wrapset (name constant))) 171 172(define-method (add-function! (wrapset <gw-guile-wrapset>) 173 (func <gw-function>)) 174 175 (next-method) 176 (add-module-export! wrapset (name func))) 177 178 179;;; 180;;; Function wrappers 181;;; 182 183;; hardcoded here, should be extracted from SCM_SUBR_MAX at configure-time 184(define *max-fixed-params* 9) 185 186(define (make-c-wrapper-param-declarations param-list) 187 (let loop ((params param-list) 188 (index 0)) 189 (cond ((null? params) 190 '()) 191 ((and (= index *max-fixed-params*)) 192 "SCM gw__restargs ") 193 (else 194 (cons 195 (list 196 "SCM " "gw__scm_arg" (number->string index) 197 (if (null? (cdr params)) 198 " " 199 ", ")) 200 (loop (cdr params) (+ index 1))))))) 201 202(define (make-c-call-param-list params) 203 ;; TODO: Make tail-recursive 204 (cond ((null? params) '()) 205 (else 206 (let ((param (car params))) 207 (cons 208 (list 209 (call-arg-cg (type param) param) 210 (if (null? (cdr params)) 211 "" 212 ", ")) 213 (make-c-call-param-list (cdr params))))))) 214 215(define (actual-arguments function) 216 (map 217 (lambda (arg number c-number out-number) 218 (apply make <gw-param> 219 #:number number 220 #:typespec (typespec arg) 221 #:var (string-append "gw__c_arg" (number->string c-number)) 222 (cond 223 ((>= number 0) 224 `(#:wrapped-var 225 ,(if (< number *max-fixed-params*) 226 (string-append "&gw__scm_arg" (number->string number)) 227 (string-append 228 "&gw__scm_extras[" (number->string 229 (- number 230 *max-fixed-params*)) "]")))) 231 ((output-argument? arg) 232 `(#:wrapped-var 233 ,(string-append "& "(out-param-name out-number)))) 234 (else '())))) 235 (arguments function) 236 (let loop ((numbers '()) (args (arguments function)) (n 0)) 237 (if (null? args) 238 (reverse numbers) 239 (if (and (visible? (car args)) 240 (not (memq 'out (options (typespec (car args)))))) 241 (loop (cons n numbers) (cdr args) (+ n 1)) 242 (loop (cons -1 numbers) (cdr args) n)))) 243 (iota (argument-count function)) 244 (let loop ((numbers '()) (args (arguments function)) (n 0)) 245 (if (null? args) 246 (reverse numbers) 247 (if (memq 'out (options (typespec (car args)))) 248 (loop (cons n numbers) (cdr args) (+ n 1)) 249 (loop (cons -1 numbers) (cdr args) n)))) 250 )) 251 252;; FIXME: This is too unspecialized, so that it is more generic than 253;; the method for rti wrapsets. It should be refactored into core. 254(define-method (global-definitions-cg (wrapset <gw-guile-wrapset>) 255 (function <gw-guile-function>)) 256 (if (uses-rti-for-function? wrapset function) 257 '() 258 (function-wrapper-cg wrapset function))) 259 260(define (out-param-name number) 261 (string-append "gw__scm_out_arg" (number->string number))) 262 263(define (function-wrapper-cg wrapset function) 264 (let* ((params (actual-arguments function)) 265 (c-name (c-name function)) 266 (return-typespec (return-typespec function)) 267 (return-type (type return-typespec)) 268 (result (make <gw-value> 269 #:typespec return-typespec 270 #:wrapped-var "&gw__scm_result" 271 #:var "gw__result")) 272 (scm-params (filter (lambda (param) (and (visible? param) 273 (not (output-param? param)))) 274 params)) 275 276 (function-has-wcp-args? 277 (or (any (lambda (p) (is-a? (type p) <gw-wct>)) params) 278 (is-a? return-type <gw-wct>))) 279 (function-has-aggregated-args? 280 (any (lambda (p) (memq 'aggregated (options (typespec p)))) 281 params)) 282 283 (scheme-sym (symbol->string (name function))) 284 (param-decl (make-c-wrapper-param-declarations scm-params)) 285 (fn-c-wrapper (slot-ref function 'wrapper-name)) 286 (fn-c-string (slot-ref function 'wrapper-namestr)) 287 (nargs (length scm-params)) 288 (error-var "gw__error") 289 (labels (make <gw-cs-labels>)) 290 (out-params (filter (lambda (param) 291 (memq 'out (options (typespec param)))) 292 params))) 293 294 (list 295 "static char * " fn-c-string " = \"" scheme-sym "\";\n" 296 "static SCM " fn-c-wrapper " (" param-decl ") {\n" 297 (if (and function-has-wcp-args? function-has-aggregated-args?) 298 " SCM gw__scm_deps = SCM_EOL;\n" 299 (format #f " /* no WCP arguments: ret=~a */\n" 300 return-type)) 301 " SCM gw__scm_result = SCM_UNSPECIFIED;\n" 302 " GWError gw__error = { GW_ERR_NONE, NULL, NULL };\n" 303 " unsigned int gw__arg_pos = 0;\n" 304 (if (needs-result-var? return-type) 305 (let ((c-value (default-c-value-for-type return-type))) 306 (list 307 ;; Initialize the C variable if possible. 308 (c-type-name return-type return-typespec) " " (var result) 309 (if (string? c-value) 310 (string-append " = " c-value ";\n") 311 ";\n"))) 312 '()) 313 314 (if (> nargs *max-fixed-params*) 315 (list " SCM gw__scm_extras[" (- nargs *max-fixed-params*) "];\n") 316 '()) 317 318 (filter-map 319 (lambda (number out-param) 320 (and (visible? out-param) 321 (list " SCM " (out-param-name number) " = SCM_UNSPECIFIED;\n"))) 322 (iota (length out-params)) 323 out-params) 324 325 "\n" 326 327 (map 328 (lambda (param) 329 (list (c-type-name (type param)) " " (var param) 330 (if (output-param? param) 331 ;; Initialize the C variable for the `out' parameter if 332 ;; possible. 333 (let ((c-value 334 (default-c-value-for-type (type param)))) 335 (if (string? c-value) 336 (string-append " = " c-value ";\n") 337 ";\n")) 338 ";\n"))) 339 params) 340 341 (map 342 (lambda (param arg) 343 (list 344 (if (and (not (output-param? param)) (visible? param)) 345 (list 346 "/* ARG " (number param) " */\n" 347 (if (memq 'aggregated (options (typespec param))) 348 ;; Arguments that are aggregated by a return value are a 349 ;; dependency of this return value and need to be marked 350 ;; as such. 351 (string-append "/* arg " (number->string (number param)) 352 " will be aggregated by the result" 353 " (further referred to) */\n" 354 "gw__scm_deps = scm_cons (" 355 (scm-var param) ", gw__scm_deps);\n") 356 "") 357 "gw__arg_pos++;\n" 358 (if (>= (number param) *max-fixed-params*) 359 (list 360 "if (SCM_NULLP (gw__restargs))\n" 361 (if (default-value arg) 362 (list 363 " " (scm-var param) "= SCM_UNDEFINED;\n") 364 (list 365 "{\n" 366 " (" error-var ").status = GW_ERR_ARGC;\n" 367 " " (goto-cg labels 368 (if (zero? (number param)) 369 "wrapper_exit" 370 (format #f "post_call_arg_~A" 371 (- (number param) 1)))) 372 "}\n")) 373 "else {\n" 374 " " (scm-var param) " = SCM_CAR (gw__restargs);\n" 375 " gw__restargs = SCM_CDR (gw__restargs);\n" 376 "}\n") 377 '())) 378 (list "/* ARG " (number param) " (invisible) */\n")) 379 "\n{\n" 380 (if (output-param? param) 381 '() 382 (let ((pre-call-code 383 (expand-special-forms 384 (pre-call-arg-cg (type param) param error-var) 385 param 386 '(memory misc type range arg-type arg-range) 387 #:labels labels))) 388 (if (default-value arg) 389 (list 390 "if (scm_is_eq (" (scm-var param) ", SCM_UNDEFINED))\n" 391 " " (set-value-cg (type arg) param 392 (default-value arg)) 393 "else {\n" 394 pre-call-code 395 "}\n") 396 pre-call-code))))) 397 params (arguments function)) 398 399 "if ((" error-var ").status == GW_ERR_NONE)\n" 400 "{\n" 401 (expand-special-forms 402 (pre-call-result-cg return-type result error-var) 403 #f '(memory misc type range)) 404 405 (let* ((func-call-code 406 (list c-name " (" (make-c-call-param-list params) ")")) 407 (call-code (call-cg return-type result func-call-code 408 error-var))) 409 (if (not (no-op? call-code)) 410 (list 411 "if ((" error-var ").status != GW_ERR_NONE)" 412 " " (goto-cg labels 413 (if (zero? nargs) 414 "wrapper_exit" 415 (format #f "post_call_arg_~A" (- nargs 1)))) 416 (expand-special-forms call-code #f '(memory misc type range))) 417 "/* no function call requested! */\n")) 418 419 "{\n/* post-call-result-cg */\n" 420 (expand-special-forms 421 (post-call-result-cg return-type result error-var) 422 #f '(memory misc type range)) 423 "}\n" 424 "}\n" 425 426 ;; insert the post-call args code in the opposite order 427 ;; of the pre-call code 428 (map 429 (lambda (param) 430 (list 431 (label-cg labels (format #f "post_call_arg_~A" (number param))) 432 (let ((post-call-code 433 (expand-special-forms 434 (post-call-arg-cg (type param) param error-var) 435 #f '(memory misc type range)))) 436 (if (no-op? post-call-code) 437 '() 438 (list "{\n" post-call-code "}\n"))) 439 "}\n")) 440 (reverse params)) 441 442 (if (and function-has-wcp-args? function-has-aggregated-args?) 443 ;; Since some of the input arguments are aggregated by the output 444 ;; arguments or the return value, iterate over the each output 445 ;; argument and generate code that marks the aggregated objects as 446 ;; its dependencies. Same for the return value. 447 (append (mark-dependencies-cg (scm-var result)) 448 (map (lambda (param) 449 (if-typespec-option param 'out 450 (mark-dependencies-cg 451 (scm-var param)) 452 '())) 453 params)) 454 '()) 455 456 " " (label-cg labels "wrapper_exit") 457 " if(gw__error.status != GW_ERR_NONE)\n" 458 " gw_handle_wrapper_error(NULL, &gw__error,\n" 459 " " fn-c-string ",\n" 460 " gw__arg_pos);\n" 461 (cond ((null? out-params) 462 " return gw__scm_result;\n") 463 ((and (not (needs-result-var? return-type)) 464 (null? (cdr out-params))) 465 (list " return (" (out-param-name 0) ");\n")) 466 (else 467 (list 468 " return scm_values (scm_list_n (" 469 (if (needs-result-var? return-type) 470 "gw__scm_result, " 471 '()) 472 (filter-map (lambda (n out-param) 473 (and (visible? out-param) 474 (string-append (out-param-name n) ", "))) 475 (iota (length out-params)) 476 out-params) 477 "SCM_UNDEFINED));\n"))) 478 "}\n"))) 479 480;; RTI functions override this method 481(define-method (initializations-cg (wrapset <gw-wrapset>) 482 (function <gw-guile-function>) 483 status-var) 484 485 (let* ((visible-args (input-arguments function)) 486 (n-visible-args (length visible-args)) 487 (n-optional-visible-args (length (filter identity 488 (map default-value visible-args)))) 489 (n-req-args (- n-visible-args n-optional-visible-args)) 490 (fn-c-wrapper (slot-ref function 'wrapper-name)) 491 (fn-c-string (slot-ref function 'wrapper-namestr)) 492 (flags-c-string (flags function))) 493 (list 494 " gw_wrapset_add_function(" (c-info-sym wrapset) ", " 495 fn-c-wrapper ", " n-req-args ", " n-optional-visible-args ", " 496 "NULL, 0, NULL, NULL, " fn-c-string ", " 497 (if (generic-name function) 498 (list "\"" (symbol->string (generic-name function)) "\"") 499 "NULL") 500 ", " flags-c-string 501 ");\n"))) 502 503 504;;; 505;;; RTI 506;;; 507 508(define-class <gw-guile-rti-type> (<gw-rti-type>)) 509 510;; TODO: We don' get full error messages yet (#f passed as param to 511;; expand-special-forms) 512 513(define-method (wrap-value-function-cg (type <gw-guile-rti-type>)) 514 (let* ((type-name (c-type-name type)) 515 (value (make <gw-rti-value> 516 #:var (string-append "(*(" type-name "*)instance)") 517 #:typespec #f ;; the typespec is passed in the function 518 #:wrapped-var "value"))) 519 (list 520 "static void " (wrap-value-function-name type) 521 "(GWLangLocative value, GWLangArena arena, const GWTypeSpec *typespec, void *instance, GWError *error) {\n" 522 " " 523 ;; Invoke `wrap-value-cg' so that it produces non-inlined code. 524 (expand-special-forms (wrap-value-cg type value "*error" #f) 525 #f '(type arg-type range memory misc)) 526 "}\n"))) 527 528 529(define-method (unwrap-value-function-cg (type <gw-guile-rti-type>)) 530 (let* ((type-name (c-type-name type)) 531 (value (make <gw-rti-value> 532 #:var (string-append "(*(" type-name "*)instance)") 533 #:typespec #f ;; the typespec is passed in the function 534 #:wrapped-var "value"))) 535 (list 536 "static void " (unwrap-value-function-name type) 537 "(void *instance, GWLangArena arena, const GWTypeSpec *typespec, GWLangLocative value, GWError *error) {\n" 538 " " 539 ;; Invoke `unwrap-value-cg' so that it produces non-inlined code. 540 (expand-special-forms (unwrap-value-cg type value "*error" #f) 541 #f '(type arg-type range memory misc)) 542 "}\n"))) 543 544(define-method (destroy-value-function-cg (type <gw-guile-rti-type>)) 545 546 (let* ((type-name (c-type-name type)) 547 (value (make <gw-rti-value> 548 #:var (string-append "(*(" type-name "*)instance)") 549 #:typespec #f ;; the typespec is passed in the function 550 #:wrapped-var "value"))) 551 (list 552 "static void " (destroy-value-function-name type) 553 "(GWLangArena arena, void *instance, const GWTypeSpec *typespec, GWError *error) {\n" 554 " " 555 ;; Invoke `destroy-value-cg' so that it produces non-inlined code. 556 (expand-special-forms (destroy-value-cg type value "*error" #f) 557 #f '(type arg-type range memory misc)) 558 "}\n"))) 559 560;;; 561;;; Enumerations 562;;; 563 564(define-class <gw-guile-enum> (<gw-enumeration-type> <gw-guile-rti-type>) 565 val->int-c-func 566 val->int-scm-func 567 val->sym-c-func 568 val->sym-scm-func) 569 570(define-method (initialize (enum <gw-guile-enum>) initargs) 571 (next-method) 572 (let-keywords 573 initargs #t ((prefix "enum-")) 574 575 (define (gen-name action) (gen-c-tmp-name enum action)) ;; Just lazy 576 (define (enum-prefix) 577 (string-append prefix (symbol->string (name enum)))) 578 579 (slot-set! enum 'val->int-c-func (gen-name "val_to_int")) 580 (slot-set! enum 'val->int-scm-func 581 (string-append (enum-prefix) "-val->int")) 582 583 (slot-set! enum 'val->sym-c-func (gen-name "val_to_sym")) 584 (slot-set! enum 'val->sym-scm-func 585 (string-append (enum-prefix) "-val->sym")))) 586 587(define-method (global-definitions-cg (wrapset <gw-guile-wrapset>) 588 (enum <gw-enumeration-type>)) 589 (list 590 (next-method) 591 592 "static SCM " (slot-ref enum 'val->sym-c-func) 593 "(SCM gw__scm_val, SCM gw__scm_show_all_p) {\n" 594 " return gw_guile_enum_val2sym(" (val-array-name enum) ", " 595 " gw__scm_val, gw__scm_show_all_p);\n" 596 "}\n" 597 "\n" 598 "static SCM " (slot-ref enum 'val->int-c-func) "(SCM gw__scm_val) {\n" 599 " return gw_guile_enum_val2int(" (val-array-name enum) ", gw__scm_val);\n" 600 "}\n")) 601 602(define-method (initializations-cg (wrapset <gw-guile-wrapset>) 603 (enum <gw-enumeration-type>) 604 error-var) 605 (list 606 (next-method) 607 608 "scm_c_define_gsubr (\"" (slot-ref enum 'val->int-scm-func) "\", 1, 0, 0,\n" 609 " " (slot-ref enum 'val->int-c-func) ");\n" 610 "scm_c_define_gsubr (\"" (slot-ref enum 'val->sym-scm-func) "\", 2, 0, 0,\n" 611 " " (slot-ref enum 'val->sym-c-func) ");\n")) 612 613(define-method (wrap-value-cg (type <gw-guile-enum>) 614 (value <gw-value>) 615 status-var 616 (inlined? <boolean>)) 617 (list (scm-var value) " = scm_from_long (" (var value) ");\n")) 618 619(define-method (unwrap-value-cg (enum <gw-guile-enum>) 620 (value <gw-value>) 621 status-var 622 (inlined? <boolean>)) 623 (let ((scm-var (scm-var value)) 624 (c-var (var value)) 625 (val-sym-array-name (val-array-name enum))) 626 (list 627 scm-var " = gw_guile_enum_val2int(" val-sym-array-name ", " scm-var ");\n" 628 "if (SCM_FALSEP (scm_integer_p(" scm-var ")))" 629 `(gw:error ,status-var type ,(wrapped-var value)) 630 "else " c-var " = scm_to_long (" scm-var ");\n"))) 631 632(define-method (wrap-enum! (wrapset <gw-guile-wrapset>) . args) 633 634 (define (slot-sym-ref v slot) 635 (string->symbol (slot-ref v slot))) 636 637 (let ((enum (apply make <gw-guile-enum> args))) 638 (add-type! wrapset enum) 639 (add-module-export! wrapset (slot-sym-ref enum 'val->int-scm-func)) 640 (add-module-export! wrapset (slot-sym-ref enum 'val->sym-scm-func)) 641 enum)) 642 643 644 645;;; 646;;; Simple Types 647;;; 648 649(define-class <gw-guile-simple-type-base> () 650 (type-check #:init-keyword #:type-check) 651 (wrap #:init-keyword #:wrap) 652 (unwrap #:init-keyword #:unwrap)) 653 654;; Helper 655(define (replace-syms tree alist) 656 (cond 657 ((null? tree) tree) 658 ((list? tree) (map (lambda (elt) (replace-syms elt alist)) tree)) 659 ((symbol? tree) 660 (let ((expansion (assq-ref alist tree))) 661 (if (string? expansion) 662 expansion 663 (error 664 (string-append 665 "g-wrap expected string for expansion " 666 "while processing ~S\n.") expansion)))) 667 (else tree))) 668 669(define-method (unwrap-value-cg (type <gw-guile-simple-type-base>) 670 (value <gw-value>) 671 status-var 672 (inlined? <boolean>)) 673 (let* ((scm-var (scm-var value)) 674 (c-var (var value)) 675 (unwrap-code (replace-syms (slot-ref type 'unwrap) 676 `((c-var . ,c-var) 677 (scm-var . ,scm-var)))) 678 (type-check (slot-ref type 'type-check))) 679 (if type-check 680 (list "if (!(" (replace-syms type-check `((scm-var . ,scm-var))) "))" 681 `(gw:error ,status-var type ,(wrapped-var value)) 682 "else {" unwrap-code "}") 683 unwrap-code))) 684 685(define-method (wrap-value-cg (type <gw-guile-simple-type-base>) 686 (value <gw-value>) 687 status-var 688 (inlined? <boolean>)) 689 (replace-syms (slot-ref type 'wrap) 690 `((c-var . ,(var value)) 691 (scm-var . ,(scm-var value))))) 692 693(define-class <gw-guile-simple-rti-type> (<gw-guile-simple-type-base> 694 <gw-simple-rti-type> 695 <gw-guile-rti-type>)) 696 697;; This class is mainly for compatibility: it's like 698;; <gw-guile-simple-rti-type>, but doesn't require an ffspec 699(define-class <gw-guile-simple-type> (<gw-guile-simple-type-base> <gw-type>) 700 (c-type-name #:getter c-type-name #:init-keyword #:c-type-name) 701 (c-const-type-name #:init-keyword #:c-const-type-name)) 702 703(define-method (c-type-name (type <gw-guile-simple-type>) 704 (typespec <gw-typespec>)) 705 (slot-ref type (if (memq 'const (options typespec)) 706 'c-const-type-name 707 'c-type-name))) 708 709(define-method (wrap-simple-type! (wrapset <gw-guile-wrapset>) . args) 710 (let* ((class (if (member #:ffspec args) 711 <gw-guile-simple-rti-type> 712 <gw-guile-simple-type>)) 713 (type (apply make class args))) 714 (add-type! wrapset type) 715 type)) 716 717 718;;; 719;;; Wrapped C Types 720;;; 721 722(define-class <gw-guile-wct> (<gw-wct> <gw-guile-rti-type>) 723 wct-var-name) 724 725(define-method (wrap-as-wct! (wrapset <gw-guile-wrapset>) . args) 726 (let ((type (apply make <gw-guile-wct> args))) 727 (add-module-export! wrapset (name type)) 728 (add-type! wrapset type) 729 type)) 730 731(define-method (initialize (wct <gw-guile-wct>) initargs) 732 (next-method) 733 (slot-set! wct 'wct-var-name 734 (gen-c-tmp (string-append 735 "wct_info_for" 736 (any-str->c-sym-str (symbol->string (name wct))))))) 737 738(define-method (wrap-value-cg (wct <gw-guile-wct>) 739 (value <gw-value>) 740 status-var 741 (inlined? <boolean>)) 742 (let ((wct-var (slot-ref wct 'wct-var-name)) 743 (sv (scm-var value)) 744 (cv (var value))) 745 (list 746 "if(" cv " == NULL) " sv " = SCM_BOOL_F;\n" 747 "else {\n" 748 sv " = gw_wcp_assimilate_ptr((void *) " cv ", " wct-var ");\n" 749 "}\n"))) 750 751 752(define-method (unwrap-value-cg (wct <gw-guile-wct>) 753 (value <gw-value>) 754 status-var 755 (inlined? <boolean>)) 756 (let* ((wct-var (slot-ref wct 'wct-var-name)) 757 (sv (scm-var value)) 758 (c-var (var value)) 759 (unwrap-code 760 (list "if (gw_wcp_is_of_type_p (" wct-var ", " sv "))\n" 761 " " c-var " = gw_wcp_get_ptr (" sv ");\n" 762 "else\n" 763 `(gw:error ,status-var type ,(wrapped-var value))))) 764 765 (list 766 (if-typespec-option value 'null-ok 767 (list "if (SCM_FALSEP (" sv "))\n" 768 " " c-var " = NULL;\n" 769 "else " unwrap-code) 770 unwrap-code)))) 771 772 773(define (mark-dependencies-cg out-scm-var) 774 ;; Set the dependencies of OUT-SCM-VAR, a WCP being returned. 775 (list "\n{\n" 776 "if ((gw__scm_deps != SCM_EOL) && (SCM_NIMP ("out-scm-var")))\n" 777 " gw_wcp_set_dependencies (" out-scm-var ", " 778 "gw__scm_deps);\n" 779 "}\n")) 780 781(define-method (post-call-result-cg (return-type <gw-guile-wct>) 782 (result <gw-value>) error-var) 783 (next-method)) 784 785(define-method (post-call-arg-cg (arg-type <gw-guile-wct>) 786 (arg <gw-value>) error-var) 787 (next-method)) 788 789 790(define-method (initializations-cg (wrapset <gw-wrapset>) 791 (wct <gw-guile-wct>) 792 error-var) 793 (let ((wct-var (slot-ref wct 'wct-var-name)) 794 (wcp-type-name (symbol->string (name wct))) 795 (wcp-mark (wcp-mark-function wct)) 796 (wcp-free (wcp-free-function wct)) 797 (wcp-equal? (wcp-equal-predicate wct))) 798 (list 799 (next-method) 800 801 wct-var "= gw_wct_create (\"" wcp-type-name "\", " wcp-equal? ", NULL, " 802 wcp-mark ", " wcp-free ");\n" 803 "scm_c_define(\"" wcp-type-name "\", " wct-var ");\n"))) 804 805(define (wct-var-decl-cg wct) 806 (list "static SCM " (slot-ref wct 'wct-var-name) " = SCM_BOOL_F;\n")) 807 808(define-method (global-declarations-cg (wrapset <gw-wrapset>) 809 (wct <gw-guile-wct>)) 810 (wct-var-decl-cg wct)) 811 812(define-method (client-global-declarations-cg (wrapset <gw-wrapset>) 813 (wct <gw-guile-wct>)) 814 (wct-var-decl-cg wct)) 815 816(define-method (client-initializations-cg (wrapset <gw-wrapset>) 817 (wct <gw-guile-wct>) 818 error-var) 819 (let ((wct-var (slot-ref wct 'wct-var-name)) 820 (wcp-type-name (symbol->string (name wct)))) 821 (list 822 " " wct-var " = scm_c_eval_string(\"" wcp-type-name "\");\n"))) 823 824 825;;; 826;;; Generation 827;;; 828 829(define (generate-wrapset-scm wrapset port) 830 (define (dsp-list lst) 831 (for-each (lambda (s) (display s port)) lst)) 832 833 (let* ((wrapset-name (name wrapset)) 834 (wrapset-name-c-sym (any-str->c-sym-str 835 (symbol->string wrapset-name))) 836 (guile-module (module wrapset)) 837 (module-dependencies 838 (filter-map module (wrapsets-depended-on wrapset)))) 839 840 (flatten-display 841 (list 842 ";; Generated by G-Wrap-TNG: an experimental Guile C API-wrapper engine.\n" 843 "\n" 844 (format #f "(define-module ~S\n" guile-module) 845 (format #f " #:use-module (g-wrap config)\n") 846 (map (lambda (m) (format #f " #:use-module ~s\n" m)) 847 module-dependencies) 848 ")\n" 849 "\n" 850 (let ((load-extension 851 (list 852 "(load-extension " 853 (if (slot-ref wrapset 'shlib-abs?) 854 (list "(string-append *g-wrap-shlib-dir* \"" 855 (slot-ref wrapset 'shlib-path) "\") ") 856 (list "\"" (slot-ref wrapset 'shlib-path) "\" ")) 857 "\"gw_init_wrapset_" wrapset-name-c-sym "\")"))) 858 (list 859 "(cond-expand\n" 860 " (guile-2\n" 861 " (eval-when (eval load compile) " load-extension "))\n" 862 " (else\n" 863 " " load-extension "))\n")) 864 "(export " (map (lambda (sym) 865 (list " " sym "\n")) 866 (module-exports wrapset)) 867 ")") 868 port) 869 (let ((gf-hash (make-hash-table 67)) 870 (has-generics? #f)) 871 (fold-functions 872 (lambda (func rest) 873 (let ((gf-name (generic-name func))) 874 (if (and gf-name 875 (> (argument-count func) 0) 876 (class-name (first (argument-types func))) 877 (not (uses-rti-for-function? wrapset func))) 878 (let ((handle 879 (hashq-create-handle! gf-hash gf-name '()))) 880 (set! has-generics? #t) 881 (set-cdr! handle (cons func (cdr handle))))))) 882 #f wrapset) 883 884 (if has-generics? 885 (begin 886 ;; The generated module requires GOOPS. 887 (newline port) 888 (write '(use-modules (oop goops)) port) 889 (newline port))) 890 891 (hash-fold 892 (lambda (gf funcs rest) 893 (for-each 894 (lambda (func) 895 (write 896 `(%gw:procedure->method-public 897 ,(name func) 898 ;; Specializers 899 ',(map (lambda (arg) 900 (let ((typespec (typespec arg))) 901 (and (not (memq 'unspecialized 902 (options typespec))) 903 (class-name (type typespec))))) 904 (filter visible? (arguments func))) 905 ',gf 906 ;; Required argument count 907 ,(- (input-argument-count func) 908 (optional-argument-count func)) 909 ;; Optional arguments? 910 ,(not (zero? (optional-argument-count func)))) 911 port) 912 (newline port)) 913 funcs) 914 (newline port)) 915 #f gf-hash) 916 917 (cond (has-generics? 918 (write 919 '(module-use! (module-public-interface (current-module)) 920 %generics) 921 port) 922 (newline port)))))) 923 924(define (make-header-def-sym filename) 925 (string-append "__" 926 (string-map 927 (lambda (ch) 928 (case ch 929 ((#\space #\. #\-) #\_) 930 (else ch))) 931 (string-upcase filename)) 932 "__")) 933 934(define (generate-wrapset-h wrapset port) 935 (let* ((wrapset-name (symbol->string (name wrapset))) 936 (wrapset-header-name (string-append wrapset-name ".h")) 937 (wrapset-name-c-sym (any-str->c-sym-str wrapset-name)) 938 (wrapset-header-def-sym (make-header-def-sym wrapset-header-name))) 939 (flatten-display 940 (list 941 "/* Generated by G-Wrap: an experimental C->Guile wrapper engine */\n" 942 "\n" 943 "#ifndef " wrapset-header-def-sym "\n" 944 "#define " wrapset-header-def-sym "\n" 945 "\n" 946 "#ifdef __cplusplus\n" 947 "extern \"C\" {\n" 948 "#endif\n" 949 "\n" 950 "void gw_init_wrapset_" wrapset-name-c-sym "(void);\n" 951 "\n" 952 "#ifdef __cplusplus\n" 953 "}\n" 954 "#endif\n" 955 "#endif\n") 956 port))) 957 958(define-method (generate-wrapset (lang <symbol>) 959 (wrapset <gw-guile-wrapset>) 960 (basename <string>)) 961 (next-method) 962 963 (call-with-output-file/cleanup 964 (string-append basename ".h") 965 (lambda (port) 966 (generate-wrapset-h wrapset port))) 967 968 (if (module wrapset) 969 (call-with-output-file/cleanup 970 (string-append basename ".scm") 971 (lambda (port) 972 (generate-wrapset-scm wrapset port))))) 973