* added files
g-wrap/.arch-ids/dynamic-type.scm.id
g-wrap/dynamic-type.scm
{arch}/g-wrap/g-wrap--rotty/g-wrap--rotty--0.1/address@hidden/patch-log/patch-7
{arch}/g-wrap/g-wrap--rotty/g-wrap--rotty--0.2/address@hidden/patch-log/patch-3
* modified files
--- orig/ChangeLog
+++ mod/ChangeLog
@@ -1,5 +1,52 @@
2003-11-11 Andreas Rottmann
+ * g-wrap/gw-standard-spec.scm, g-wrap/gw-wct-spec.scm,
+ g-wrap/gw-glib-spec.scm: Make use of dynamic types.
+
+ * g-wrap/simple-type.scm (gw:wrap-simple-type): Make simple types
+ dynamic.
+
+ * g-wrap/Makefile.am (gwrapmodule_DATA): Added dynamic-type.scm.
+ * g-wrap/dynamic-type.scm: New file.
+
+ * g-wrap.scm (add-wrapset-types-info-output): New helper prcoedure.
+
+ * g-wrap.scm (gw:wrapset-use-dynamic-calls?): Dummy wrapset
+ attribute accessor, returns #t for now.
+
+ * g-wrap.scm (gw:wrap-function): Support a generic name and use
+ gw_wrapset_add_function().
+
+ * g-wrap.scm (gw:param-visibility): New type attribute.
+ (gw:type-set-param-visibility!, gw:type-get-param-visibility): New
+ type accessors.
+ (gw:param-visible?) New predicate.
+ (gw:_generate-wrapped-func-definitions_): Added support for
+ invisible parameters.
+
+ * g-wrap.scm (gw:_generate-wrapped-func-initializers_): Removed,
+ now done by gw_wrapset_register().
+
+ * g-wrap.scm (gw:typespec-check): New macro.
+
+ * g-wrap.scm (gw:type-get-class-name, gw:type-set-class-name!):
+ New public procedures.
+
+ * g-wrap.scm (gw:call-arg-ccg): New type CCG.
+ (gw:type-set-call-arg-ccg!): New type setter.
+ (make-c-call-param-list): Added support for the call-arg-ccg.
+
+ * g-wrap.scm: (gw:type-dynamic?, gw:type-get-c-typespec-ccg)
+ (gw:type-set-dynamic!): New public procedures.
+
+ * g-wrap.scm, g-wrap/enumeration.scm: Use runtime library instead
+ of spitting out all code ourselves.
+
+ * g-wrap.scm: Remove (use-modules (g-wrap enumeration)) hackery.
+ and seemingly useless simple-format check.
+
+ * g-wrap.scm (gw:wrapset-get-wrapsets-depended-on): Made public.
+
* test/gw-test-glib-spec.scm: Use #:use-module clauses instead of
(use-modules ...) statements.
--- orig/g-wrap.scm
+++ mod/g-wrap.scm
@@ -1,6 +1,7 @@
;;;; File: g-wrap.scm
;;;; Copyright (C) 1996, 1997,1998 Christopher Lee
;;;; Copyright (C) 1999, 2000, 2001, 2002 Rob Browning
+;;;; Copyright (C) 2003 Andreas Rottmann
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -19,18 +20,15 @@
;;;;
(define-module (g-wrap)
- :use-module (g-wrap output-file)
- :use-module (g-wrap sorting)
+ #:use-module (oop goops)
+ #:use-module (ice-9 slib)
+ #:use-module (ice-9 optargs)
+ #:use-module (srfi srfi-1)
+ #:use-module (g-wrap output-file)
+ #:use-module (g-wrap sorting)
;; FIXME: What does this one do?
- :use-module (g-wrap g-translate))
-
-(use-modules (ice-9 slib))
-
-(if (not (defined? 'simple-format))
- (begin
- (require 'format)
- (export simple-format)
- (define simple-format format)))
+ #:use-module (g-wrap g-translate)
+ #:export-syntax (gw:typespec-check))
(define *available-wrapsets* (make-hash-table 31))
@@ -138,6 +136,8 @@
wrapsets-depended-on
types-used
+ c-info-sym
+
ch-declarations-funcs
cs-before-includes-funcs ;; pre-header-ccg
cs-declarations-funcs ;; declarations-ccg
@@ -166,9 +166,20 @@
" - wrapset \""
,ws "\" does not exist."))))))
+;;; [rotty: A wrapset should really be a class]
+
(define-public gw:wrapset-get-name
(record-accessor *gw-wrapset-rtd* 'name))
+; [rotty: experimental dynamic call support]
+(define-public (gw:wrapset-use-dynamic-calls? ws)
+ #t)
+
+(define-public gw:wrapset-get-c-info-sym
+ (record-accessor *gw-wrapset-rtd* 'c-info-sym))
+(define gw:wrapset-set-c-info-sym!
+ (record-modifier *gw-wrapset-rtd* 'c-info-sym))
+
(define gw:wrapset-set-wrapped-types!
(record-modifier *gw-wrapset-rtd* 'wrapped-types))
(define gw:wrapset-get-wrapped-types
@@ -176,7 +187,7 @@
(define gw:wrapset-set-wrapsets-depended-on!
(record-modifier *gw-wrapset-rtd* 'wrapsets-depended-on))
-(define gw:wrapset-get-wrapsets-depended-on
+(define-public gw:wrapset-get-wrapsets-depended-on
(record-accessor *gw-wrapset-rtd* 'wrapsets-depended-on))
(define gw:wrapset-set-types-used!
@@ -312,12 +323,62 @@
(gw:wrapset-set-cs-wrapper-initializers-funcs! result '())
(gw:wrapset-set-guile-module-exports! result '())
+
+ ;; [rotty: runtime information]
+ (gw:wrapset-set-c-info-sym! result (gw:gen-c-tmp "c_info"))
result))))
(define-public (gw:wrapset-uses-type? wrapset type)
(hashq-ref (gw:wrapset-get-types-used wrapset) type #f))
+(define (add-wrapset-types-info-output wrapset port)
+ (let ((c-info-sym (gw:wrapset-get-c-info-sym wrapset)))
+ (for-each
+ (lambda (type)
+ (let* ((class-name (gw:type-get-class-name type))
+ (dynamic? (gw:type-dynamic? type))
+ (dyn-info (gw:type-get-dynamic-info type))
+ (c-typedef (if dynamic? (list-ref dyn-info 3) #f))
+ (subtypes-sym (gw:gen-c-tmp "subtypes")))
+ (flatten-display
+ (list
+ "{\n"
+ (if (list? c-typedef)
+ (list
+ "const char **" subtypes-sym "["
+ (+ 1 (number->string (length c-typedef))) "];\n"
+ (let loop ((i 0) (tail c-typedef))
+ (if (null? tail)
+ '()
+ (cons
+ (list subtypes-sym "[" (number->string i) = "]\""
+ subtype "\";\n")
+ (loop (+ i 1) (cdr tail)))))
+ subtypes-sym "[" (length c-typedef) "] = NULL;\n")
+ '())
+ " gw_wrapset_add_type(" c-info-sym ", \""
+ (gw:type-get-name type) "\", "
+ (if class-name (list "\"" class-name "\"") "NULL") ", "
+ (if dynamic?
+ (list
+ (cond
+ ((symbol? c-typedef)
+ (list
+ "&ffi_type_" (symbol->string c-typedef) ", NULL, "))
+ ((list? c-typedef)
+ (list "NULL, " subtypes-sym ", "))
+ (else
+ (error "Invalid C type definition")))
+ (list-ref dyn-info 0) ", "
+ (list-ref dyn-info 1) ", "
+ (list-ref dyn-info 2))
+ "NULL, NULL, NULL, NULL, NULL")
+ ");\n"
+ "}\n")
+ port)))
+ (map cdr (gw:wrapset-get-wrapped-types wrapset)))))
+
(define (add-wrapset-types-ccg-output wrapset port ccg-key)
(define (ws-run-type-ccgs-for-client wrapset client-wrapset)
@@ -353,6 +414,8 @@
ccg-key)
;; Run all the output funcs from wrapsets this one depends on.
+ ;; [rotty: with the new dynamic types and runtime info, we should be
+ ;; able to get rid of this]
(for-each
(lambda (depended-on-wrapset)
(ws-run-type-ccgs-for-client depended-on-wrapset wrapset))
@@ -363,16 +426,14 @@
(define (add-wrapset-types-initializer-ccg-output wrapset port ccg-key)
- (let* ((status-var (gw:gen-c-tmp "err_status"))
- (err-misc-msg-var (gw:gen-c-tmp "err_misc_msg"))
- (err-data-var (gw:gen-c-tmp "err_data"))
+ (let* ((error-var (gw:gen-c-tmp "err_var"))
(wrapset-name (gw:wrapset-get-name wrapset))
(wrapset-name-c-sym (gw:any-str->c-sym-str wrapset-name))
(wrapset-init-func (string-append "gw_init_wrapset_"
wrapset-name-c-sym)))
(define (output-initializer-code func type client-wrapset)
- (let ((code (func type client-wrapset status-var)))
+ (let ((code (func type client-wrapset error-var)))
(if (not (null? code))
(begin
@@ -381,12 +442,9 @@
port)
(flatten-display
(list
- "if (" status-var " != GW__ERR_NONE)"
- " gw__handle_wrapper_error (" status-var ",\n"
- " \"" wrapset-init-func "\",\n"
- " 0,\n"
- " " err-misc-msg-var ",\n"
- " " err-data-var ");\n")
+ "if ((" error-var ").status != GW_ERR_NONE)"
+ " gw_handle_wrapper_error (&(" error-var "), \""
+ wrapset-init-func "\", 0);\n")
port)))))
(define (ws-run-type-ccgs-for-client wrapset client-wrapset)
@@ -414,13 +472,11 @@
;; Run all the output funcs from wrapsets this one depends on.
(display "{\n" port)
- (display (string-append
- " enum GW__ErrorStatus " status-var " = GW__ERR_NONE;\n") port)
- (display (string-append " SCM " err-data-var " = SCM_UNSPECIFIED;\n") port)
- (display (string-append " char *" err-misc-msg-var " = NULL;\n") port)
- (display (string-append " (void) " status-var ";\n") port)
- (display (string-append " (void) " err-data-var ";\n") port)
- (display (string-append " (void) " err-misc-msg-var ";\n") port)
+ (display (string-append " GWError " error-var ";\n") port)
+ (display (string-append " " error-var ".status = GW_ERR_NONE;\n") port)
+ (display (string-append " " error-var ".data = SCM_UNSPECIFIED;\n") port)
+ (display (string-append " " error-var ".message = NULL;\n") port)
+ (display (string-append " (void) " error-var ";\n") port)
(for-each
(lambda (depended-on-wrapset)
@@ -432,20 +488,9 @@
(display "}\n" port)))
+;; not used anymore - moved to runtime lib
(define (gw:generate-error-handler wrapset port)
(display "\
-enum GW__ErrorStatus
-{
- GW__ERR_NONE,
- GW__ERR_MISC,
- GW__ERR_MEMORY,
- GW__ERR_RANGE,
- GW__ERR_TYPE,
- GW__ERR_ARGC,
- GW__ERR_ARG_RANGE,
- GW__ERR_ARG_TYPE
-};
-
static void
gw__handle_wrapper_error(enum GW__ErrorStatus status,
const char *func_name,
@@ -469,36 +514,36 @@
wrong_type_key = scm_permanent_object(scm_c_make_keyword(\"wrong-type\"));
switch(status) {
- case GW__ERR_NONE:
+ case GW_ERR_NONE:
scm_misc_error(func_name,
\"asked to handle error when there wasn't one\",
SCM_EOL);
break;
- case GW__ERR_MISC:
+ case GW_ERR_MISC:
/* scm_data is a list of format args for misc_msg */
scm_misc_error(func_name, misc_msg, scm_data); break;
- case GW__ERR_MEMORY:
+ case GW_ERR_MEMORY:
scm_memory_error(func_name); break;
- case GW__ERR_RANGE:
+ case GW_ERR_RANGE:
scm_error (out_of_range_key,
func_name,
\"Out of range: ~S\",
scm_cons (scm_data, SCM_EOL),
SCM_BOOL_F);
break;
- case GW__ERR_TYPE:
+ case GW_ERR_TYPE:
scm_error(wrong_type_key,
func_name,
\"Wrong type: \",
scm_cons (scm_data, SCM_EOL),
SCM_BOOL_F);
break;
- case GW__ERR_ARGC:
+ case GW_ERR_ARGC:
scm_wrong_num_args(scm_makfrom0str(func_name)); break;
- case GW__ERR_ARG_RANGE:
+ case GW_ERR_ARG_RANGE:
/* scm_data is the bad arg */
scm_out_of_range(func_name, scm_data); break;
- case GW__ERR_ARG_TYPE:
+ case GW_ERR_ARG_TYPE:
/* scm_data is the bad arg */
scm_wrong_type_arg(func_name, arg_pos, scm_data); break;
default:
@@ -587,6 +632,17 @@
(let ((name-func (gw:type-get-c-type-name-func (gw:typespec-get-type ts))))
(name-func ts)))
+;; This must be used by all dynamic type ccgs, since we may also
+;; receive the typespec at runtime, not wrapper creation time. In this
+;; case the ccgs get a string as typespec, which is the name of the C
+;; variable holding the typespec. This is a quite hacky and should be
+;; made cleaner, once I understand the full implications of having
+;; run-time typespecs -- rotty
+(define-macro (gw:typespec-check ts scm-forms c-forms)
+ `(if (string? ,ts)
+ ,c-forms
+ ,scm-forms))
+
(define-public (gw:prototype-form->typespec form wrapset)
(define (default-options-parser options wrapset)
;; default is to allow 'foo only, not '(foo)
@@ -642,6 +698,9 @@
(define-public (gw:param-get-c-type-name x)
(gw:typespec-get-c-type-name (gw:param-get-typespec x)))
+(define-public (gw:param-visible? x)
+ (gw:type-get-param-visibility (gw:param-get-type x)))
+
(define (param-specs->params param-specs wrapset)
(let loop ((remainder param-specs) (n 0))
(if (null? remainder)
@@ -685,7 +744,7 @@
;;; g-wrap, the others may be used by anyone building a new, specific
;;; kind of type on top of one of these. (thinking about changing this
;;; to have a separate child hash-table, or eliminating it
-;;; altogether...)
+;;; altogether... [rotty: or making this a class])
;;;
;;; what happens with arg options?
@@ -724,7 +783,12 @@
;;; [Code generated will always be put in new scope.]
;;;
;;; gw:call-ccg (result func-call-code status-var)
-;;; Normally must (at least) assign func-call-code (a string) to C result var.
+;;; Normally must (at least) assign func-call-code (a string)
+;;; to C result var.
+;;;
+;;; gw:call-arg-ccg (param)
+;;;
+;;; Optional. Can transform the param for the call (e.g. call-by-reference)
;;;
;;; gw:post-call-result-ccg (result status-var)
;;;
@@ -739,11 +803,13 @@
;;; "post-call" chunks will be run for each matching pre-call chunk
;;; that has already been run.
-(define-public (gw:wrap-type wrapset name-sym)
+(define*-public (gw:wrap-type wrapset name-sym)
(let ((result (make-hash-table 17)))
(resolve-wrapset! wrapset "gw:wrap-type")
(hashq-set! result 'gw:name name-sym)
(hashq-set! result 'gw:wrapset wrapset)
+ (hashq-set! result 'gw:dynamic #f)
+ (hashq-set! result 'gw:class-name #f)
(gw:wrapset-add-type! wrapset result)
result))
@@ -753,6 +819,67 @@
(define-public (gw:type-get-wrapset t)
(hashq-ref t 'gw:wrapset))
+;; [rotty: experimental "glueless" feature]
+(define-public (gw:type-dynamic? t)
+ (hashq-ref t 'gw:dynamic))
+(define (gw:type-get-dynamic-info t)
+ (hashq-ref t 'gw:dynamic-info))
+(define (gw:type-get-c-typespec-ccg t)
+ (list-ref (gw:type-get-dynamic-info t) 4))
+
+(define-public (gw:type-set-dynamic! t c-typedef c-typespec-ccg)
+ ;; FIXME: really need to get rid of faked typespec here
+ (let* ((ts (gw:make-typespec t '()))
+ (type-name (gw:typespec-get-c-type-name ts))
+ (scm->c-sym (gw:gen-c-tmp "c_to_scm"))
+ (c->scm-sym (gw:gen-c-tmp "scm_to_c"))
+ (c-destructor-sym (gw:gen-c-tmp "c_destructor")))
+ (hashq-set! t 'gw:dynamic #t)
+ (hashq-set! t 'gw:dynamic-info (list scm->c-sym c->scm-sym
+ c-destructor-sym c-typedef
+ c-typespec-ccg))
+ (gw:wrapset-add-cs-wrapper-definitions!
+ (gw:type-get-wrapset t)
+ (lambda (wrapset client-wrapset)
+ (if client-wrapset
+ '()
+ (list
+ "static SCM " c->scm-sym
+ "(void *instance, const GWTypeSpec *typespec, GWError *error) {\n"
+ " SCM result;\n"
+ " " ((gw:type-get-c->scm-ccg t) "result"
+ (string-append "(*(" type-name "*)instance)")
+ "*typespec" "*error")
+ " return result;\n"
+ "}\n"
+ "static void " scm->c-sym
+ "(void *instance, const GWTypeSpec *typespec, SCM value, GWError *error) {\n"
+ " " (gw:expand-special-forms
+ ((gw:type-get-scm->c-ccg t)
+ (string-append "(*(" type-name "*)instance)")
+ "value" "*typespec" "*error")
+ #f
+ '(type arg-type range memory misc))
+ "}\n"
+ "static void " c-destructor-sym
+ "(void *instance, const GWTypeSpec *typespec, int force, GWError *error) {\n"
+ " " (gw:expand-special-forms
+ ((gw:type-get-c-destructor t)
+ (string-append "(*(" type-name "*)instance)")
+ "*typespec" "*error" "force")
+ #f
+ '(type arg-type range memory misc))
+ "}\n"
+ ))))))
+
+(define-public (gw:type-set-typespec-ccg t ts-ccg)
+ (list-set! (hashq-ref t 'gw:dynamic-info) 4 ts-ccg))
+
+(define-public (gw:type-get-class-name t)
+ (hashq-ref t 'gw:class-name))
+(define-public (gw:type-set-class-name! t name)
+ (hashq-set! t 'gw:class-name name))
+
(define-public (gw:type-set-c-type-name-func! t func)
(hashq-set! t 'gw:c-type-name-func func))
(define-public (gw:type-get-c-type-name-func t)
@@ -763,6 +890,11 @@
(define-public (gw:type-get-typespec-options-parser t)
(hashq-ref t 'gw:typespec-options-parser))
+(define-public (gw:type-set-param-visibility! t vis)
+ (hashq-set! t 'gw:param-visibility vis))
+(define-public (gw:type-get-param-visibility t)
+ (hashq-ref t 'gw:param-visibility #t))
+
(define-public (gw:type-set-global-initializations-ccg! t generator)
(hashq-set! t 'gw:global-initializations-ccg generator))
(define-public (gw:type-set-global-declarations-ccg! t generator)
@@ -789,6 +921,8 @@
(hashq-set! t 'gw:pre-call-result-ccg generator))
(define-public (gw:type-set-pre-call-arg-ccg! t generator)
(hashq-set! t 'gw:pre-call-arg-ccg generator))
+(define-public (gw:type-set-call-arg-ccg! t generator)
+ (hashq-set! t 'gw:call-arg-ccg generator))
(define-public (gw:type-set-call-ccg! t generator)
(hashq-set! t 'gw:call-ccg generator))
(define-public (gw:type-set-post-call-arg-ccg! t generator)
@@ -1038,16 +1172,14 @@
(reverse (funcs-getter wrapset)))))
(define (run-wrapset-initializer-output-funcs wrapset funcs-getter port)
- (let* ((status-var (gw:gen-c-tmp "status_var"))
- (err-misc-msg-var (gw:gen-c-tmp "err_misc_msg"))
- (err-data-var (gw:gen-c-tmp "err_data"))
+ (let* ((error-var (gw:gen-c-tmp "error_var"))
(wrapset-name (gw:wrapset-get-name wrapset))
(wrapset-name-c-sym (gw:any-str->c-sym-str wrapset-name))
(wrapset-init-func (string-append "gw_init_wrapset_"
wrapset-name-c-sym)))
(define (output-initializer-code func provider-wrapset client-wrapset)
- (let ((code (func provider-wrapset client-wrapset status-var)))
+ (let ((code (func provider-wrapset client-wrapset error-var)))
(if (not (null? code))
(begin
@@ -1056,26 +1188,20 @@
port)
(flatten-display
(list
- "if (" status-var " != GW__ERR_NONE)"
- " gw__handle_wrapper_error (" status-var ",\n"
+ "if (" error-var ".status != GW_ERR_NONE)"
+ " gw_handle_wrapper_error (&" error-var ",\n"
" \"" wrapset-init-func "\",\n"
- " 0,\n"
- " " err-misc-msg-var ",\n"
- " " err-data-var ");\n")
+ " 0);\n")
port)))))
(list
(display "{\n" port)
- (display (string-append
- " enum GW__ErrorStatus " status-var " = GW__ERR_NONE;\n") port)
- (display (string-append " SCM " err-data-var " = SCM_UNSPECIFIED;\n")
- port)
- (display (string-append " char *" err-misc-msg-var " = NULL;\n") port)
- (display (string-append " (void) " status-var ";\n") port)
- (display (string-append " (void) " err-data-var ";\n") port)
- (display (string-append " (void) " err-misc-msg-var ";\n") port)
-
+ (display (string-append " GWError " error-var ";\n") port)
+ (display (string-append " " error-var ".status = GW_ERR_NONE;\n") port)
+ (display (string-append " " error-var ".data = SCM_UNSPECIFIED;\n") port)
+ (display (string-append " " error-var ".message = NULL;\n") port)
+ (display (string-append " (void) " error-var ";\n") port)
;; Run all the output funcs from wrapsets this one depends on.
(map
@@ -1123,6 +1249,7 @@
"#include \n"
"#include \n"
"#include \n"
+ "#include \n"
"\n"
"#include \"" wrapset-header-name "\"\n"))
@@ -1149,8 +1276,8 @@
port)
-
- (gw:generate-error-handler wrapset port)
+ ;; not needed - is runtime lib now
+ ;; (gw:generate-error-handler wrapset port)
(run-wrapset-output-funcs wrapset
gw:wrapset-get-cs-definitions-funcs
@@ -1163,13 +1290,16 @@
(dsp-list
(list
"void\n"
- "gw_init_wrapset_" wrapset-name-c-sym "() {\n"
+ "gw_init_wrapset_" wrapset-name-c-sym "(void) {\n"
+ " GWWrapSet *" (gw:wrapset-get-c-info-sym wrapset) " = NULL;\n"
" static int gw_wrapset_initialized = 0;\n"
"\n"
- " if(!gw_wrapset_initialized)\n"
- " {\n"
- " gh_eval_str(\"(use-modules (g-wrap runtime))\");\n"
- " gh_eval_str(\"(gw:wrapset-register-runtime \\\"" wrapset-name "\\\")\");\n"
+ " if(gw_wrapset_initialized)\n"
+ " return;\n"
+ "\n"
+ " gw_runtime_init ();\n"
+ " gh_eval_str(\"(use-modules (g-wrap runtime))\");\n"
+ " gh_eval_str(\"(gw:wrapset-register-runtime \\\"" wrapset-name "\\\")\");\n"
"\n"))
(for-each
@@ -1181,6 +1311,19 @@
`("gw_init_wrapset_" ,wrapset-name-c-sym "();\n"))
port)))
(gw:wrapset-get-wrapsets-depended-on wrapset))
+
+ (flatten-display
+ (list
+ " " (gw:wrapset-get-c-info-sym wrapset) " = gw_wrapset_new(\""
+ (gw:wrapset-get-name wrapset) "\", "
+ (map (lambda (dep)
+ (list "\"" (gw:wrapset-get-name dep) "\", "))
+ (gw:wrapset-get-wrapsets-depended-on wrapset))
+ "NULL);\n")
+ port)
+
+ ; [rotty: experimental runtime-info]
+ (add-wrapset-types-info-output wrapset port)
(run-wrapset-initializer-output-funcs
wrapset
@@ -1199,9 +1342,8 @@
(dsp-list
(list
+ " gw_wrapset_register(" (gw:wrapset-get-c-info-sym wrapset) ");\n"
" gw_wrapset_initialized = 1;\n"
- " (void) gw__handle_wrapper_error;\n"
- " }\n"
"}\n"))))))
(define-public (gw:generate-wrapset wrapset . options)
@@ -1263,7 +1405,7 @@
(list (cadr args) top-form)
#f))
- (let ((status-var (car args)))
+ (let ((error-var (car args)))
(set! args (cdr args))
(list
"{\n"
@@ -1273,46 +1415,46 @@
;; (list 'gw:error 'misc msg format-args)
(if (not (= 3 (length args))) (error "bad call to (gw:error 'misc ...)"))
(list
- " " status-var " = GW__ERR_MISC;\n"
- " gw__error_msg = " (list-ref args 1) ";\n"
- " gw__error_data = " (list-ref args 2) ";\n"))
+ " (" error-var ").status = GW_ERR_MISC;\n"
+ " (" error-var ").message = " (list-ref args 1) ";\n"
+ " (" error-var ").data = " (list-ref args 2) ";\n"))
((memory)
;; (list 'gw:error 'memory)
(if (not (= 1 (length args)))
(error "bad call to (gw:error 'memory ...)"))
(list
- " " status-var " = GW__ERR_ARG_MEMORY;\n"))
+ " (" error-var ").status = GW_ERR_ARG_MEMORY;\n"))
((range)
;; (list 'gw:error 'range scm-item-out-of-range)
(if (not (= 2 (length args)))
(error "bad call to (gw:error 'range ...)"))
(list
- " " status-var " = GW__ERR_ARG_TYPE;\n"
- " gw__error_data = " (cadr args) ";\n"))
+ " (" error-var ").status = GW_ERR_ARG_TYPE;\n"
+ " (" error-var ").data = " (cadr args) ";\n"))
((type)
;; (list 'gw:error 'type scm-bad-type-item)
(if (not (= 2 (length args)))
(error "bad call to (gw:error 'type ...)"))
(list
- " " status-var " = GW__ERR_ARG_TYPE;\n"
- " gw__error_data = " (cadr args) ";\n"))
+ " (" error-var ").status = GW_ERR_ARG_TYPE;\n"
+ " (" error-var ").data = " (cadr args) ";\n"))
((argc)
;; (list 'gw:error 'argc)
(if (not (= 1 (length args))) (error "bad call to (gw:error 'argc ...)"))
(list
- " " status-var " = GW__ERR_ARGC;\n"))
+ " (" error-var ").status = GW_ERR_ARGC;\n"))
((arg-type)
(if (not (= 1 (length args)))
(error "bad call to (gw:error 'arg-type ...)"))
(list
- " " status-var " = GW__ERR_ARG_TYPE;\n"
- " gw__error_data = " (gw:param-get-scm-name param) ";\n"))
+ " (" error-var ").status = GW_ERR_ARG_TYPE;\n"
+ " (" error-var ").data = " (gw:param-get-scm-name param) ";\n"))
((arg-range)
(if (not (= 1 (length args)))
(error "bad call to (gw:error 'arg-range ...)"))
(list
- " " status-var " = GW__ERR_ARG_RANGE;\n"
- " gw__error_data = " (gw:param-get-scm-name param) ";\n"))
+ " (" error-var ").status = GW_ERR_ARG_RANGE;\n"
+ " (" error-var ").data = " (gw:param-get-scm-name param) ";\n"))
(else
(error "unexpected error type in gw:error")))
@@ -1333,22 +1475,22 @@
((gw:error?)
(cond
((= 2 (length tree))
- (let ((status-var (list-ref tree 1)))
- (list "(" status-var " != GW__ERR_NONE)")))
+ (let ((error-var (list-ref tree 1)))
+ (list "((" error-var ").status != GW_ERR_NONE)")))
((= 3 (length tree))
- (let ((status-var (list-ref tree 1))
+ (let ((error-var (list-ref tree 1))
(err-sym
(case (list-ref tree 2)
- ((misc) "GW__ERR_MISC")
- ((memory) "GW__ERR_MEMORY")
- ((range) "GW__ERR_RANGE")
- ((type) "GW__ERR_TYPE")
- ((argc) "GW__ERR_ARGC")
+ ((misc) "GW_ERR_MISC")
+ ((memory) "GW_ERR_MEMORY")
+ ((range) "GW_ERR_RANGE")
+ ((type) "GW_ERR_TYPE")
+ ((argc) "GW_ERR_ARGC")
((arg-range) "GW__ARG_RANGE")
((arg-type) "GW__ARG_TYPE")
(else (error "improper error type given to gw:error?: "
(list-ref tree 2))))))
- (list "(" status-var " == " err-sym ")")))
+ (list "((" error-var ").status == " err-sym ")")))
(else
(error "improper use of gw:error?"))))
((gw:error)
@@ -1360,16 +1502,21 @@
(else tree)))
(gw:expand-helper tree param allowed-errors tree))
-(define (make-c-call-param-list params)
+(define (make-c-call-param-list params)
(cond ((null? params) '())
- (else
- (cons
- (list
- (gw:param-get-c-name (car params))
- (if (null? (cdr params))
- ""
- ", "))
- (make-c-call-param-list (cdr params))))))
+ (else
+ (let* ((param (car params))
+ (type (gw:param-get-type param))
+ (call-arg-ccg (hashq-ref type 'gw:call-arg-ccg)))
+ (cons
+ (list
+ (if call-arg-ccg
+ (call-arg-ccg param)
+ (gw:param-get-c-name param))
+ (if (null? (cdr params))
+ ""
+ ", "))
+ (make-c-call-param-list (cdr params)))))))
(define (make-c-wrapper-param-declarations param-list)
(let loop ((params param-list)
@@ -1388,6 +1535,7 @@
(loop (cdr params) (+ index 1)))))))
(define (gw:_generate-wrapped-func-definitions_ wrapset
+ dynamic-call?
scheme-sym
result
c-name
@@ -1395,192 +1543,252 @@
description
wrapper-name
wrapper-namestr)
-
- (let ((param-decl (make-c-wrapper-param-declarations params))
- (fn-c-wrapper wrapper-name)
- (fn-c-string wrapper-namestr)
- (nargs (length params))
- (status-var "gw__error_status"))
+ (let* ((scm-params (filter gw:param-visible? params))
+ (param-decl (make-c-wrapper-param-declarations scm-params))
+ (fn-c-wrapper wrapper-name)
+ (fn-c-string wrapper-namestr)
+ (nargs (length scm-params))
+ (error-var "gw__error"))
(list
"static char * " fn-c-string " = \"" scheme-sym "\";\n"
- "static SCM " fn-c-wrapper " (" param-decl ") {\n"
- " SCM gw__scm_result = SCM_UNSPECIFIED;\n"
- " enum GW__ErrorStatus gw__error_status = GW__ERR_NONE;\n"
- " SCM gw__error_data = SCM_UNSPECIFIED;\n"
- " unsigned int gw__arg_pos = 0;\n"
- " const char *gw__error_misc_msg = NULL;\n"
-
- (if (gw:type-declare-scm-result-var? (gw:result-get-type result))
- (list (gw:result-get-c-type-name result) " "
- (gw:result-get-c-name result) ";\n")
- '())
-
- (if (> nargs gw:*max-fixed-params*)
- (list " SCM gw__scm_extras[" (- nargs gw:*max-fixed-params*) "];\n")
- '())
-
- "\n"
-
- (map
- (lambda (x)
- (list
- (gw:param-get-c-type-name x) " " (gw:param-get-c-name x) ";\n"))
- params)
-
- (map
- (lambda (param)
- (let ((pre-call-ccg
- (hashq-ref (gw:param-get-type param) 'gw:pre-call-arg-ccg #f)))
- (list
- "/* ARG " (gw:param-get-number param) " */\n"
- "gw__arg_pos++;\n"
- (if (> (gw:param-get-number param) gw:*max-fixed-params*)
+ (if dynamic-call?
+ '()
+ (list
+ "static SCM " fn-c-wrapper " (" param-decl ") {\n"
+ " SCM gw__scm_result = SCM_UNSPECIFIED;\n"
+ " GWError gw__error = { GW_ERR_NONE, NULL, SCM_UNSPECIFIED };\n"
+ " unsigned int gw__arg_pos = 0;\n"
+
+ (if (gw:type-declare-scm-result-var? (gw:result-get-type result))
+ (list (gw:result-get-c-type-name result) " "
+ (gw:result-get-c-name result) ";\n")
+ '())
+
+ (if (> nargs gw:*max-fixed-params*)
+ (list " SCM gw__scm_extras[" (- nargs gw:*max-fixed-params*) "];\n")
+ '())
+
+ "\n"
+
+ (map
+ (lambda (x)
+ (list
+ (gw:param-get-c-type-name x) " " (gw:param-get-c-name x) ";\n"))
+ params)
+
+ (map
+ (lambda (param)
+ (let ((pre-call-ccg
+ (hashq-ref (gw:param-get-type param) 'gw:pre-call-arg-ccg #f)))
(list
- "if (SCM_NULLP (gw__restargs)) " status-var " = GW__ERR_ARGC;\n"
- "else {\n"
- " " (gw:param-get-scm-name param) " = SCM_CAR(gw__restargs);\n"
- " gw__restargs = SCM_CDR (gw__restargs);\n"
- "}\n")
- '())
- "if (" status-var " != GW__ERR_NONE)"
- " goto " (if (zero? (gw:param-get-number param))
- "gw__wrapper_exit;\n"
- (list "gw__post_call_arg_"
- (- (gw:param-get-number param) 1) ";\n"))
- "\n{\n"
- (if pre-call-ccg
- (gw:expand-special-forms
- (pre-call-ccg param status-var)
- param
- '(memory misc type range arg-type arg-range))
- " /* no pre-call arg code requested! */\n"))))
- params)
-
- (let ((pre-call-result-ccg
- (hashq-ref (gw:result-get-type result) 'gw:pre-call-result-ccg #f)))
- (list
- "if (" status-var " == GW__ERR_NONE)\n"
- "{\n"
- (if pre-call-result-ccg
- (gw:expand-special-forms (pre-call-result-ccg result status-var)
- #f
- '(memory misc type range))
- " /* no pre-call result code requested! */\n")))
-
-
- (let ((call-ccg (hashq-ref (gw:result-get-type result) 'gw:call-ccg #f))
- (func-call-code (list c-name " (" (make-c-call-param-list params) ")")))
- (if call-ccg
- (list
- "if (" status-var " != GW__ERR_NONE)"
- " goto " (if (zero? nargs)
- "gw__wrapper_exit;\n"
- (list "gw__post_call_arg_" (- nargs 1) ";\n"))
- "SCM_DEFER_INTS;\n"
- (gw:expand-special-forms (call-ccg result func-call-code status-var)
- #f
- '(memory misc type range))
- "SCM_ALLOW_INTS;\n")
- "/* no function call requested! */\n"))
-
- (let ((post-call-ccg (hashq-ref (gw:result-get-type result)
- 'gw:post-call-result-ccg #f)))
- (list
- (if post-call-ccg
+ (if (gw:param-visible? param)
+ (list
+ "/* ARG " (gw:param-get-number param) " */\n"
+ "gw__arg_pos++;\n"
+ (if (> (gw:param-get-number param) gw:*max-fixed-params*)
+ (list
+ "if (SCM_NULLP (gw__restargs)) (" error-var ").status = GW_ERR_ARGC;\n"
+ "else {\n"
+ " " (gw:param-get-scm-name param) " = SCM_CAR(gw__restargs);\n"
+ " gw__restargs = SCM_CDR (gw__restargs);\n"
+ "}\n")
+ '())
+ "if ((" error-var ").status != GW_ERR_NONE)"
+ " goto " (if (zero? (gw:param-get-number param))
+ "gw__wrapper_exit;\n"
+ (list "gw__post_call_arg_"
+ (- (gw:param-get-number param) 1) ";\n")))
+ '())
+ "\n{\n"
+ (if pre-call-ccg
+ (gw:expand-special-forms
+ (pre-call-ccg param error-var)
+ param
+ '(memory misc type range arg-type arg-range))
+ " /* no pre-call arg code requested! */\n"))))
+ params)
+
+ (let ((pre-call-result-ccg
+ (hashq-ref (gw:result-get-type result) 'gw:pre-call-result-ccg #f)))
(list
+ "if ((" error-var ").status == GW_ERR_NONE)\n"
"{\n"
- (gw:expand-special-forms (post-call-ccg result status-var)
- #f
- '(memory misc type range))
- "}\n")
- " /* no post-call result code requested */\n")
- "}\n"))
-
- ;; insert the post-call args code in the opposite order
- ;; of the pre-call code
- (map
- (lambda (param)
- (let ((post-call-ccg
- (hashq-ref (gw:param-get-type param) 'gw:post-call-arg-ccg #f)))
- (list
- " gw__post_call_arg_" (gw:param-get-number param) ":\n"
- (if post-call-ccg
+ (if pre-call-result-ccg
+ (gw:expand-special-forms (pre-call-result-ccg result error-var)
+ #f
+ '(memory misc type range))
+ " /* no pre-call result code requested! */\n")))
+
+
+ (let ((call-ccg (hashq-ref (gw:result-get-type result) 'gw:call-ccg #f))
+ (func-call-code (list c-name " (" (make-c-call-param-list params) ")")))
+ (if call-ccg
+ (list
+ "if ((" error-var ").status != GW_ERR_NONE)"
+ " goto " (if (zero? nargs)
+ "gw__wrapper_exit;\n"
+ (list "gw__post_call_arg_" (- nargs 1) ";\n"))
+ "SCM_DEFER_INTS;\n"
+ (gw:expand-special-forms (call-ccg result func-call-code error-var)
+ #f
+ '(memory misc type range))
+ "SCM_ALLOW_INTS;\n")
+ "/* no function call requested! */\n"))
+
+ (let ((post-call-ccg (hashq-ref (gw:result-get-type result)
+ 'gw:post-call-result-ccg #f)))
+ (list
+ (if post-call-ccg
+ (list
+ "{\n"
+ (gw:expand-special-forms (post-call-ccg result error-var)
+ #f
+ '(memory misc type range))
+ "}\n")
+ " /* no post-call result code requested */\n")
+ "}\n"))
+
+ ;; insert the post-call args code in the opposite order
+ ;; of the pre-call code
+ (map
+ (lambda (param)
+ (let ((post-call-ccg
+ (hashq-ref (gw:param-get-type param) 'gw:post-call-arg-ccg #f)))
(list
- "{\n"
- (gw:expand-special-forms (post-call-ccg param status-var)
- #f
- '(memory misc type range))
- "}\n")
- " /* no post-call arg code requested! */\n")
- " { /* shut up warnings if no code */ int x = x; }\n"
- "}\n")))
- (reverse params))
-
- " gw__wrapper_exit:\n"
- " if(gw__error_status != GW__ERR_NONE)\n"
- " gw__handle_wrapper_error(gw__error_status,\n"
- " " fn-c-string ",\n"
- " gw__arg_pos,\n"
- " gw__error_misc_msg,\n"
- " gw__error_data);\n"
- " return gw__scm_result;\n"
- "}\n")))
-
-
-(define (gw:_generate-wrapped-func-initializers_ scm-sym
- c-name
- nargs
- description
- wrapper-name
- wrapper-namestr)
- (let ((use-extra-params? (> nargs gw:*max-fixed-params*))
- (fn-c-wrapper wrapper-name)
- (fn-c-string wrapper-namestr)
- (fn-doc (flatten-string description)))
- ;;(fn-doc (str-translate (flatten-string description)
- ;; "\n\""
- ;; (vector "\\n\\\n" "\\\""))))
-
- (list
- " gh_new_procedure(" fn-c-string ",\n"
- " (SCM (*) ()) " fn-c-wrapper ",\n"
- " " (if use-extra-params?
- gw:*max-fixed-params*
- nargs) ",\n"
- " 0,\n"
- " " (if use-extra-params? "1" "0") ");\n"
- "\n"
- ;;(gw:inline-scheme `(gw:add-description ,scm-sym ,fn-doc))
- )))
-
-;; " gw_add_description(scm_cons(SCM_CAR(scm_intern0(" fn-c-string ")), "
-;; " gh_str02scm(\"" fn-doc "\")));\n")))
-
+ (if (gw:param-visible? param)
+ (list " gw__post_call_arg_" (gw:param-get-number param) ":\n")
+ '())
+ (if post-call-ccg
+ (list
+ "{\n"
+ (gw:expand-special-forms (post-call-ccg param error-var)
+ #f
+ '(memory misc type range))
+ "}\n")
+ " /* no post-call arg code requested! */\n")
+ " { /* shut up warnings if no code */ int x = x; }\n"
+ "}\n")))
+ (reverse params))
+
+ " gw__wrapper_exit:\n"
+ " if(gw__error.status != GW_ERR_NONE)\n"
+ " gw_handle_wrapper_error(&gw__error,\n"
+ " " fn-c-string ",\n"
+ " gw__arg_pos);\n"
+ " return gw__scm_result;\n"
+ "}\n")))))
+
+
+(define-class ()
+ (dynamic #:accessor dynamic?
+ #:init-keyword #:dynamic?)
+ (c-proc-sym #:accessor c-procedure-symbol
+ #:init-keyword #:c-proc-sym)
+ (return-typespec #:accessor return-typespec #:init-keyword #:return-typespec)
+ (nargs #:accessor argument-count
+ #:init-keyword #:nargs)
+ (arg-typespecs #:accessor argument-typespecs
+ #:init-keyword #:argument-typespecs
+ #:init-value #f)
+ (proc-name #:accessor procedure-name
+ #:init-value #f
+ #:init-keyword #:procedure-name)
+ (class-name #:accessor class-name
+ #:init-value #f
+ #:init-keyword #:class-name)
+ (generic-name #:accessor generic-name
+ #:init-value #f
+ #:init-keyword #:generic-name))
+
+(define ws-functions-hash (make-hash-table 7))
+
+(define*-public (gw:wrap-function
+ wrapset
+ scheme-sym
+ result-spec
+ c-name
+ param-specs
+ #:optional new-description
+ #:key (generic-sym #f))
-(define-public (gw:wrap-function
- wrapset
- scheme-sym
- result-spec
- c-name
- param-specs
- .
- new-description)
-
- (resolve-wrapset! wrapset "gw:wrap-function")
+ (define (add-funcs-ccg wrapset client-wrapset error-var)
+ (if (not client-wrapset)
+ (map
+ (lambda (func)
+ (let* ((nargs (argument-count func))
+ (proc-name (procedure-name func))
+ (arg-typespecs (argument-typespecs func))
+ (ret-typespec (return-typespec func))
+ (ret-type (gw:typespec-get-type ret-typespec))
+ (use-extra-params? (> nargs gw:*max-fixed-params*))
+ (arg-types-sym (gw:gen-c-tmp "arg_types"))
+ (gen-sym (generic-name func))
+ (arg-typespecs-sym (gw:gen-c-tmp "arg_typespecs")))
+ (list
+ "{\n"
+ " const char *" arg-types-sym "[" (number->string (+ nargs 1)) "];\n"
+ " GWTypeSpec " arg-typespecs-sym "[] = { "
+ (map (lambda (ts)
+ (let ((type (gw:typespec-get-type ts)))
+ (string-append
+ (if (dynamic? func)
+ ((gw:type-get-c-typespec-ccg type) ts)
+ "0") ", ")))
+ arg-typespecs)
+ "0 };\n"
+ (let loop ((idx 0) (specs arg-typespecs))
+ (if (null? specs)
+ '()
+ (cons
+ (list
+ " " arg-types-sym "[" (number->string idx) "] = \""
+ (gw:type-get-name
+ (gw:typespec-get-type (car specs))) "\";\n")
+ (loop (+ idx 1) (cdr specs)))))
+ " " arg-types-sym "[" (number->string nargs) "] = NULL;\n"
+ " gw_wrapset_add_function(" (gw:wrapset-get-c-info-sym wrapset)
+ ", " (if (dynamic? func) "1" "0")
+ ", " (c-procedure-symbol func) ", "
+ (if use-extra-params? gw:*max-fixed-params* nargs) ", "
+ "0, "
+ (if use-extra-params? "1" "0") ", "
+ "\"" (gw:type-get-name ret-type) "\", "
+ (if (dynamic? func)
+ ((gw:type-get-c-typespec-ccg ret-type) ret-typespec)
+ "0") ", "
+ arg-types-sym ", " arg-typespecs-sym ", " proc-name " , "
+ (if gen-sym
+ (list "\"" (symbol->string gen-sym) "\"")
+ "NULL")
+ ");\n"
+ "}\n")))
+ (hashq-ref ws-functions-hash (gw:wrapset-get-name wrapset) '()))
+ '()))
(let* ((params (param-specs->params param-specs wrapset))
+ (arg-types (map (lambda (param) (gw:param-get-type param)) params))
+ (arg-types-dynamic?
+ (not (find-tail (lambda (t) (not (gw:type-dynamic? t)))
+ arg-types)))
+ (result (result-spec->result result-spec wrapset))
+ (result-type (gw:result-get-type result))
+ (result-typespec (gw:result-get-typespec result))
+ (dynamic-call? (and (gw:wrapset-use-dynamic-calls? wrapset)
+ (gw:type-dynamic? result-type)
+ arg-types-dynamic?))
(wrapper-name (gw:gen-c-tmp (string-append c-name "_wrapper")))
(wrapper-namestr (gw:gen-c-tmp (string-append c-name "_namestr")))
- (result (result-spec->result result-spec wrapset))
(description
(list
- (param-specs->description-head
- scheme-sym (gw:result-get-type result) param-specs)
+ (param-specs->description-head scheme-sym result-type param-specs)
new-description))
- (nargs (length params)))
-
+ (nargs (length (filter gw:param-visible? params)))
+ (ws-name (gw:wrapset-get-name wrapset))
+ (ws-functions (hashq-ref ws-functions-hash ws-name '())))
+ (resolve-wrapset! wrapset "gw:wrap-function")
+
(gw:wrapset-add-guile-module-export! wrapset scheme-sym)
(gw:wrapset-add-cs-wrapper-definitions!
@@ -1589,6 +1797,7 @@
(if client-wrapset
'()
(gw:_generate-wrapped-func-definitions_ wrapset
+ dynamic-call?
scheme-sym
result
c-name
@@ -1596,18 +1805,26 @@
description
wrapper-name
wrapper-namestr))))
- (gw:wrapset-add-cs-wrapper-initializers!
- wrapset
- (lambda (wrapset client-wrapset status-var)
- (if client-wrapset
- '()
- (gw:_generate-wrapped-func-initializers_ scheme-sym
- c-name
- nargs
- description
- wrapper-name
- wrapper-namestr))))))
-
+
+ (if (null? ws-functions) ; first function in wrapset?
+ (gw:wrapset-add-cs-wrapper-initializers! wrapset add-funcs-ccg))
+
+ (hashq-set! ws-functions-hash ws-name
+ (cons (make
+ #:dynamic? dynamic-call?
+ #:c-proc-sym (if dynamic-call? c-name wrapper-name)
+ #:nargs nargs
+ #:return-typespec result-typespec
+ #:argument-typespecs
+ (map (lambda (param)
+ (gw:param-get-typespec param))
+ params)
+ #:procedure-name (string->symbol wrapper-namestr)
+ #:class-name class-name
+ #:generic-name generic-sym)
+ ws-functions))
+
+ ))
(define (param-specs->description-head scheme-sym ret-type param-list)
(list
@@ -1632,7 +1849,7 @@
wrapset
scheme-sym
typespec-form
- c-value ;; (c-var typespec status-var)
+ c-value ;; (c-var typespec error-var)
.
description)
@@ -1646,26 +1863,20 @@
(gw:wrapset-add-cs-wrapper-initializers!
wrapset
- (lambda (wrapset client-wrapset status-var)
+ (lambda (wrapset client-wrapset error-var)
(if client-wrapset
'()
- (let ((convert-value-code (c->scm scm-var c-value typespec status-var)))
+ (let ((convert-value-code (c->scm scm-var c-value typespec error-var)))
(list
"{\n"
" SCM " scm-var ";\n"
"\n"
convert-value-code
- "if(!" `(gw:error? ,status-var) ")"
+ "if(!" `(gw:error? ,error-var) ")"
" gh_define(\"" (symbol->string scheme-sym) "\"," scm-var ");\n"
"}\n")))))))
-(use-modules (g-wrap enumeration))
-(export gw:wrap-enumeration)
-(export gw:enum-add-value!)
-
-
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Junk.
--- orig/g-wrap/Makefile.am
+++ mod/g-wrap/Makefile.am
@@ -28,6 +28,7 @@
gwrapmodule_DATA= \
enumeration.scm \
+ dynamic-type.scm \
simple-type.scm \
\
${GW_GLIB_DATA_ADD} \
--- orig/g-wrap/enumeration.scm
+++ mod/g-wrap/enumeration.scm
@@ -7,51 +7,50 @@
;;; switch to using gw:tmp-c-sym
(define-module (g-wrap enumeration)
- :use-module (g-wrap)
- :use-module (g-wrap output-file))
+ #:use-module (g-wrap)
+ #:use-module (g-wrap dynamic-type)
+ #:use-module (g-wrap output-file))
(define-public (gw:wrap-enumeration wrapset name-sym c-type-name)
- (let* ((wt (gw:wrap-type wrapset name-sym))
- (enum-c-sym
- (gw:any-str->c-sym-str (symbol->string (gw:type-get-name wt))))
- (val->int-var-name
+ (let* ((enum-c-sym
+ (gw:any-str->c-sym-str (symbol->string name-sym)))
+ (val-sym-array-name
+ (string-append "gw__enum_" enum-c-sym "_val_array"))
+ (val->int-var-name
(string-append "gw__enum_" enum-c-sym "_val_to_int_scm_func"))
(val->int-scm-func-name
- (let* ((enum-name (hashq-ref wt 'gw:name #f)))
- (string-append "gw:enum-" (symbol->string enum-name) "-val->int")))
+ (string-append "gw:enum-" (symbol->string name-sym) "-val->int"))
(val->int-c-func-name
(string-append "gw__enum_" enum-c-sym "_val_to_int"))
(val->sym-var-name
(string-append "gw__enum_" enum-c-sym "_val_to_sym_scm_func"))
(val->sym-scm-func-name
- (let* ((enum-name (hashq-ref wt 'gw:name #f)))
- (string-append "gw:enum-" (symbol->string enum-name) "-val->sym")))
+ (string-append "gw:enum-" (symbol->string name-sym) "-val->sym"))
(val->sym-c-func-name
(string-append "gw__enum_" enum-c-sym "_val_to_sym")))
- (define (c-type-name-func typespec)
- (if (memq 'const (gw:typespec-get-options typespec))
- (string-append "const " c-type-name)
- c-type-name))
-
(define (typespec-options-parser options-form wrapset)
(let ((remainder options-form))
(set! remainder (delq 'const options-form))
(if (null? remainder)
- options-form
+ (cons 'caller-owned options-form) ; needed for dynamic typespec
(throw 'gw:bad-typespec "Bad enumeration options form."
options-form))))
(define (scm->c-ccg c-var scm-var typespec status-var)
(list
- scm-var " = gh_call1(" val->int-var-name ", " scm-var ");\n"
+ scm-var " = gw_enum_val2int(" val-sym-array-name ", " scm-var ");\n"
"if(SCM_FALSEP(scm_integer_p(" scm-var ")))"
`(gw:error ,status-var type ,scm-var)
- "else " c-var " = gh_scm2long(" scm-var ");\n"))
+ "else " c-var " = scm_num2long(" scm-var
+ ", 0, \"%gw:enum->scm->c-ccg\");\n"))
(define (c->scm-ccg scm-var c-var typespec status-var)
- (list scm-var " = gh_long2scm(" c-var ");\n"))
+ (list scm-var " = scm_long2num(" c-var ");\n"))
+
+ (define (c-destructor c-var typespec status-var force?)
+ '())
(define (global-declarations-ccg type client-wrapset)
(if (eq? client-wrapset wrapset)
@@ -65,84 +64,36 @@
(let* ((substitutions
`((enum-c-type-name ,c-type-name)
(enum-c-sym ,enum-c-sym)
+ (val-sym-array-name ,val-sym-array-name)
(val-to-int-func ,val->int-var-name)
(val-to-sym-func ,val->sym-var-name)
(val->int-c-func-name ,val->int-c-func-name)
(val->sym-c-func-name ,val->sym-c-func-name)
- (val->sym-logic
- ,(map
+ (val-sym-array
+ ,(list
+ "{\n"
+ (map
(lambda (enum-val)
(let ((c-sym (car enum-val))
(scm-sym (cdr enum-val)))
(list
- "\n"
- " if(gw__enum_val == " c-sym ") {\n"
- " if(!gw__return_all_syms) return gh_symbol2scm(\"" scm-sym "\");\n"
- " gw__scm_result =\n"
- " gh_cons(gh_symbol2scm(\"" scm-sym "\"), gw__scm_result);\n"
- " }\n")))
- (hashq-ref type 'enum:values)))
- (val->int-logic
- ,(map
- (lambda (enum-val)
- (let ((c-sym (car enum-val))
- (scm-sym (cdr enum-val)))
- (list
- "\n"
- " if(strcmp(gw__symstr, \"" scm-sym "\") == 0) {\n"
- " free(gw__symstr);\n"
- " return gh_long2scm(" c-sym ");\n"
- " }\n")))
- (hashq-ref type 'enum:values))))))
+ " {" c-sym ", \"" scm-sym "\" },\n")))
+ (hashq-ref type 'enum:values))
+ " { 0, NULL } }")))))
(translate-str "\
-static SCM
-%val->sym-c-func-name%(SCM gw__scm_val, SCM gw__scm_show_all_p) {
- %enum-c-type-name% gw__enum_val;
- SCM gw__scm_result;
-
- int gw__return_all_syms = SCM_NFALSEP(gw__scm_show_all_p);
- if(gw__return_all_syms) gw__scm_result = SCM_EOL;
- else gw__scm_result = SCM_BOOL_F;
+static GWEnumPair %val-sym-array-name%[] = %val-sym-array%;
- if(gh_symbol_p(gw__scm_val)) {
- SCM gw__scm_int_value = gh_call1(%val-to-int-func%,
- gw__scm_val);
- if(SCM_FALSEP(gw__scm_int_value)) return SCM_EOL;
- if(!gw__return_all_syms) return gw__scm_val;
- gw__enum_val = gh_scm2long(gw__scm_int_value);
- } else {
- /* this better be an int */
- gw__enum_val = gh_scm2long(gw__scm_val);
- }
-
- %val->sym-logic%
-
- return(gw__scm_result);
+static SCM
+%val->sym-c-func-name%(SCM gw__scm_val, SCM gw__scm_show_all_p) {
+ return gw_enum_val2sym(%val-sym-array-name%, gw__scm_val,
+ gw__scm_show_all_p);
}
static SCM
%val->int-c-func-name%(SCM gw__scm_val) {
- char *gw__symstr = NULL;
-
- if(SCM_NFALSEP(scm_integer_p(gw__scm_val))) {
- SCM gw__scm_existing_sym = gh_call2(%val-to-sym-func%,
- gw__scm_val,
- SCM_BOOL_F);
- if(SCM_FALSEP(gw__scm_existing_sym)) {
- return SCM_BOOL_F;
- } else {
- return gw__scm_val;
- }
- }
-
- gw__symstr = gh_symbol2newstr(gw__scm_val, NULL);
-
- %val->int-logic%
-
- free(gw__symstr);
- return SCM_BOOL_F;
+ return gw_enum_val2int(%val-sym-array-name%, gw__scm_val);
}
"
substitutions))))
@@ -171,48 +122,28 @@
" " val->sym-c-func-name ",\n"
" 2, 0, 0);\n"))))
- (define (pre-call-arg-ccg param status-var)
- (let* ((scm-name (gw:param-get-scm-name param))
- (c-name (gw:param-get-c-name param))
- (typespec (gw:param-get-typespec param)))
- (list
- (scm->c-ccg c-name scm-name typespec status-var)
- "if(" `(gw:error? ,status-var type) ")"
- `(gw:error ,status-var arg-type)
- "else if(" `(gw:error? ,status-var range) ")"
- `(gw:error ,status-var arg-range))))
-
- (define (call-ccg result func-call-code status-var)
- (list (gw:result-get-c-name result) " = " func-call-code ";\n"))
-
- (define (post-call-result-ccg result status-var)
- (let* ((scm-name (gw:result-get-scm-name result))
- (c-name (gw:result-get-c-name result))
- (typespec (gw:result-get-typespec result)))
- (c->scm-ccg scm-name c-name typespec status-var)))
-
- (hashq-set! wt 'enum:values '())
-
- (gw:type-set-c-type-name-func! wt c-type-name-func)
- (gw:type-set-typespec-options-parser! wt typespec-options-parser)
-
- (gw:type-set-scm->c-ccg! wt scm->c-ccg)
- (gw:type-set-c->scm-ccg! wt c->scm-ccg)
-
- (gw:type-set-global-declarations-ccg! wt global-declarations-ccg)
- (gw:type-set-global-definitions-ccg! wt global-definitions-ccg)
- (gw:type-set-global-initializations-ccg! wt global-init-ccg)
-
- (gw:type-set-pre-call-arg-ccg! wt pre-call-arg-ccg)
- (gw:type-set-call-ccg! wt call-ccg)
- (gw:type-set-post-call-result-ccg! wt post-call-result-ccg)
-
- (gw:wrapset-add-guile-module-export! wrapset
- (string->symbol val->int-scm-func-name))
- (gw:wrapset-add-guile-module-export! wrapset
- (string->symbol val->sym-scm-func-name))
-
- wt))
+ (let* ((wt (gw:wrap-dynamic-type
+ wrapset name-sym
+ c-type-name (string-append "const " c-type-name)
+ scm->c-ccg
+ c->scm-ccg
+ c-destructor
+ 'uint))) ;; FIMXE: are enumns are passed as ints always?
+
+ (hashq-set! wt 'enum:values '())
+
+ (gw:type-set-typespec-options-parser! wt typespec-options-parser)
+
+ (gw:type-set-global-declarations-ccg! wt global-declarations-ccg)
+ (gw:type-set-global-definitions-ccg! wt global-definitions-ccg)
+ (gw:type-set-global-initializations-ccg! wt global-init-ccg)
+
+ (gw:wrapset-add-guile-module-export! wrapset
+ (string->symbol val->int-scm-func-name))
+ (gw:wrapset-add-guile-module-export! wrapset
+ (string->symbol val->sym-scm-func-name))
+
+ wt)))
(define-public (gw:enum-add-value! enum c-val-namestr scheme-sym)
;; FIXME: need checking for duplicate values here...
--- orig/g-wrap/gw-glib-spec.scm
+++ mod/g-wrap/gw-glib-spec.scm
@@ -3,9 +3,9 @@
;;;
(define-module (g-wrap gw-glib-spec)
- :use-module (g-wrap))
-
-(use-modules (g-wrap simple-type))
+ #:use-module (g-wrap)
+ #:use-module (g-wrap simple-type)
+ #:use-module (g-wrap gw-standard-spec))
(let ((ws (gw:new-wrapset "gw-glib")))
@@ -27,10 +27,11 @@
ws ' "gint64"
'("gw_glib_gint64_p(" scm-var ")")
'(c-var " = gw_glib_scm_to_gint64(" scm-var ");\n")
- '(scm-var " = gw_glib_gint64_to_scm(" c-var ");\n"))
+ '(scm-var " = gw_glib_gint64_to_scm(" c-var ");\n")
+ 'sint64)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; gint64
+ ;; gchars
(let* ((gchars (gw:wrap-type ws ')))
(define (c-type-name-func typespec)
--- orig/g-wrap/gw-standard-spec.scm
+++ mod/g-wrap/gw-standard-spec.scm
@@ -1,195 +1,88 @@
;; -*-scheme-*-
-(define-module (g-wrap gw-standard-spec))
-
-(use-modules (g-wrap))
-(use-modules (g-wrap simple-type))
+(define-module (g-wrap gw-standard-spec)
+ #:use-module (g-wrap)
+ #:use-module (g-wrap simple-type)
+ #:use-module (g-wrap dynamic-type))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Simple ranged integer types.
;;;
;;; code stolen from plain simple-types. The same, but different :>
-(define (wrap-simple-ranged-signed-integer-type wrapset
- type-sym
- c-type-name
- scm-minval-text
- scm-maxval-text
- scm->c-form
- c->scm-form)
-
- (define (replace-syms tree alist)
- (cond
- ((null? tree) tree)
- ((list? tree) (map (lambda (elt) (replace-syms elt alist)) tree))
- ((symbol? tree)
- (let ((expansion (assq-ref alist tree)))
- (if (string? expansion)
- expansion
- (error "Expected string for expansion..."))))
- (else tree)))
-
- (let* ((simple-type (gw:wrap-type wrapset type-sym))
- (c-sym-name (gw:any-str->c-sym-str (symbol->string type-sym)))
+(define (wrap-simple-ranged-integer-type wrapset
+ type-sym
+ c-type-name
+ c-minval-text ; for unsigned, #f
+ c-maxval-text
+ scm->c-function
+ c->scm-function
+ c-typedef)
+
+ (let* ((c-sym-name (gw:any-str->c-sym-str (symbol->string type-sym)))
(minvar (gw:gen-c-tmp (string-append "range_minval" c-sym-name)))
(maxvar (gw:gen-c-tmp (string-append "range_maxval" c-sym-name))))
+
+ (define (scm->c-ccg c-var scm-var typespec error-var)
+ (list "if(SCM_FALSEP(scm_integer_p(" scm-var ")))"
+ `(gw:error ,error-var type ,scm-var)
+ (if c-minval-text
+ (list
+ "else if(SCM_FALSEP(scm_geq_p(" scm-var ", " minvar "))"
+ " || SCM_FALSEP(scm_leq_p(" scm-var ", " maxvar ")))")
+ (list
+ "else if(SCM_NFALSEP(scm_negative_p(" scm-var "))"
+ " || SCM_FALSEP(scm_leq_p(" scm-var ", " maxvar ")))"))
+ `(gw:error ,error-var range ,scm-var)
+ "else {\n"
+ ;; here we pass NULL and 0 as the callers because we've already
+ ;; checked the bounds on the argument
+ " " c-var " = " scm->c-function "(" scm-var ", 0, NULL);\n"
+ "}\n"))
- (define (c-type-name-func typespec)
- c-type-name)
-
+ (define (c->scm-ccg scm-var c-var typespec error-var)
+ (list scm-var " = " c->scm-function "(" c-var ");\n"))
+
+ (define (c-destructor c-var typespec status-var force?)
+ '())
+
(define (global-declarations-ccg type client-wrapset)
- (if client-wrapset
- (list "static SCM " minvar ";\n"
+ (if #t ;; (not client-wrapset)<- FIXME: no real need for this in depending wrapsets -- rotty
+ (list (if c-minval-text
+ (list "static SCM " minvar ";\n")
+ '())
"static SCM " maxvar ";\n")
'()))
- ;; TODO: maybe use status-var.
- (define (global-init-ccg type client-wrapset status-var)
- (if client-wrapset
- (list minvar " = " scm-minval-text ";\n"
- "scm_protect_object(" minvar ");\n"
- maxvar " = " scm-maxval-text ";\n"
+ ;; TODO: maybe use error-var.
+ (define (global-init-ccg type client-wrapset error-var)
+ (if #t ;; (not client-wrapset) <- FIXME: no real need forthis in depending wrapsets -- rotty
+ (list (if c-minval-text
+ (list minvar " = " c->scm-function "(" c-minval-text ");\n"
+ "scm_protect_object(" minvar ");\n")
+ '())
+ maxvar " = " c->scm-function "(" c-maxval-text ");\n"
"scm_protect_object(" maxvar ");\n")
'()))
- (define (scm->c-ccg c-var scm-var typespec status-var)
- (let ((scm->c-code (replace-syms scm->c-form `((c-var . ,c-var)
- (scm-var . ,scm-var)))))
- (list "if(SCM_FALSEP(scm_integer_p(" scm-var ")))"
- `(gw:error ,status-var type ,scm-var)
- "else if(SCM_FALSEP(scm_geq_p(" scm-var ", " minvar "))"
- " || SCM_FALSEP(scm_leq_p(" scm-var ", " maxvar ")))"
- `(gw:error ,status-var range ,scm-var)
- "else {" scm->c-code "}\n"
- "\n"
- "if(" `(gw:error? ,status-var type) ")"
- `(gw:error ,status-var arg-type)
- "else if(" `(gw:error? ,status-var range) ")"
- `(gw:error ,status-var arg-range))))
-
-
- (define (c->scm-ccg scm-var c-var typespec status-var)
- (replace-syms c->scm-form
- `((c-var . ,c-var)
- (scm-var . ,scm-var))))
-
- (define (pre-call-arg-ccg param status-var)
- (let* ((scm-name (gw:param-get-scm-name param))
- (c-name (gw:param-get-c-name param))
- (typespec (gw:param-get-typespec param)))
- (list
- (scm->c-ccg c-name scm-name typespec status-var)
- "if(" `(gw:error? ,status-var type) ")"
- `(gw:error ,status-var arg-type)
- "else if(" `(gw:error? ,status-var range) ")"
- `(gw:error ,status-var arg-range))))
-
-
- (define (call-ccg result func-call-code status-var)
- (list (gw:result-get-c-name result) " = " func-call-code ";\n"))
-
- (define (post-call-result-ccg result status-var)
- (let* ((scm-name (gw:result-get-scm-name result))
- (c-name (gw:result-get-c-name result))
- (typespec (gw:result-get-typespec result)))
- (c->scm-ccg scm-name c-name typespec status-var)))
-
- (gw:type-set-c-type-name-func! simple-type c-type-name-func)
- (gw:type-set-global-declarations-ccg! simple-type global-declarations-ccg)
- (gw:type-set-global-initializations-ccg! simple-type global-init-ccg)
- (gw:type-set-scm->c-ccg! simple-type scm->c-ccg)
- (gw:type-set-c->scm-ccg! simple-type c->scm-ccg)
- (gw:type-set-pre-call-arg-ccg! simple-type pre-call-arg-ccg)
- (gw:type-set-call-ccg! simple-type call-ccg)
- (gw:type-set-post-call-result-ccg! simple-type post-call-result-ccg)
-
- simple-type))
-
-(define (wrap-simple-ranged-unsigned-integer-type wrapset
- type-sym
- c-type-name
- scm-maxval-text
- scm->c-form
- c->scm-form)
-
- (define (replace-syms tree alist)
- (cond
- ((null? tree) tree)
- ((list? tree) (map (lambda (elt) (replace-syms elt alist)) tree))
- ((symbol? tree)
- (let ((expansion (assq-ref alist tree)))
- (if (string? expansion)
- expansion
- (error "Expected string for expansion..."))))
- (else tree)))
-
- (let* ((simple-type (gw:wrap-type wrapset type-sym))
- (c-sym-name (gw:any-str->c-sym-str (symbol->string type-sym)))
- (maxvar (gw:gen-c-tmp (string-append "range_maxval" c-sym-name))))
-
- (define (c-type-name-func typespec)
- c-type-name)
-
- (define (global-declarations-ccg type client-wrapset)
- (if client-wrapset
- (list "static SCM " maxvar ";\n")
- '()))
+ (define (typespec-options-parser options-form wrapset)
+ (let ((remainder options-form))
+ (set! remainder (delq 'const remainder))
+ (if (null? remainder)
+ (cons 'callee-owned options-form)
+ (throw 'gw:bad-typespec
+ "Bad simple-type options form - spurious options: "
+ remainder))))
- ;; TODO: maybe use status-var
- (define (global-init-ccg type client-wrapset status-var)
- (if client-wrapset
- (list maxvar " = " scm-maxval-text ";\n"
- "scm_protect_object(" maxvar ");\n")
- '()))
-
- (define (scm->c-ccg c-var scm-var typespec status-var)
- (let ((scm->c-code (replace-syms scm->c-form `((c-var . ,c-var)
- (scm-var . ,scm-var)))))
-
- (list
- "if(SCM_FALSEP(scm_integer_p(" scm-var ")))"
- `(gw:error ,status-var type ,scm-var)
- "else if(SCM_NFALSEP(scm_negative_p(" scm-var "))"
- " || SCM_FALSEP(scm_leq_p(" scm-var ", " maxvar ")))"
- `(gw:error ,status-var range ,scm-var)
- "else {" scm->c-code "}\n")))
-
- (define (c->scm-ccg scm-var c-var typespec status-var)
- (replace-syms c->scm-form
- `((c-var . ,c-var)
- (scm-var . ,scm-var))))
-
- (define (pre-call-arg-ccg param status-var)
- (let* ((scm-name (gw:param-get-scm-name param))
- (c-name (gw:param-get-c-name param))
- (typespec (gw:param-get-typespec param)))
- (list
- (scm->c-ccg c-name scm-name typespec status-var)
- "if(" `(gw:error? ,status-var type) ")"
- `(gw:error ,status-var arg-type)
- "else if(" `(gw:error? ,status-var range) ")"
- `(gw:error ,status-var arg-range))))
-
- (define (call-ccg result func-call-code status-var)
- (list (gw:result-get-c-name result) " = " func-call-code ";\n"))
-
- (define (post-call-result-ccg result status-var)
- (let* ((scm-name (gw:result-get-scm-name result))
- (c-name (gw:result-get-c-name result))
- (typespec (gw:result-get-typespec result)))
- (c->scm-ccg scm-name c-name typespec status-var)))
-
- (gw:type-set-c-type-name-func! simple-type c-type-name-func)
- (gw:type-set-global-declarations-ccg! simple-type global-declarations-ccg)
- (gw:type-set-global-initializations-ccg! simple-type global-init-ccg)
- (gw:type-set-scm->c-ccg! simple-type scm->c-ccg)
- (gw:type-set-c->scm-ccg! simple-type c->scm-ccg)
- (gw:type-set-pre-call-arg-ccg! simple-type pre-call-arg-ccg)
- (gw:type-set-call-ccg! simple-type call-ccg)
- (gw:type-set-post-call-result-ccg! simple-type post-call-result-ccg)
+ (let ((dynamic-type (gw:wrap-dynamic-type
+ wrapset type-sym c-type-name c-type-name
+ scm->c-ccg c->scm-ccg c-destructor c-typedef)))
+
+ (gw:type-set-global-declarations-ccg! dynamic-type global-declarations-ccg)
+ (gw:type-set-global-initializations-ccg! dynamic-type global-init-ccg)
+ (gw:type-set-typespec-options-parser! dynamic-type typespec-options-parser)
- simple-type))
-
+ dynamic-type)))
(let ((ws (gw:new-wrapset "gw-standard"))
(limits-requiring-types '()))
@@ -198,32 +91,48 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; void
- (let ((wt (gw:wrap-type ws ')))
+ (let ((wt (gw:wrap-dynamic-type
+ ws '
+ "void" "void"
+ (lambda (c-var scm-var typespec error-var)
+ (gw:typespec-check
+ typespec
+ (error "Can't convert a from Scheme to C.")
+ '()))
+ (lambda (scm-var c-var typespec error-var)
+ (gw:typespec-check
+ typespec
+ (error "Can't convert a from C to scm.")
+ (list scm-var " = SCM_UNSPECIFIED;\n")))
+ (lambda (c-var typespec error-var force?)
+ (gw:typespec-check typespec
+ (error "Can't destroy a .")
+ '()))
+ 'void)))
- (gw:type-set-c-type-name-func!
+ (gw:type-set-typespec-options-parser!
wt
- (lambda (typespec) "void"))
-
- (gw:type-set-scm->c-ccg!
- wt
- (lambda (c-var scm-var typespec status-var)
- (error "Can't convert a from Scheme to C.")))
-
- (gw:type-set-c->scm-ccg!
- wt
- (lambda (scm-var c-var typespec status-var)
- (error "Can't convert a from C to scm.")))
-
- (gw:type-set-c-destructor!
- wt
- (lambda (c-var typespec status-var force?)
- (error "Can't destroy a .")))
+ (lambda (options-form wrapset)
+ (let ((remainder options-form))
+ (if (null? remainder)
+ (cons 'callee-owned options-form)
+ (throw 'gw:bad-typespec
+ "Bad form - spurious options: "
+ remainder)))))
+ ;; We overwrite some of the ccgs generated by
+ ;; gw:wrap-dynamic-type, so that they don't invoke the ccgs we
+ ;; passed it. -- rotty
(gw:type-set-pre-call-arg-ccg!
wt
- (lambda (param status-var)
+ (lambda (param error-var)
(error "Can't use as an argument type.")))
+ (gw:type-set-post-call-result-ccg!
+ wt
+ (lambda (result error-var)
+ (list (gw:result-get-scm-name result) " = SCM_UNSPECIFIED;\n")))
+
;; no result assignment.
(gw:type-set-call-ccg!
wt
@@ -243,7 +152,8 @@
"SCM"
'("1")
'(c-var " = " scm-var ";\n")
- '(scm-var " = " c-var ";\n"))
+ '(scm-var " = " c-var ";\n")
+ 'pointer) ;; FIXME: This is not accurate -- rotty
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; - boolean type
@@ -251,87 +161,137 @@
;; Any scheme value is a valid bool.
'("1")
'(c-var "= SCM_NFALSEP(" scm-var ");\n")
- '(scm-var "= (" c-var ") ? SCM_BOOL_T : SCM_BOOL_F;\n"))
+ '(scm-var "= (" c-var ") ? SCM_BOOL_T : SCM_BOOL_F;\n")
+ 'sint)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;
+ ;; -- FIXME: scm chars are 0-255, not [-128,127] like c chars
+ ;; [rotty: c-chars are not always signed!]
(gw:wrap-simple-type ws ' "char"
'("SCM_NFALSEP(scm_char_p(" scm-var "))\n")
'(c-var "= SCM_CHAR(" scm-var ");\n")
- '(scm-var "= SCM_MAKE_CHAR(" c-var ");\n"))
+ '(scm-var "= SCM_MAKE_CHAR(" c-var ");\n")
+ 'schar) ;; FIXME: see above
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; -- scm chars are bounded to [0,255]
+ (gw:wrap-simple-type ws ' "unsigned char"
+ '("SCM_NFALSEP(scm_char_p(" scm-var "))\n")
+ '(c-var "= SCM_CHAR(" scm-var ");\n")
+ '(scm-var "= SCM_MAKE_CHAR(" c-var ");\n")
+ 'uchar)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
(gw:wrap-simple-type ws ' "float"
'("SCM_NFALSEP(scm_number_p(" scm-var "))\n")
'(c-var "= gh_scm2double(" scm-var ");\n")
- '(scm-var "= gh_double2scm(" c-var ");\n"))
+ '(scm-var "= gh_double2scm(" c-var ");\n")
+ 'float)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
(gw:wrap-simple-type ws ' "double"
'("SCM_NFALSEP(scm_number_p(" scm-var "))\n")
'(c-var "= gh_scm2double(" scm-var ");\n")
- '(scm-var "= gh_double2scm(" c-var ");\n"))
+ '(scm-var "= gh_double2scm(" c-var ");\n")
+ 'double)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;
+ (let ((wt (wrap-simple-ranged-integer-type
+ ws ' "short"
+ "SHRT_MIN" "SHRT_MAX"
+ "scm_num2short" "scm_short2num"
+ 'sshort)))
+ (set! limits-requiring-types (cons wt limits-requiring-types)))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;
+ (let ((wt (wrap-simple-ranged-integer-type
+ ws ' "unsigned short"
+ #f "USHRT_MAX"
+ "scm_num2ushort" "scm_ushort2num"
+ 'ushort)))
+ (set! limits-requiring-types (cons wt limits-requiring-types)))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
- (let ((wt (wrap-simple-ranged-signed-integer-type
+ (let ((wt (wrap-simple-ranged-integer-type
ws ' "int"
- "scm_long2num(INT_MIN)"
- "scm_long2num(INT_MAX)"
- '(c-var "= gh_scm2long(" scm-var ");\n")
- '(scm-var "= gh_long2scm(" c-var ");\n"))))
+ "INT_MIN" "INT_MAX"
+ "scm_num2int" "scm_int2num"
+ 'sint)))
(set! limits-requiring-types (cons wt limits-requiring-types)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
- (let ((wt (wrap-simple-ranged-unsigned-integer-type
+ (let ((wt (wrap-simple-ranged-integer-type
ws ' "unsigned int"
- "scm_ulong2num(UINT_MAX)"
- '(c-var "= gh_scm2ulong(" scm-var ");\n")
- '(scm-var "= gh_ulong2scm(" c-var ");\n"))))
+ #f "UINT_MAX"
+ "scm_num2uint" "scm_uint2num"
+ 'uint)))
(set! limits-requiring-types (cons wt limits-requiring-types)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
- (let ((wt (wrap-simple-ranged-signed-integer-type
+ (let ((wt (wrap-simple-ranged-integer-type
ws ' "long"
- "scm_long2num(LONG_MIN)"
- "scm_long2num(LONG_MAX)"
- '(c-var "= gh_scm2long(" scm-var ");\n")
- '(scm-var "= gh_long2scm(" c-var ");\n"))))
+ "LONG_MIN" "LONG_MAX"
+ "scm_num2long" "scm_long2num"
+ 'slong)))
(set! limits-requiring-types (cons wt limits-requiring-types)))
-
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
- (let ((wt (wrap-simple-ranged-unsigned-integer-type
+ (let ((wt (wrap-simple-ranged-integer-type
ws ' "unsigned long"
- "scm_ulong2num(ULONG_MAX)"
- '(c-var "= gh_scm2ulong(" scm-var ");\n")
- '(scm-var "= gh_ulong2scm(" c-var ");\n"))))
+ #f "ULONG_MAX"
+ "scm_num2ulong" "scm_ulong2num"
+ 'ulong)))
(set! limits-requiring-types (cons wt limits-requiring-types)))
+
+ (if (string>=? (version) "1.6")
+ (begin
+ ;; There's a bit of a mess in some older guiles wrt long long
+ ;; support. I don't know when it was fixed, but I know that the
+ ;; 1.6 series works properly -- apw
+ ;;
+ ;; Maybe we can make Guile 1.6 a requirement -- rotty
+
+ ;; FIXME: how to handle the no-long-longs case nicely?
+ ;; Why can't an honest guy seem to get a hold of LLONG_MAX?
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;
+ (let ((wt (wrap-simple-ranged-integer-type
+ ws ' "long long"
+ "((long long)0x7fffffffffffffffULL)"
+ "((long long)0x8000000000000000ULL)"
+ "scm_num2long_long" "scm_long_long2num"
+ 'sint64))) ;; FIXME: not accurate -- rotty
+ (set! limits-requiring-types (cons wt limits-requiring-types)))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;
+ (let ((wt (wrap-simple-ranged-integer-type
+ ws ' "unsigned long long"
+ #f "((unsigned long long)0xffffffffffffffffULL)"
+ "scm_num2ulong_long" "scm_ulong_long2num"
+ 'uint64))) ;; FIXME: not accurate -- rotty
+ (set! limits-requiring-types (cons wt limits-requiring-types)))))
+
- ;; long long support is currently unavailable. To fix that, we're
- ;; going to need to do some work to handle broken versions of guile
- ;; (or perhaps just refuse to add long long support for those
- ;; versions. The issue is that some versions of guile in
- ;; libguile/__scm.h just "typedef long long_long" even on platforms
- ;; that have long long's that are larger than long. This is a mess,
- ;; meaning, among other things, that long_long won't be big enough
- ;; to hold LONG_LONG_MAX, etc. yuck. (NOTE: )))
-
- (define (c-type-name-func typespec)
- (if (memq 'const (gw:typespec-get-options typespec))
- "const char *"
- "char *"))
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;
+ (let ()
+ ;; This is in fact the same as the dynamic-type one, except that
+ ;; we ignore 'null-ok (hack to make guile-gobject work)
(define (typespec-options-parser options-form wrapset)
(let ((remainder options-form))
(set! remainder (delq 'const remainder))
+ (set! remainder (delq 'null-ok remainder))
(if (and (memq 'caller-owned remainder)
(memq 'callee-owned remainder))
(throw 'gw:bad-typespec
@@ -340,7 +300,7 @@
(if (not (or (memq 'caller-owned remainder)
(memq 'callee-owned remainder)))
(throw 'gw:bad-typespec
- "Bad options form (must be caller or callee owned!)."
+ (format #t "Bad options form for type ~A (must be caller or callee owned!)." type-sym)
options-form))
(set! remainder (delq 'caller-owned remainder))
(set! remainder (delq 'callee-owned remainder))
@@ -350,71 +310,42 @@
"Bad options form - spurious options: "
remainder))))
- (define (scm->c-ccg c-var scm-var typespec status-var)
+ (define (scm->c-ccg c-var scm-var typespec error-var)
(list
c-var " = NULL;\n"
"\n"
"if(SCM_FALSEP(" scm-var "))\n"
" " c-var " = NULL;\n"
"else if(SCM_STRINGP(" scm-var "))\n"
- " " c-var " = gh_scm2newstr(" scm-var ", NULL);\n"
+ " " c-var " = strdup (SCM_STRING_CHARS (" scm-var "));\n"
"else\n"
- `(gw:error ,status-var type ,scm-var)))
+ `(gw:error ,error-var type ,scm-var)))
- (define (c->scm-ccg scm-var c-var typespec status-var)
+ (define (c->scm-ccg scm-var c-var typespec error-var)
(list
- " /* we coerce to (char *) here b/c broken guile 1.3.4 prototype */\n"
"if(" c-var " == NULL) " scm-var " = SCM_BOOL_F;\n"
"else "
- scm-var " = gh_str02scm((char *) " c-var ");\n"))
+ scm-var " = scm_makfrom0str( " c-var ");\n"))
- (define (c-destructor c-var typespec status-var force?)
- (if (or force?
- (memq 'caller-owned (gw:typespec-get-options typespec)))
- (list "if(" c-var ") free((void *) " c-var ");\n")
- '()))
+ (define (c-destructor c-var typespec error-var force?)
+ (gw:typespec-check
+ typespec
+ (if (or force?
+ (memq 'caller-owned (gw:typespec-get-options typespec)))
+ (list "if(" c-var ") free(" c-var ");\n")
+ '())
+ (list "if (" c-var "&& (" force? "|| (" typespec
+ " & GW_TYPESPEC_CALLER_OWNED))) free(" c-var ");\n")))
+
+ (let* ((mchars (gw:wrap-dynamic-type ws '
+ "char *" "char *"
+ scm->c-ccg c->scm-ccg c-destructor
+ 'pointer)))
- (define (pre-call-arg-ccg param status-var)
- (let* ((scm-name (gw:param-get-scm-name param))
- (c-name (gw:param-get-c-name param))
- (typespec (gw:param-get-typespec param)))
- (list
- (scm->c-ccg c-name scm-name typespec status-var)
- "if(" `(gw:error? ,status-var type) ")"
- `(gw:error ,status-var arg-type)
- "else if(" `(gw:error? ,status-var range) ")"
- `(gw:error ,status-var arg-range))))
-
- (define (call-ccg result func-call-code status-var)
- (list (gw:result-get-c-name result) " = " func-call-code ";\n"))
-
- (define (post-call-arg-ccg param status-var)
- (let* ((c-name (gw:param-get-c-name param))
- (typespec (gw:param-get-typespec param)))
- (c-destructor c-name typespec status-var #f)))
-
- (define (post-call-result-ccg result status-var)
- (let* ((scm-name (gw:result-get-scm-name result))
- (c-name (gw:result-get-c-name result))
- (typespec (gw:result-get-typespec result)))
- (list
- (c->scm-ccg scm-name c-name typespec status-var)
- (c-destructor c-name typespec status-var #f))))
-
- (gw:type-set-c-type-name-func! mchars c-type-name-func)
(gw:type-set-typespec-options-parser! mchars typespec-options-parser)
- (gw:type-set-scm->c-ccg! mchars scm->c-ccg)
- (gw:type-set-c->scm-ccg! mchars c->scm-ccg)
- (gw:type-set-c-destructor! mchars c-destructor)
-
- (gw:type-set-pre-call-arg-ccg! mchars pre-call-arg-ccg)
- (gw:type-set-call-ccg! mchars call-ccg)
- (gw:type-set-post-call-arg-ccg! mchars post-call-arg-ccg)
- (gw:type-set-post-call-result-ccg! mchars post-call-result-ccg)
-
- mchars)
-
+ mchars))
+
(gw:wrapset-add-cs-before-includes!
ws
(lambda (wrapset client-wrapset)
@@ -427,10 +358,12 @@
(gw:wrapset-add-cs-declarations!
ws
(lambda (wrapset client-wrapset)
- (if (and client-wrapset
- (gw:any? (lambda (x) (gw:wrapset-uses-type? client-wrapset x))
- limits-requiring-types))
- "#include \n"
- '())))
+ (list
+ (if (and client-wrapset
+ (gw:any? (lambda (x) (gw:wrapset-uses-type? client-wrapset x))
+ limits-requiring-types))
+ "#include \n"
+ '())
+ )))
)
--- orig/g-wrap/gw-wct-spec.scm
+++ mod/g-wrap/gw-wct-spec.scm
@@ -1,11 +1,10 @@
;; -*-scheme-*-
-(define-module (g-wrap gw-wct-spec))
-
-(use-modules (g-wrap))
-(use-modules (g-wrap simple-type))
-
-(use-modules (g-wrap gw-standard-spec))
+(define-module (g-wrap gw-wct-spec)
+ #:use-module (g-wrap)
+ #:use-module (g-wrap simple-type)
+ #:use-module (g-wrap dynamic-type)
+ #:use-module (g-wrap gw-standard-spec))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Wrapped C type (wct)
@@ -40,11 +39,10 @@
(define-public (gw:wrap-as-wct wrapset name-sym c-type-name c-const-type-name)
- (let* ((wct (gw:wrap-type wrapset name-sym))
- (wct-var-name (gw:gen-c-tmp
- (string-append
- "wct_info_for_"
- (gw:any-str->c-sym-str (symbol->string name-sym))))))
+ (let ((wct-var-name (gw:gen-c-tmp
+ (string-append
+ "wct_info_for_"
+ (gw:any-str->c-sym-str (symbol->string name-sym))))))
(define (generate-print-func type func-name)
(let ((func-ccg (hashq-ref type 'wct:print-ccg #f)))
@@ -82,16 +80,11 @@
(func-ccg type "gw__result" "gw__wcp")
"}\n")))
- (define (c-type-name-func typespec)
- (if (memq 'const (gw:typespec-get-options typespec))
- c-const-type-name
- c-type-name))
-
(define (typespec-options-parser options-form wrapset)
(let ((remainder options-form))
(set! remainder (delq 'const options-form))
(if (null? remainder)
- options-form
+ (cons 'caller-owned options-form)
(throw 'gw:bad-typespec "Bad wct options form." options-form))))
(define (scm->c-ccg c-var scm-var typespec status-var)
@@ -115,12 +108,15 @@
(list
"if(" cv " == NULL) " sv " = SCM_BOOL_F;\n"
"else " sv " = gw_wcp_assimilate_ptr((void *) " cv ", " wct-var ");\n")))
+
+ (define (c-destructor c-var typespec status-var force?)
+ '())
(define (global-declarations-ccg type client-wrapset)
(if (eq? client-wrapset wrapset)
'()
(list "static SCM " wct-var-name " = SCM_BOOL_F;\n")))
-
+
(define (global-definitions-ccg type client-wrapset)
(let* ((print-func-name (hashq-ref type 'wct:print-func-name #f))
(equal?-func-name (hashq-ref type 'wct:equal?-func-name #f))
@@ -181,26 +177,6 @@
(wct-init-ccg type client-wrapset)
'()))))
- (define (pre-call-arg-ccg param status-var)
- (let* ((scm-name (gw:param-get-scm-name param))
- (c-name (gw:param-get-c-name param))
- (typespec (gw:param-get-typespec param)))
- (list
- (scm->c-ccg c-name scm-name typespec status-var)
- "if(" `(gw:error? ,status-var type) ")"
- `(gw:error ,status-var arg-type)
- "else if(" `(gw:error? ,status-var range) ")"
- `(gw:error ,status-var arg-range))))
-
- (define (call-ccg result func-call-code status-var)
- (list (gw:result-get-c-name result) " = " func-call-code ";\n"))
-
- (define (post-call-result-ccg result status-var)
- (let* ((scm-name (gw:result-get-scm-name result))
- (c-name (gw:result-get-c-name result))
- (typespec (gw:result-get-typespec result)))
- (c->scm-ccg scm-name c-name typespec status-var)))
-
;; This is so that any wrapset that depends on any wrapset that
;; wraps a wct will also have the header inserted...
(if (not (hashq-ref wrapsets-w-wct-initializers wrapset #f))
@@ -211,24 +187,21 @@
"#include \n"))
(hashq-set! wrapsets-w-wct-initializers wrapset #t)))
-
- (gw:type-set-c-type-name-func! wct c-type-name-func)
- (gw:type-set-typespec-options-parser! wct typespec-options-parser)
-
- (gw:type-set-scm->c-ccg! wct scm->c-ccg)
- (gw:type-set-c->scm-ccg! wct c->scm-ccg)
-
- (gw:type-set-global-declarations-ccg! wct global-declarations-ccg)
- (gw:type-set-global-definitions-ccg! wct global-definitions-ccg)
- (gw:type-set-global-initializations-ccg! wct global-init-ccg)
- (gw:type-set-pre-call-arg-ccg! wct pre-call-arg-ccg)
- (gw:type-set-call-ccg! wct call-ccg)
- (gw:type-set-post-call-result-ccg! wct post-call-result-ccg)
-
- (gw:wrapset-add-guile-module-export! wrapset name-sym)
+ (let ((wct (gw:wrap-dynamic-type wrapset name-sym
+ c-type-name c-const-type-name
+ scm->c-ccg c->scm-ccg c-destructor
+ 'pointer)))
+
+ (gw:type-set-typespec-options-parser! wct typespec-options-parser)
+
+ (gw:type-set-global-declarations-ccg! wct global-declarations-ccg)
+ (gw:type-set-global-definitions-ccg! wct global-definitions-ccg)
+ (gw:type-set-global-initializations-ccg! wct global-init-ccg)
+
+ (gw:wrapset-add-guile-module-export! wrapset name-sym)
- wct))
+ wct)))
;; Are all these the overrides the "right thing"? Is there a better
;; approach, and/or do we need them at all?
@@ -292,14 +265,16 @@
(gw:wrap-simple-type ws ' "SCM"
'("gw_wct_p(" scm-var ")")
'(c-var " = " scm-var ";\n")
- '(scm-var " = " c-var ";\n"))
+ '(scm-var " = " c-var ";\n")
+ 'pointer) ;; not accurate
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; - wrapped c pointer object
(gw:wrap-simple-type ws ' "SCM"
'("gw_wcp_p(" scm-var ")")
'(c-var " = " scm-var ";\n")
- '(scm-var " = " c-var ";\n"))
+ '(scm-var " = " c-var ";\n")
+ 'pointer) ;; not accurate
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; - wrapped c pointer object
--- orig/g-wrap/runtime.scm
+++ mod/g-wrap/runtime.scm
@@ -1,3 +1,6 @@
+;; I guess this module should provide a scheme interface to the stuff
+;; in g-wrap-runtime.c. -- rotty
+
(define-module (g-wrap runtime))
(define gw:runtime-wrapsets-hash (make-hash-table 131))
--- orig/g-wrap/simple-type.scm
+++ mod/g-wrap/simple-type.scm
@@ -1,15 +1,18 @@
(define-module (g-wrap simple-type)
- :use-module (g-wrap))
+ #:use-module (g-wrap)
+ #:use-module (g-wrap dynamic-type))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Simple types.
;;;
-;;; Simple types are simple :> They just need to specify their normal
-;;; type name, their const type name, their type check function, their
-;;; scm->c function, their c->scm function, and their destructor. All
-;;; the code will be generated automatically. The newly created type
-;;; will respond to 'const as a typespec option.
+;;; Simple types are simple :> They just need to specify their type
+;;; name, their type check function, their scm->c function, their
+;;; c->scm function. All the code will be generated automatically.
+;;;
+;;; A simple type is implemented as a dynamic type wich is always
+;;; callee-owned (since simple type are assumed to be converted
+;;; completly, i.e. the SCM value has no reference to the C value).
;;;
;;; The "functions" may only be a static tree of strings and symbols.
;;; Each symbol must be recognized and will be expanded to the proper
@@ -17,7 +20,6 @@
;;;
;;; (gw:wrap-simple-type '
;;; "GUID"
-;;; "const GUID"
;;; '("gnc_guid_p(" scm-var ")")
;;; '(c-var " = gnc_scm2guid(" scm-var ");\n")
;;; '(scm-var " = gnc_guid2scm(" c-var ");\n")
@@ -28,7 +30,8 @@
c-type-name
type-check-form
scm->c-form
- c->scm-form)
+ c->scm-form
+ c-typedef)
(define (replace-syms tree alist)
(cond
@@ -40,56 +43,49 @@
expansion
(error
(string-append
- "g-wrap simple-type expected string for expansion "
+ "g-wrap dynamic-type expected string for expansion "
"while processing ~S from wrapset ~S\n.")
type-sym
(gw:wrapset-get-name wrapset)))))
(else tree)))
- (let ((simple-type (gw:wrap-type wrapset type-sym)))
-
- (define (c-type-name-func typespec)
- c-type-name)
+ (define (scm->c-ccg c-var scm-var typespec status-var)
+ (let ((type-check-code (replace-syms type-check-form
+ `((scm-var . ,scm-var))))
+ (scm->c-code (replace-syms scm->c-form `((c-var . ,c-var)
+ (scm-var . ,scm-var)))))
+ (list "if (!(" type-check-code "))"
+ `(gw:error ,status-var type ,scm-var)
+ "else {" scm->c-code "}")))
+
+ (define (c->scm-ccg scm-var c-var typespec status-var)
+ (replace-syms c->scm-form
+ `((c-var . ,c-var)
+ (scm-var . ,scm-var))))
+
+ (define (c-destructor c-var typespec status-var force?)
+ '())
+
+ (let ((simple-type (gw:wrap-dynamic-type wrapset
+ type-sym
+ c-type-name
+ c-type-name
+ scm->c-ccg
+ c->scm-ccg
+ c-destructor
+ c-typedef)))
- (define (scm->c-ccg c-var scm-var typespec status-var)
- (let ((type-check-code (replace-syms type-check-form
- `((scm-var . ,scm-var))))
- (scm->c-code (replace-syms scm->c-form `((c-var . ,c-var)
- (scm-var . ,scm-var)))))
- (list "if (!(" type-check-code "))"
- `(gw:error ,status-var type ,scm-var)
- "else {" scm->c-code "}")))
-
- (define (c->scm-ccg scm-var c-var typespec status-var)
- (replace-syms c->scm-form
- `((c-var . ,c-var)
- (scm-var . ,scm-var))))
+ (define (typespec-options-parser options-form wrapset)
+ (let ((remainder options-form))
+ (set! remainder (delq 'const remainder))
+ (if (null? remainder)
+ (cons 'callee-owned options-form)
+ (throw 'gw:bad-typespec
+ "Bad simple-type options form - spurious options: "
+ remainder))))
+
- (define (pre-call-arg-ccg param status-var)
- (let* ((scm-name (gw:param-get-scm-name param))
- (c-name (gw:param-get-c-name param))
- (typespec (gw:param-get-typespec param)))
- (list
- (scm->c-ccg c-name scm-name typespec status-var)
- "if (" `(gw:error? ,status-var type) ")"
- `(gw:error ,status-var arg-type)
- "else if (" `(gw:error? ,status-var range) ")"
- `(gw:error ,status-var arg-range))))
+ (gw:type-set-typespec-options-parser! simple-type typespec-options-parser)
- (define (call-ccg result func-call-code status-var)
- (list (gw:result-get-c-name result) " = " func-call-code ";\n"))
-
- (define (post-call-result-ccg result status-var)
- (let* ((scm-name (gw:result-get-scm-name result))
- (c-name (gw:result-get-c-name result))
- (typespec (gw:result-get-typespec result)))
- (c->scm-ccg scm-name c-name typespec status-var)))
-
- (gw:type-set-c-type-name-func! simple-type c-type-name-func)
- (gw:type-set-scm->c-ccg! simple-type scm->c-ccg)
- (gw:type-set-c->scm-ccg! simple-type c->scm-ccg)
- (gw:type-set-pre-call-arg-ccg! simple-type pre-call-arg-ccg)
- (gw:type-set-call-ccg! simple-type call-ccg)
- (gw:type-set-post-call-result-ccg! simple-type post-call-result-ccg)
-
simple-type))
+