Check-in [1a7d494008]
Overview
Comment:Added a command called "code" to get the generated code
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 1a7d494008f59c433c1303970742640f7a57673e
User & Date: rkeene on 2014-06-18 19:46:13
Other Links: manifest | tags
Context
2014-06-18
19:50
Added new API tests check-in: 2a9dcf9840 user: rkeene tags: trunk
19:46
Added a command called "code" to get the generated code check-in: 1a7d494008 user: rkeene tags: trunk
19:04
Updated to use pointerSize to determine 32/64-bit library paths so that i386 code can be emitted when running a 32-bit Tcl on a 64-bit box check-in: 0d7d9afa0a user: rkeene tags: trunk
Changes

Modified tcc4tcl.tcl from [9e249ac45d] to [602c05c493].

    31     31   			}
    32     32   		}
    33     33   
    34     34   		array set $handle [list tcc $tcc_handle code "" type $type filename $output package $pkgName]
    35     35   
    36     36   		proc $handle {cmd args} [string map [list @@HANDLE@@ $handle] {
    37     37   			set handle {@@HANDLE@@}
           38  +			if {$cmd == "go"} {
           39  +				set args [list 0 {*}$args]
           40  +			}
           41  +
           42  +			if {$cmd == "code"} {
           43  +				set cmd "go"
           44  +				set args [list 1 {*}$args]
           45  +			}
           46  +
    38     47   			uplevel 1 [list ::tcc4tcl::_$cmd $handle {*}$args]
    39     48   		}]
    40     49   
    41     50   		return $handle
    42     51   	}
    43     52   
    44     53   	proc _cproc {handle name adefs rtype {body "#"}} {
................................................................................
    55     64   
    56     65   		lappend state(procs) $name $tclname
    57     66   	}
    58     67   
    59     68   	proc _ccode {handle code} {
    60     69   		upvar #0 $handle state
    61     70   
    62         -		append state(code) $code
           71  +		append state(code) $code "\n"
    63     72   	}
    64     73   
    65     74   	proc _tk {handle} {
    66     75   		upvar #0 $handle state
    67     76   
    68     77   		set state(tk) 1
    69     78   	}
    70     79   
    71         -	proc _go {handle} {
           80  +	proc _go {handle {outputOnly 0}} {
    72     81   		variable dir
    73     82   
    74     83   		upvar #0 $handle state
           84  +
           85  +		set code $state(code)
    75     86   
    76     87   		if {[info exists state(tk)]} {
    77         -			set state(code) "#include <tk.h>\n$state(code)"
           88  +			set code "#include <tk.h>\n$code"
    78     89   		}
    79         -		set state(code) "#include <tcl.h>\n\n$state(code)"
           90  +		set code "#include <tcl.h>\n\n$code"
    80     91   
    81     92   		# Append additional generated code to support the output type
    82     93   		switch -- $state(type) {
    83     94   			"memory" {
    84     95   				# No additional code needed
           96  +				if {$outputOnly} {
           97  +					if {[info exists state(procs)] && [llength $state(procs)] > 0} {
           98  +						foreach {procname cname} $state(procs) {
           99  +							append code "/* Immediate: Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL); */\n"
          100  +						}
          101  +					}
          102  +				}
    85    103   			}
    86    104   			"exe" - "dll" {
    87    105   				if {[info exists state(procs)] && [llength $state(procs)] > 0} {
    88         -					append state(code) "int _initProcs(Tcl_Interp *interp) \{\n"
          106  +					append code "int _initProcs(Tcl_Interp *interp) \{\n"
    89    107   					
    90    108   					foreach {procname cname} $state(procs) {
    91         -						append state(code) "  Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL);"
          109  +						append code "  Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL);\n"
    92    110   					}
    93    111   
    94         -					append state(code) "\}"
          112  +					append code "\}"
    95    113   				}
    96    114   			}
    97    115   			"package" {
    98    116   				set packageName [lindex $state(package) 0]
    99    117   				set packageVersion [lindex $state(package) 1]
   100    118   				if {$packageVersion == ""} {
   101    119   					set packageVersion "0"
   102    120   				}
   103    121   
   104         -				append state(code) "int [string totitle $packageName]_Init(Tcl_Interp *interp) \{\n"
   105         -				append state(code) "#ifdef USE_TCL_STUBS\n"
   106         -				append state(code) "  if (Tcl_InitStubs(interp, \"8.4\" , 0) == 0L) \{\n"
   107         -				append state(code) "    return TCL_ERROR;\n"
   108         -				append state(code) "  \}\n"
   109         -				append state(code) "#endif\n"
          122  +				append code "int [string totitle $packageName]_Init(Tcl_Interp *interp) \{\n"
          123  +				append code "#ifdef USE_TCL_STUBS\n"
          124  +				append code "  if (Tcl_InitStubs(interp, \"8.4\" , 0) == 0L) \{\n"
          125  +				append code "    return TCL_ERROR;\n"
          126  +				append code "  \}\n"
          127  +				append code "#endif\n"
   110    128   
   111    129   				if {[info exists state(procs)] && [llength $state(procs)] > 0} {
   112    130   					foreach {procname cname} $state(procs) {
   113         -						append state(code) "  Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL);"
          131  +						append code "  Tcl_CreateObjCommand(interp, \"$procname\", $cname, NULL, NULL);\n"
   114    132   					}
   115    133   				}
   116    134   
   117         -				append state(code) "Tcl_PkgProvide(interp, \"$packageName\", \"$packageVersion\");\n"
   118         -				append state(code) "  return(TCL_OK);\n"
   119         -				append state(code) "\}"
          135  +				append code "  Tcl_PkgProvide(interp, \"$packageName\", \"$packageVersion\");\n"
          136  +				append code "  return(TCL_OK);\n"
          137  +				append code "\}"
   120    138   			}
   121    139   		}
          140  +
          141  +		if {$outputOnly} {
          142  +			return $code
          143  +		}
   122    144   
   123    145   		# Generate output code
   124    146   		switch -- $state(type) {
   125    147   			"package" {
   126    148   				set tcc_type "dll"
   127    149   			}
   128    150   			default {
   129    151   				set tcc_type $state(type)
   130    152   			}
   131    153   		}
          154  +
   132    155   		tcc4tcl $dir $tcc_type tcc
   133    156   
   134    157   		switch -- $state(type) {
   135    158   			"memory" {
   136         -				tcc compile $state(code)
          159  +				tcc compile $code
   137    160   
   138         -				foreach {procname cname} $state(procs) {
   139         -					tcc command $procname $cname
          161  +				if {[info exists state(procs)] && [llength $state(procs)] > 0} {
          162  +					foreach {procname cname} $state(procs) {
          163  +						tcc command $procname $cname
          164  +					}
   140    165   				}
   141    166   			}
   142    167   
   143    168   			"package" - "dll" - "exe" {
   144    169   				switch -glob -- $::tcl_platform(os)-$::tcl_platform(pointerSize) {
   145    170   					"Linux-8" {
   146    171   						tcc add_library_path "/lib64"
   147    172   						tcc add_library_path "/usr/lib64"
   148    173   						tcc add_library_path "/lib"
   149    174   						tcc add_library_path "/usr/lib"
   150    175   					}
          176  +					"SunOS-8" {
          177  +						tcc add_library_path "/lib/64"
          178  +						tcc add_library_path "/usr/lib/64"
          179  +						tcc add_library_path "/lib"
          180  +						tcc add_library_path "/usr/lib"
          181  +					}
   151    182   					"Linux-*" {
   152    183   						tcc add_library_path "/lib32"
   153    184   						tcc add_library_path "/usr/lib32"
   154    185   						tcc add_library_path "/lib"
   155    186   						tcc add_library_path "/usr/lib"
   156    187   					}
   157    188   					default {
................................................................................
   158    189   						if {$::tcl_platform(platform) == "unix"} {
   159    190   							tcc add_library_path "/lib"
   160    191   							tcc add_library_path "/usr/lib"
   161    192   						}
   162    193   					}
   163    194   				}
   164    195   
   165         -				tcc compile $state(code)
          196  +				tcc compile $code
   166    197   
   167    198   				tcc output_file $state(filename)
   168    199   			}
   169    200   		}
   170    201   
   171    202   		# Cleanup
   172    203   		rename $handle ""