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# SCCS: @(#) ldAout.tcl 1.11 96/09/17 09:02:20
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#
32# modified 12/19/1996 by Andreas Kupries (a.kupries@westend.com) /aku/
33# to allow usage for arbitrary libraries
34
35
36proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
37  global env
38  global argv
39
40  if {$cc==""} {
41    set cc $env(CC)
42  }
43
44  # if only two parameters are supplied there is assumed that the
45  # only shlib_suffix is missing. This parameter is anyway available
46  # as "info sharedlibextension" too, so there is no need to transfer
47  # 3 parameters to the function tclLdAout. For compatibility, this
48  # function now accepts both 2 and 3 parameters.
49
50  if {$shlib_suffix==""} {
51    set shlib_cflags $env(SHLIB_CFLAGS)
52  } else {
53    if {$shlib_cflags=="none"} {
54      set shlib_cflags $shlib_suffix
55    }
56  }
57
58  # seenDotO is nonzero if a .o or .a file has been seen
59
60  set seenDotO 0
61
62  # minusO is nonzero if the last command line argument was "-o".
63
64  set minusO 0
65
66  # head has command line arguments up to but not including the first
67  # .o or .a file. tail has the rest of the arguments.
68
69  set head {}
70  set tail {}
71
72  # nmCommand is the "nm" command that lists global symbols from the
73  # object files.
74
75  set nmCommand {|nm -g}
76
77  # entryProtos is the table of prototypes found in the
78  # module.
79
80  set entryProtos {}
81
82  # entryPoints is the table of entries found in the
83  # module.
84
85  set entryPoints {}
86
87  # libraries is the list of -L and -l flags to the linker.
88
89  set libraries {}
90  set libdirs {}
91
92  # Process command line arguments
93
94  foreach a $argv {
95    if {!$minusO && [regexp {\.[ao]$} $a]} {
96      set seenDotO 1
97      lappend nmCommand $a
98    }
99    if {$minusO} {
100      set outputFile $a
101      set minusO 0
102    } elseif {![string compare $a -o]} {
103      set minusO 1
104    }
105    if [regexp {^-[lL]} $a] {
106	lappend libraries $a
107	if [regexp {^-L} $a] {
108	    lappend libdirs [string range $a 2 end]
109	}
110    } elseif {$seenDotO} {
111	lappend tail $a
112    } else {
113	lappend head $a
114    }
115  }
116  lappend libdirs /lib /usr/lib
117
118  # MIPS -- If there are corresponding G0 libraries, replace the
119  # ordinary ones with the G0 ones.
120
121  set libs {}
122  foreach lib $libraries {
123      if [regexp {^-l} $lib] {
124	  set lname [string range $lib 2 end]
125	  foreach dir $libdirs {
126	      if [file exists [file join $dir lib${lname}_G0.a]] {
127		  set lname ${lname}_G0
128		  break
129	      }
130	  }
131	  lappend libs -l$lname
132      } else {
133	  lappend libs $lib
134      }
135  }
136  set libraries $libs
137
138  # Extract the module name from the "-o" option
139
140  if {![info exists outputFile]} {
141    error "-o option must be supplied to link a Tcl load module"
142  }
143  set m [file tail $outputFile]
144  if [regexp {\.a$} $outputFile] {
145    set shlib_suffix .a
146  } else {
147    set shlib_suffix ""
148  }
149  if [regexp {\..*$} $outputFile match] {
150      set l [expr {[string length $m] - [string length $match]}]
151  } else {
152      error "Output file does not appear to have a suffix"
153  }
154  set modName [string tolower [string range $m 0 [expr {$l-1}]]]
155  if [regexp {^lib} $modName] {
156    set modName [string range $modName 3 end]
157  }
158  if [regexp {[0-9\.]*(_g0)?$} $modName match] {
159      set modName [string range $modName 0 [expr {[string length $modName]-[string length $match]-1}]]
160  }
161  set modName "[string toupper [string index $modName 0]][string range $modName 1 end]"
162
163  # Catalog initialization entry points found in the module
164  # /aku/ use ALL globals, not only XX_(Safe)?Init
165
166  set f [open $nmCommand r]
167  while {[gets $f l] >= 0} {
168    if [regexp {[0-9A-Fa-f]+ T[ 	]*([a-zA-Z0-9_]*)} $l trash symbol] {
169      append entryProtos {extern int } $symbol { (); } \n
170      append entryPoints {  } \{ { "} $symbol {", } $symbol { } \} , \n
171    }
172  }
173  close $f
174
175  if {$entryPoints==""} {
176    error "No entry point found in objects"
177  }
178
179  # Compose a C function that resolves the entry points and
180  # embeds the required libraries in the object code.
181
182  set C {#include <string.h>}
183  append C \n
184  append C {char TclLoadLibraries_} $modName { [] =} \n
185  append C {  "@LIBS: } $libraries {";} \n
186  append C $entryProtos
187  append C {static struct } \{ \n
188  append C {  char * name;} \n
189  append C {  int (*value)();} \n
190  append C \} {dictionary [] = } \{ \n
191  append C $entryPoints
192  append C \{  0, 0 \} \n \} \; \n
193  append C {typedef struct Tcl_Interp Tcl_Interp;} \n
194  append C {typedef int Tcl_PackageInitProc (Tcl_Interp *);} \n
195  append C {Tcl_PackageInitProc *} \n
196  append C TclLoadDictionary_ $modName { (symbol)} \n
197  append C {    char * symbol;} \n
198  append C {{
199    int i;
200    for (i = 0; dictionary [i] . name != 0; ++i) {
201      if (!strcmp (symbol, dictionary [i] . name)) {
202	return dictionary [i].value;
203      }
204    }
205    return 0;
206}} \n
207
208  # Write the C module and compile it
209
210  set cFile tcl$modName.c
211  set f [open $cFile w]
212  puts -nonewline $f $C
213  close $f
214  set ccCommand "$cc -c $shlib_cflags $cFile"
215  puts stderr $ccCommand
216  eval exec $ccCommand
217
218  # Now compose and execute the ld command that packages the module
219
220  if {$shlib_suffix == ".a"} {
221    set ldCommand "ar cr $outputFile"
222    regsub { -o} $tail {} tail
223  } else {
224  set ldCommand ld
225  foreach item $head {
226    lappend ldCommand $item
227  }
228  }
229  lappend ldCommand tcl$modName.o
230  foreach item $tail {
231    lappend ldCommand $item
232  }
233  puts stderr $ldCommand
234  if [catch "exec $ldCommand" msg] {
235    puts stderr $msg
236  }
237  if {$shlib_suffix == ".a"} {
238    exec ranlib $outputFile
239  }
240
241  # Clean up working files
242
243  exec /bin/rm $cFile [file rootname $cFile].o
244}
245