← Back to branch summary

~ubuntu-branches/ubuntu/utopic/critcl/utopic

« back to all changes in this revision

Viewing changes to lib/stubs/gen_decl.tcl

  • Committer: Package Import Robot
  • Author(s): Andrew Shadura
  • Date: 2013-05-11 00:08:06 UTC
  • Revision ID: package-import@ubuntu.com-20130511000806-7hq1zc3fnn0gat79
Tags: upstream-3.1.9
Import upstream version 3.1.9

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/stubs/gen_decl.tcl
 
1
# -*- tcl -*-
 
2
# STUBS handling -- Code generation: Writing declarations.
 
3
#
 
4
# (c) 2011 Andreas Kupries http://wiki.tcl.tk/andreas%20kupries
 
5
 
 
6
# A stubs table is represented by a dictionary value.
 
7
# A gen is a variable holding a stubs table value.
 
8
 
 
9
# # ## ### ##### ######## #############
 
10
## Requisites
 
11
 
 
12
package require Tcl 8.4
 
13
package require stubs::gen
 
14
package require stubs::container
 
15
package require lassign84
 
16
 
 
17
namespace eval ::stubs::gen::decl::g {
 
18
    namespace import ::stubs::gen::*
 
19
}
 
20
 
 
21
namespace eval ::stubs::gen::decl::c {
 
22
    namespace import ::stubs::container::*
 
23
}
 
24
 
 
25
# # ## ### ##### ######## #############
 
26
## Implementation.
 
27
 
 
28
proc ::stubs::gen::decl::gen {table name} {
 
29
    set text "\n/*\n * Exported function declarations:\n */\n\n"
 
30
    append text [g::forall $table $name [list [namespace current]::Make $table] 0]
 
31
    return $text
 
32
}
 
33
 
 
34
# # ## ### #####
 
35
## Internal helpers.
 
36
 
 
37
proc ::stubs::gen::decl::Make {table name decl index} {
 
38
    #puts "DECL($name $index) = |$decl|"
 
39
 
 
40
    lassign $decl rtype fname args
 
41
 
 
42
    append text "/* $index */\n"
 
43
 
 
44
    set    line  "[c::scspec? $table] $rtype"
 
45
    set    count [expr {2 - ([string length $line] / 8)}]
 
46
    append line [string range "\t\t\t" 0 $count]
 
47
 
 
48
    set pad [expr {24 - [string length $line]}]
 
49
    if {$pad <= 0} {
 
50
        append line " "
 
51
        set pad 0
 
52
    }
 
53
 
 
54
    if {![llength $args]} {
 
55
        append text $line $fname ";\n"
 
56
        return $text
 
57
    }
 
58
 
 
59
    set arg1 [lindex $args 0]
 
60
    switch -exact -- $arg1 {
 
61
        void {
 
62
            append text $line $fname "(void)"
 
63
        }
 
64
        TCL_VARARGS {
 
65
            append line $fname
 
66
            append text [MakeArgs $line $pad [lrange $args 1 end] ", ..."]
 
67
        }
 
68
        default {
 
69
            append line $fname
 
70
            append text [MakeArgs $line $pad $args]
 
71
        }
 
72
    }
 
73
    append text ";\n"
 
74
    return $text
 
75
}
 
76
 
 
77
proc ::stubs::gen::decl::MakeArgs {line pad arguments {suffix {}}} {
 
78
    #checker -scope local exclude warnArgWrite
 
79
    set text ""
 
80
    set sep "("
 
81
    foreach arg $arguments {
 
82
        append line $sep
 
83
        set next {}
 
84
 
 
85
        lassign $arg atype aname aind
 
86
 
 
87
        append next $atype
 
88
        if {[string index $next end] ne "*"} {
 
89
            append next " "
 
90
        }
 
91
        append next $aname $aind
 
92
 
 
93
        if {([string length $line] + [string length $next] + $pad) > 76} {
 
94
            append text [string trimright $line] \n
 
95
            set line "\t\t\t\t"
 
96
            set pad 28
 
97
        }
 
98
        append line $next
 
99
        set sep ", "
 
100
    }
 
101
    append line "$suffix)"
 
102
 
 
103
    if {[lindex $arguments end] eq "{const char *} format"} {
 
104
        # TCL_VARARGS case... arguments list already shrunken.
 
105
        set n [llength $arguments]
 
106
        append line " TCL_FORMAT_PRINTF(" $n ", " [expr {$n + 1}] ")"
 
107
    }
 
108
 
 
109
    return $text$line
 
110
}
 
111
 
 
112
# # ## ### #####
 
113
namespace eval ::stubs::gen::decl {
 
114
    namespace export gen
 
115
}
 
116
 
 
117
# # ## ### #####
 
118
package provide stubs::gen::decl 1
 
119
return