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