path: root/library/ldAout.tcl

# 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
}