* 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)) +