summaryrefslogtreecommitdiffstats
path: root/library/ldAout.tcl
blob: 11d301e193e1e1819f02954fc976fc116452f831 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
# ldAout.tcl --
#
#	This "tclldAout" procedure in this script acts as a replacement
#	for the "ld" command when linking an object file that will be
#	loaded dynamically into Tcl or Tk using pseudo-static linking.
#
# Parameters:
#	The arguments to the script are the command line options for
#	an "ld" command.
#
# Results:
#	The "ld" command is parsed, and the "-o" option determines the
#	module name.  ".a" and ".o" options are accumulated.
#	The input archives and object files are examined with the "nm"
#	command to determine whether the modules initialization
#	entry and safe initialization entry are present.  A trivial
#	C function that locates the entries is composed, compiled, and
#	its .o file placed before all others in the command; then
#	"ld" is executed to bind the objects together.
#
# RCS: @(#) $Id: ldAout.tcl,v 1.2 1998/09/14 18:40:03 stanton Exp $
#
# Copyright (c) 1995, by General Electric Company. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# This work was supported in part by the ARPA Manufacturing Automation
# and Design Engineering (MADE) Initiative through ARPA contract
# F33615-94-C-4400.

proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
  global env
  global argv

  if {$cc==""} {
    set cc $env(CC)
  }

  # if only two parameters are supplied there is assumed that the
  # only shlib_suffix is missing. This parameter is anyway available
  # as "info sharedlibextension" too, so there is no need to transfer
  # 3 parameters to the function tclLdAout. For compatibility, this
  # function now accepts both 2 and 3 parameters.

  if {$shlib_suffix==""} {
    set shlib_cflags $env(SHLIB_CFLAGS)
  } else {
    if {$shlib_cflags=="none"} {
      set shlib_cflags $shlib_suffix
    }
  }

  # seenDotO is nonzero if a .o or .a file has been seen

  set seenDotO 0

  # minusO is nonzero if the last command line argument was "-o".

  set minusO 0

  # head has command line arguments up to but not including the first
  # .o or .a file. tail has the rest of the arguments.

  set head {}
  set tail {}

  # nmCommand is the "nm" command that lists global symbols from the
  # object files.

  set nmCommand {|nm -g}

  # entryProtos is the table of _Init and _SafeInit prototypes found in the
  # module.

  set entryProtos {}

  # entryPoints is the table of _Init and _SafeInit entries found in the
  # module.

  set entryPoints {}

  # libraries is the list of -L and -l flags to the linker.

  set libraries {}
  set libdirs {}

  # Process command line arguments

  foreach a $argv {
    if {!$minusO && [regexp {\.[ao]$} $a]} {
      set seenDotO 1
      lappend nmCommand $a
    }
    if {$minusO} {
      set outputFile $a
      set minusO 0
    } elseif {![string compare $a -o]} {
      set minusO 1
    }
    if [regexp {^-[lL]} $a] {
	lappend libraries $a
	if [regexp {^-L} $a] {
	    lappend libdirs [string range $a 2 end]
	}
    } elseif {$seenDotO} {
	lappend tail $a
    } else {
	lappend head $a
    }
  }
  lappend libdirs /lib /usr/lib

  # MIPS -- If there are corresponding G0 libraries, replace the
  # ordinary ones with the G0 ones.

  set libs {}
  foreach lib $libraries {
      if [regexp {^-l} $lib] {
	  set lname [string range $lib 2 end]
	  foreach dir $libdirs {
	      if [file exists [file join $dir lib${lname}_G0.a]] {
		  set lname ${lname}_G0
		  break
	      }
	  }
	  lappend libs -l$lname
      } else {
	  lappend libs $lib
      }
  }
  set libraries $libs

  # Extract the module name from the "-o" option

  if {![info exists outputFile]} {
    error "-o option must be supplied to link a Tcl load module"
  }
  set m [file tail $outputFile]
  if [regexp {\.a$} $outputFile] {
    set shlib_suffix .a
  } else {
    set shlib_suffix ""
  }
  if [regexp {\..*$} $outputFile match] {
    set l [expr [string length $m] - [string length $match]]
  } else {
    error "Output file does not appear to have a suffix"
  }
  set modName [string tolower [string range $m 0 [expr $l-1]]]
  if [regexp {^lib} $modName] {
    set modName [string range $modName 3 end]
  }
  if [regexp {[0-9\.]*(_g0)?$} $modName match] {
    set modName [string range $modName 0 [expr [string length $modName]-[string length $match]-1]]
  }
  set modName "[string toupper [string index $modName 0]][string range $modName 1 end]"
  
  # Catalog initialization entry points found in the module

  set f [open $nmCommand r]
  while {[gets $f l] >= 0} {
    if [regexp {T[ 	]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol] {
      if {![regexp {_?([A-Z][a-z0-9_]*_(Safe)?Init)} $symbol trash s]} {
	set s $symbol
      }
      append entryProtos {extern int } $symbol { (); } \n
      append entryPoints {  } \{ { "} $s {", } $symbol { } \} , \n
    }
  }
  close $f

  if {$entryPoints==""} {
    error "No entry point found in objects"
  }

  # Compose a C function that resolves the initialization entry points and
  # embeds the required libraries in the object code.

  set C {#include <string.h>}
  append C \n
  append C {char TclLoadLibraries_} $modName { [] =} \n
  append C {  "@LIBS: } $libraries {";} \n
  append C $entryProtos
  append C {static struct } \{ \n
  append C {  char * name;} \n
  append C {  int (*value)();} \n
  append C \} {dictionary [] = } \{ \n
  append C $entryPoints
  append C {  0, 0 } \n \} \; \n
  append C {typedef struct Tcl_Interp Tcl_Interp;} \n
  append C {typedef int Tcl_PackageInitProc (Tcl_Interp *);} \n
  append C {Tcl_PackageInitProc *} \n
  append C TclLoadDictionary_ $modName { (symbol)} \n
  append C {    char * symbol;} \n
  append C {{
    int i;
    for (i = 0; dictionary [i] . name != 0; ++i) {
      if (!strcmp (symbol, dictionary [i] . name)) {
	return dictionary [i].value;
      }
    }
    return 0;
}} \n

  # Write the C module and compile it

  set cFile tcl$modName.c
  set f [open $cFile w]
  puts -nonewline $f $C
  close $f
  set ccCommand "$cc -c $shlib_cflags $cFile"
  puts stderr $ccCommand
  eval exec $ccCommand

  # Now compose and execute the ld command that packages the module

  if {$shlib_suffix == ".a"} {
    set ldCommand "ar cr $outputFile"
    regsub { -o} $tail {} tail
  } else {
  set ldCommand ld
  foreach item $head {
    lappend ldCommand $item
  }
  }
  lappend ldCommand tcl$modName.o
  foreach item $tail {
    lappend ldCommand $item
  }
  puts stderr $ldCommand
  eval exec $ldCommand
  if {$shlib_suffix == ".a"} {
    exec ranlib $outputFile
  }

  # Clean up working files

  exec /bin/rm $cFile [file rootname $cFile].o
}