Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: data/media/tcl8.4/ldAout.tcl @ 5500

Last change on this file since 5500 was 5167, checked in by rgrieder, 16 years ago

added svn property svn:eol-style native to all tcl files

  • Property svn:eol-style set to native
File size: 6.6 KB
Line 
1# ldAout.tcl --
2#
3#       This "tclldAout" procedure in this script acts as a replacement
4#       for the "ld" command when linking an object file that will be
5#       loaded dynamically into Tcl or Tk using pseudo-static linking.
6#
7# Parameters:
8#       The arguments to the script are the command line options for
9#       an "ld" command.
10#
11# Results:
12#       The "ld" command is parsed, and the "-o" option determines the
13#       module name.  ".a" and ".o" options are accumulated.
14#       The input archives and object files are examined with the "nm"
15#       command to determine whether the modules initialization
16#       entry and safe initialization entry are present.  A trivial
17#       C function that locates the entries is composed, compiled, and
18#       its .o file placed before all others in the command; then
19#       "ld" is executed to bind the objects together.
20#
21# RCS: @(#) $Id: ldAout.tcl,v 1.5 2001/09/28 01:21:53 dgp Exp $
22#
23# Copyright (c) 1995, by General Electric Company. All rights reserved.
24#
25# See the file "license.terms" for information on usage and redistribution
26# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
27#
28# This work was supported in part by the ARPA Manufacturing Automation
29# and Design Engineering (MADE) Initiative through ARPA contract
30# F33615-94-C-4400.
31
32proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
33    global env
34    global argv
35
36    if {[string equal $cc ""]} {
37        set cc $env(CC)
38    }
39
40    # if only two parameters are supplied there is assumed that the
41    # only shlib_suffix is missing. This parameter is anyway available
42    # as "info sharedlibextension" too, so there is no need to transfer
43    # 3 parameters to the function tclLdAout. For compatibility, this
44    # function now accepts both 2 and 3 parameters.
45
46    if {[string equal $shlib_suffix ""]} {
47        set shlib_cflags $env(SHLIB_CFLAGS)
48    } elseif {[string equal $shlib_cflags "none"]} {
49        set shlib_cflags $shlib_suffix
50    }
51
52    # seenDotO is nonzero if a .o or .a file has been seen
53    set seenDotO 0
54
55    # minusO is nonzero if the last command line argument was "-o".
56    set minusO 0
57
58    # head has command line arguments up to but not including the first
59    # .o or .a file. tail has the rest of the arguments.
60    set head {}
61    set tail {}
62
63    # nmCommand is the "nm" command that lists global symbols from the
64    # object files.
65    set nmCommand {|nm -g}
66
67    # entryProtos is the table of _Init and _SafeInit prototypes found in the
68    # module.
69    set entryProtos {}
70
71    # entryPoints is the table of _Init and _SafeInit entries found in the
72    # module.
73    set entryPoints {}
74
75    # libraries is the list of -L and -l flags to the linker.
76    set libraries {}
77    set libdirs {}
78
79    # Process command line arguments
80    foreach a $argv {
81        if {!$minusO && [regexp {\.[ao]$} $a]} {
82            set seenDotO 1
83            lappend nmCommand $a
84        }
85        if {$minusO} {
86            set outputFile $a
87            set minusO 0
88        } elseif {![string compare $a -o]} {
89            set minusO 1
90        }
91        if {[regexp {^-[lL]} $a]} {
92            lappend libraries $a
93            if {[regexp {^-L} $a]} {
94                lappend libdirs [string range $a 2 end]
95            }
96        } elseif {$seenDotO} {
97            lappend tail $a
98        } else {
99            lappend head $a
100        }
101    }
102    lappend libdirs /lib /usr/lib
103
104    # MIPS -- If there are corresponding G0 libraries, replace the
105    # ordinary ones with the G0 ones.
106
107    set libs {}
108    foreach lib $libraries {
109        if {[regexp {^-l} $lib]} {
110            set lname [string range $lib 2 end]
111            foreach dir $libdirs {
112                if {[file exists [file join $dir lib${lname}_G0.a]]} {
113                    set lname ${lname}_G0
114                    break
115                }
116            }
117            lappend libs -l$lname
118        } else {
119            lappend libs $lib
120        }
121    }
122    set libraries $libs
123
124    # Extract the module name from the "-o" option
125
126    if {![info exists outputFile]} {
127        error "-o option must be supplied to link a Tcl load module"
128    }
129    set m [file tail $outputFile]
130    if {[regexp {\.a$} $outputFile]} {
131        set shlib_suffix .a
132    } else {
133        set shlib_suffix ""
134    }
135    if {[regexp {\..*$} $outputFile match]} {
136        set l [expr {[string length $m] - [string length $match]}]
137    } else {
138        error "Output file does not appear to have a suffix"
139    }
140    set modName [string tolower $m 0 [expr {$l-1}]]
141    if {[regexp {^lib} $modName]} {
142        set modName [string range $modName 3 end]
143    }
144    if {[regexp {[0-9\.]*(_g0)?$} $modName match]} {
145        set modName [string range $modName 0 [expr {[string length $modName]-[string length $match]-1}]]
146    }
147    set modName [string totitle $modName]
148
149    # Catalog initialization entry points found in the module
150
151    set f [open $nmCommand r]
152    while {[gets $f l] >= 0} {
153        if {[regexp {T[         ]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol]} {
154            if {![regexp {_?([A-Z][a-z0-9_]*_(Safe)?Init)} $symbol trash s]} {
155                set s $symbol
156            }
157            append entryProtos {extern int } $symbol { (); } \n
158            append entryPoints {  } \{ { "} $s {", } $symbol { } \} , \n
159        }
160    }
161    close $f
162
163    if {[string equal $entryPoints ""]} {
164        error "No entry point found in objects"
165    }
166
167    # Compose a C function that resolves the initialization entry points and
168    # embeds the required libraries in the object code.
169
170    set C {#include <string.h>}
171    append C \n
172    append C {char TclLoadLibraries_} $modName { [] =} \n
173    append C {  "@LIBS: } $libraries {";} \n
174    append C $entryProtos
175    append C {static struct } \{ \n
176    append C {  char * name;} \n
177    append C {  int (*value)();} \n
178    append C \} {dictionary [] = } \{ \n
179    append C $entryPoints
180    append C {  0, 0 } \n \} \; \n
181    append C {typedef struct Tcl_Interp Tcl_Interp;} \n
182    append C {typedef int Tcl_PackageInitProc (Tcl_Interp *);} \n
183    append C {Tcl_PackageInitProc *} \n
184    append C TclLoadDictionary_ $modName { (symbol)} \n
185    append C {    CONST char * symbol;} \n
186    append C {
187        {
188            int i;
189            for (i = 0; dictionary [i] . name != 0; ++i) {
190                if (!strcmp (symbol, dictionary [i] . name)) {
191                    return dictionary [i].value;
192                }
193            }
194            return 0;
195        }
196    }
197    append C \n
198
199
200    # Write the C module and compile it
201
202    set cFile tcl$modName.c
203    set f [open $cFile w]
204    puts -nonewline $f $C
205    close $f
206    set ccCommand "$cc -c $shlib_cflags $cFile"
207    puts stderr $ccCommand
208    eval exec $ccCommand
209
210    # Now compose and execute the ld command that packages the module
211
212    if {[string equal $shlib_suffix ".a"]} {
213        set ldCommand "ar cr $outputFile"
214        regsub { -o} $tail {} tail
215    } else {
216        set ldCommand ld
217        foreach item $head {
218            lappend ldCommand $item
219        }
220    }
221    lappend ldCommand tcl$modName.o
222    foreach item $tail {
223        lappend ldCommand $item
224    }
225    puts stderr $ldCommand
226    eval exec $ldCommand
227    if {[string equal $shlib_suffix ".a"]} {
228        exec ranlib $outputFile
229    }
230
231    # Clean up working files
232    exec /bin/rm $cFile [file rootname $cFile].o
233}
Note: See TracBrowser for help on using the repository browser.