Hex Artifact Content

Artifact 356b248a0ae7a2dfa118539a56b1b0026442458a:


0000: 23 20 74 63 63 2e 74 63 6c 20 2d 20 6c 69 62 72  # tcc.tcl - libr
0010: 61 72 79 20 72 6f 75 74 69 6e 65 73 20 66 6f 72  ary routines for
0020: 20 74 68 65 20 74 63 63 20 77 72 61 70 70 65 72   the tcc wrapper
0030: 20 28 4d 61 72 6b 20 4a 61 6e 73 73 65 6e 29 0a   (Mark Janssen).
0040: 0a 6e 61 6d 65 73 70 61 63 65 20 65 76 61 6c 20  .namespace eval 
0050: 74 63 63 34 74 63 6c 20 7b 0a 20 20 20 76 61 72  tcc4tcl {.   var
0060: 69 61 62 6c 65 20 64 69 72 20 0a 20 20 20 76 61  iable dir .   va
0070: 72 69 61 62 6c 65 20 6c 69 62 73 0a 20 20 20 76  riable libs.   v
0080: 61 72 69 61 62 6c 65 20 69 6e 63 6c 75 64 65 73  ariable includes
0090: 0a 20 20 20 76 61 72 69 61 62 6c 65 20 63 6f 75  .   variable cou
00a0: 6e 74 0a 20 20 20 76 61 72 69 61 62 6c 65 20 63  nt.   variable c
00b0: 6f 6d 6d 61 6e 64 5f 63 6f 75 6e 74 0a 20 20 20  ommand_count.   
00c0: 76 61 72 69 61 62 6c 65 20 63 6f 6d 6d 61 6e 64  variable command
00d0: 73 0a 0a 20 20 20 73 65 74 20 64 69 72 20 5b 66  s..   set dir [f
00e0: 69 6c 65 20 64 69 72 6e 61 6d 65 20 5b 69 6e 66  ile dirname [inf
00f0: 6f 20 73 63 72 69 70 74 5d 5d 0a 20 20 20 69 66  o script]].   if
0100: 20 7b 5b 69 6e 66 6f 20 63 6f 6d 6d 61 6e 64 20   {[info command 
0110: 3a 3a 74 63 63 34 74 63 6c 5d 20 3d 3d 20 22 22  ::tcc4tcl] == ""
0120: 7d 20 7b 0a 20 20 20 20 20 20 63 61 74 63 68 20  } {.      catch 
0130: 7b 20 6c 6f 61 64 20 7b 7d 20 74 63 63 34 74 63  { load {} tcc4tc
0140: 6c 20 7d 0a 20 20 20 7d 0a 20 20 20 69 66 20 7b  l }.   }.   if {
0150: 5b 69 6e 66 6f 20 63 6f 6d 6d 61 6e 64 20 3a 3a  [info command ::
0160: 74 63 63 34 74 63 6c 5d 20 3d 3d 20 22 22 7d 20  tcc4tcl] == ""} 
0170: 7b 0a 20 20 20 20 20 20 20 6c 6f 61 64 20 5b 66  {.       load [f
0180: 69 6c 65 20 6a 6f 69 6e 20 24 64 69 72 20 74 63  ile join $dir tc
0190: 6c 74 63 63 5b 69 6e 66 6f 20 73 68 61 72 65 64  ltcc[info shared
01a0: 6c 69 62 65 78 74 65 6e 73 69 6f 6e 5d 5d 20 74  libextension]] t
01b0: 63 63 34 74 63 6c 0a 20 20 20 7d 0a 20 20 20 73  cc4tcl.   }.   s
01c0: 65 74 20 6c 69 62 73 20 24 64 69 72 2f 6c 69 62  et libs $dir/lib
01d0: 0a 20 20 20 73 65 74 20 69 6e 63 6c 75 64 65 73  .   set includes
01e0: 20 24 64 69 72 2f 69 6e 63 6c 75 64 65 0a 20 20   $dir/include.  
01f0: 20 73 65 74 20 63 6f 75 6e 74 20 30 0a 20 20 20   set count 0.   
0200: 73 65 74 20 63 6f 6d 6d 61 6e 64 5f 63 6f 75 6e  set command_coun
0210: 74 20 30 0a 20 20 20 61 72 72 61 79 20 73 65 74  t 0.   array set
0220: 20 63 6f 6d 6d 61 6e 64 73 20 7b 7d 0a 20 20 20   commands {}.   
0230: 70 72 6f 63 20 6e 65 77 20 7b 7d 20 7b 0a 20 20  proc new {} {.  
0240: 20 20 20 20 20 76 61 72 69 61 62 6c 65 20 64 69       variable di
0250: 72 0a 20 20 20 20 20 20 20 76 61 72 69 61 62 6c  r.       variabl
0260: 65 20 63 6f 75 6e 74 0a 20 20 20 20 20 20 20 73  e count.       s
0270: 65 74 20 68 61 6e 64 6c 65 20 74 63 63 5f 5b 69  et handle tcc_[i
0280: 6e 63 72 20 63 6f 75 6e 74 5d 0a 20 20 20 20 20  ncr count].     
0290: 20 20 74 63 63 34 74 63 6c 20 24 64 69 72 20 24    tcc4tcl $dir $
02a0: 68 61 6e 64 6c 65 0a 20 20 20 20 20 20 20 72 65  handle.       re
02b0: 74 75 72 6e 20 74 63 63 5f 24 63 6f 75 6e 74 0a  turn tcc_$count.
02c0: 20 20 20 7d 0a 20 20 20 70 72 6f 63 20 74 63 6c     }.   proc tcl
02d0: 63 6f 6d 6d 61 6e 64 20 7b 68 61 6e 64 6c 65 20  command {handle 
02e0: 6e 61 6d 65 20 63 63 6f 64 65 7d 20 7b 0a 20 20  name ccode} {.  
02f0: 20 20 20 20 20 76 61 72 69 61 62 6c 65 20 63 6f       variable co
0300: 6d 6d 61 6e 64 73 0a 20 20 20 20 20 20 20 76 61  mmands.       va
0310: 72 69 61 62 6c 65 20 63 6f 6d 6d 61 6e 64 5f 63  riable command_c
0320: 6f 75 6e 74 0a 20 20 20 20 20 20 20 73 65 74 20  ount.       set 
0330: 63 6e 61 6d 65 20 5f 74 63 63 5f 74 63 6c 5f 63  cname _tcc_tcl_c
0340: 6f 6d 6d 61 6e 64 5f 5b 69 6e 63 72 20 63 6f 6d  ommand_[incr com
0350: 6d 61 6e 64 5f 63 6f 75 6e 74 5d 0a 20 20 20 20  mand_count].    
0360: 20 20 20 73 65 74 20 63 6f 64 65 20 20 20 20 7b     set code    {
0370: 23 69 6e 63 6c 75 64 65 20 22 74 63 6c 2e 68 22  #include "tcl.h"
0380: 7d 0a 20 20 20 20 20 20 20 61 70 70 65 6e 64 20  }.       append 
0390: 63 6f 64 65 20 22 5c 6e 20 69 6e 74 20 24 63 6e  code "\n int $cn
03a0: 61 6d 65 22 0a 20 20 20 20 20 20 20 61 70 70 65  ame".       appe
03b0: 6e 64 20 63 6f 64 65 20 22 28 43 6c 69 65 6e 74  nd code "(Client
03c0: 44 61 74 61 20 63 64 61 74 61 2c 54 63 6c 5f 49  Data cdata,Tcl_I
03d0: 6e 74 65 72 70 20 2a 69 6e 74 65 72 70 2c 69 6e  nterp *interp,in
03e0: 74 20 6f 62 6a 63 2c 54 63 6c 5f 4f 62 6a 2a 20  t objc,Tcl_Obj* 
03f0: 43 4f 4e 53 54 20 6f 62 6a 76 5b 5d 29 7b 22 0a  CONST objv[]){".
0400: 20 20 20 20 20 20 20 61 70 70 65 6e 64 20 63 6f         append co
0410: 64 65 20 22 5c 6e 24 63 63 6f 64 65 22 0a 20 20  de "\n$ccode".  
0420: 20 20 20 20 20 61 70 70 65 6e 64 20 63 6f 64 65       append code
0430: 20 22 7d 22 0a 20 20 20 20 20 20 20 24 68 61 6e   "}".       $han
0440: 64 6c 65 20 63 6f 6d 70 69 6c 65 20 24 63 6f 64  dle compile $cod
0450: 65 0a 20 20 20 20 20 20 20 73 65 74 20 63 6f 6d  e.       set com
0460: 6d 61 6e 64 73 28 24 68 61 6e 64 6c 65 2c 24 6e  mands($handle,$n
0470: 61 6d 65 29 20 24 63 6e 61 6d 65 0a 20 20 20 20  ame) $cname.    
0480: 20 20 20 72 65 74 75 72 6e 0a 20 20 20 7d 0a 20     return.   }. 
0490: 20 20 70 72 6f 63 20 63 6f 6d 70 69 6c 65 20 7b    proc compile {
04a0: 68 61 6e 64 6c 65 7d 20 7b 0a 20 20 20 20 20 20  handle} {.      
04b0: 20 76 61 72 69 61 62 6c 65 20 63 6f 6d 6d 61 6e   variable comman
04c0: 64 73 0a 20 20 20 20 20 20 20 66 6f 72 65 61 63  ds.       foreac
04d0: 68 20 63 6d 64 20 5b 61 72 72 61 79 20 6e 61 6d  h cmd [array nam
04e0: 65 73 20 63 6f 6d 6d 61 6e 64 73 20 24 68 61 6e  es commands $han
04f0: 64 6c 65 2a 5d 20 7b 0a 20 20 20 20 20 20 20 20  dle*] {.        
0500: 20 20 20 70 75 74 73 20 24 63 6d 64 0a 20 20 20     puts $cmd.   
0510: 20 20 20 20 20 20 20 20 70 75 74 73 20 24 63 6f          puts $co
0520: 6d 6d 61 6e 64 73 28 24 63 6d 64 29 0a 20 20 20  mmands($cmd).   
0530: 20 20 20 20 20 20 20 20 73 65 74 20 63 6e 61 6d          set cnam
0540: 65 20 24 63 6f 6d 6d 61 6e 64 73 28 24 63 6d 64  e $commands($cmd
0550: 29 0a 20 20 20 20 20 20 20 20 20 20 20 73 65 74  ).           set
0560: 20 74 63 6c 63 6f 6d 6d 61 6e 64 20 5b 6a 6f 69   tclcommand [joi
0570: 6e 20 5b 6c 72 61 6e 67 65 20 5b 73 70 6c 69 74  n [lrange [split
0580: 20 24 63 6d 64 20 2c 5d 20 31 20 65 6e 64 5d 20   $cmd ,] 1 end] 
0590: 7b 7d 5d 0a 20 20 20 20 20 20 20 20 20 20 20 73  {}].           s
05a0: 65 74 20 68 61 6e 64 6c 65 20 5b 6c 69 6e 64 65  et handle [linde
05b0: 78 20 5b 73 70 6c 69 74 20 24 63 6d 64 20 2c 5d  x [split $cmd ,]
05c0: 20 30 5d 0a 20 20 20 20 20 20 20 20 20 20 20 24   0].           $
05d0: 68 61 6e 64 6c 65 20 63 6f 6d 6d 61 6e 64 20 24  handle command $
05e0: 74 63 6c 63 6f 6d 6d 61 6e 64 20 24 63 6e 61 6d  tclcommand $cnam
05f0: 65 0a 20 20 20 20 20 20 20 20 7d 0a 20 20 20 20  e.        }.    
0600: 20 20 20 72 65 74 75 72 6e 0a 20 20 20 7d 0a 7d     return.   }.}
0610: 0a 70 72 6f 63 20 74 63 63 34 74 63 6c 3a 3a 74  .proc tcc4tcl::t
0620: 6f 5f 64 6c 6c 20 7b 63 6f 64 65 20 64 6c 6c 20  o_dll {code dll 
0630: 7b 6c 69 62 73 20 7b 7d 7d 7d 20 7b 0a 20 20 20  {libs {}}} {.   
0640: 20 74 63 63 34 74 63 6c 20 24 3a 3a 74 63 63 34   tcc4tcl $::tcc4
0650: 74 63 6c 3a 3a 64 69 72 20 64 6c 6c 20 74 63 63  tcl::dir dll tcc
0660: 5f 31 0a 20 20 20 20 74 63 63 5f 31 20 61 64 64  _1.    tcc_1 add
0670: 5f 6c 69 62 72 61 72 79 20 74 63 6c 38 2e 35 20  _library tcl8.5 
0680: 0a 20 20 20 20 74 63 63 5f 31 20 61 64 64 5f 6c  .    tcc_1 add_l
0690: 69 62 72 61 72 79 5f 70 61 74 68 20 2e 0a 20 20  ibrary_path ..  
06a0: 20 20 66 6f 72 65 61 63 68 20 6c 69 62 20 24 6c    foreach lib $l
06b0: 69 62 73 20 7b 74 63 63 5f 31 20 61 64 64 5f 6c  ibs {tcc_1 add_l
06c0: 69 62 72 61 72 79 20 24 6c 69 62 7d 0a 20 20 20  ibrary $lib}.   
06d0: 20 69 66 20 7b 24 3a 3a 74 63 6c 5f 70 6c 61 74   if {$::tcl_plat
06e0: 66 6f 72 6d 28 70 6c 61 74 66 6f 72 6d 29 20 65  form(platform) e
06f0: 71 20 22 77 69 6e 64 6f 77 73 22 7d 20 7b 0a 20  q "windows"} {. 
0700: 20 20 20 20 20 20 20 74 63 63 5f 31 20 64 65 66         tcc_1 def
0710: 69 6e 65 20 44 4c 4c 5f 45 58 50 4f 52 54 20 7b  ine DLL_EXPORT {
0720: 5f 5f 64 65 63 6c 73 70 65 63 28 64 6c 6c 65 78  __declspec(dllex
0730: 70 6f 72 74 29 7d 20 0a 20 20 20 20 20 20 20 20  port)} .        
0740: 73 65 74 20 66 20 5b 6f 70 65 6e 20 24 3a 3a 74  set f [open $::t
0750: 63 63 34 74 63 6c 3a 3a 64 69 72 2f 63 2f 64 6c  cc4tcl::dir/c/dl
0760: 6c 63 72 74 31 2e 63 5d 0a 20 20 20 20 20 20 20  lcrt1.c].       
0770: 20 74 63 63 5f 31 20 63 6f 6d 70 69 6c 65 20 5b   tcc_1 compile [
0780: 72 65 61 64 20 24 66 5d 0a 20 20 20 20 20 20 20  read $f].       
0790: 20 63 6c 6f 73 65 20 24 66 0a 20 20 20 20 20 20   close $f.      
07a0: 20 20 73 65 74 20 66 20 5b 6f 70 65 6e 20 24 3a    set f [open $:
07b0: 3a 74 63 63 34 74 63 6c 3a 3a 64 69 72 2f 63 2f  :tcc4tcl::dir/c/
07c0: 64 6c 6c 6d 61 69 6e 2e 63 5d 0a 20 20 20 20 20  dllmain.c].     
07d0: 20 20 20 74 63 63 5f 31 20 63 6f 6d 70 69 6c 65     tcc_1 compile
07e0: 20 5b 72 65 61 64 20 24 66 5d 0a 20 20 20 20 20   [read $f].     
07f0: 20 20 20 63 6c 6f 73 65 20 24 66 0a 20 20 20 20     close $f.    
0800: 7d 20 65 6c 73 65 20 7b 0a 20 20 20 20 20 20 20  } else {.       
0810: 20 74 63 63 5f 31 20 64 65 66 69 6e 65 20 44 4c   tcc_1 define DL
0820: 4c 5f 45 58 50 4f 52 54 20 22 22 0a 20 20 20 20  L_EXPORT "".    
0830: 7d 0a 20 20 20 20 74 63 63 5f 31 20 63 6f 6d 70  }.    tcc_1 comp
0840: 69 6c 65 20 24 63 6f 64 65 0a 20 20 20 20 74 63  ile $code.    tc
0850: 63 5f 31 20 6f 75 74 70 75 74 5f 66 69 6c 65 20  c_1 output_file 
0860: 24 64 6c 6c 0a 20 20 20 20 72 65 6e 61 6d 65 20  $dll.    rename 
0870: 74 63 63 5f 31 20 7b 7d 0a 7d 0a 70 72 6f 63 20  tcc_1 {}.}.proc 
0880: 3a 3a 74 63 63 34 74 63 6c 3a 3a 4c 6f 67 20 7b  ::tcc4tcl::Log {
0890: 61 72 67 73 7d 20 7b 0a 20 20 23 20 70 75 74 73  args} {.  # puts
08a0: 20 24 61 72 67 73 0a 7d 0a 70 72 6f 63 20 3a 3a   $args.}.proc ::
08b0: 74 63 63 34 74 63 6c 3a 3a 72 65 73 65 74 20 7b  tcc4tcl::reset {
08c0: 7d 20 7b 0a 20 20 76 61 72 69 61 62 6c 65 20 74  } {.  variable t
08d0: 63 63 0a 20 20 73 65 74 20 74 63 63 28 63 6f 64  cc.  set tcc(cod
08e0: 65 29 20 20 20 22 22 0a 20 20 73 65 74 20 74 63  e)   "".  set tc
08f0: 63 28 63 66 69 6c 65 73 29 20 5b 6c 69 73 74 5d  c(cfiles) [list]
0900: 0a 20 20 73 65 74 20 74 63 63 28 74 6b 29 20 30  .  set tcc(tk) 0
0910: 0a 7d 0a 23 20 43 75 73 74 6f 6d 20 68 65 6c 70  .}.# Custom help
0920: 65 72 73 0a 70 72 6f 63 20 3a 3a 74 63 63 34 74  ers.proc ::tcc4t
0930: 63 6c 3a 3a 63 68 65 63 6b 6e 61 6d 65 20 7b 6e  cl::checkname {n
0940: 7d 20 7b 65 78 70 72 20 7b 5b 72 65 67 65 78 70  } {expr {[regexp
0950: 20 7b 5e 5b 61 2d 7a 41 2d 5a 30 2d 39 5f 5d 2b   {^[a-zA-Z0-9_]+
0960: 24 7d 20 24 6e 5d 20 3e 20 30 7d 7d 0a 70 72 6f  $} $n] > 0}}.pro
0970: 63 20 3a 3a 74 63 63 34 74 63 6c 3a 3a 63 6c 65  c ::tcc4tcl::cle
0980: 61 6e 6e 61 6d 65 20 7b 6e 7d 20 7b 72 65 67 73  anname {n} {regs
0990: 75 62 20 2d 61 6c 6c 20 7b 5b 5e 61 2d 7a 41 2d  ub -all {[^a-zA-
09a0: 5a 30 2d 39 5f 5d 2b 7d 20 24 6e 20 5f 7d 0a 0a  Z0-9_]+} $n _}..
09b0: 70 72 6f 63 20 3a 3a 74 63 63 34 74 63 6c 3a 3a  proc ::tcc4tcl::
09c0: 63 63 6f 64 65 20 7b 63 6f 64 65 7d 20 7b 0a 20  ccode {code} {. 
09d0: 20 76 61 72 69 61 62 6c 65 20 74 63 63 0a 20 20   variable tcc.  
09e0: 4c 6f 67 20 22 49 4e 4a 45 43 54 49 4e 47 20 43  Log "INJECTING C
09f0: 43 4f 44 45 22 0a 20 20 61 70 70 65 6e 64 20 74  CODE".  append t
0a00: 63 63 28 63 6f 64 65 29 20 24 63 6f 64 65 20 5c  cc(code) $code \
0a10: 6e 0a 7d 0a 70 72 6f 63 20 3a 3a 74 63 63 34 74  n.}.proc ::tcc4t
0a20: 63 6c 3a 3a 63 63 20 7b 63 6f 64 65 7d 20 7b 0a  cl::cc {code} {.
0a30: 20 20 76 61 72 69 61 62 6c 65 20 74 63 63 0a 20    variable tcc. 
0a40: 20 69 66 20 7b 21 5b 69 6e 66 6f 20 65 78 69 73   if {![info exis
0a50: 74 73 20 74 63 63 28 63 63 29 5d 7d 20 7b 0a 20  ts tcc(cc)]} {. 
0a60: 20 20 20 20 20 73 65 74 20 74 63 63 28 63 63 29       set tcc(cc)
0a70: 20 74 63 63 31 0a 20 20 20 20 20 20 74 63 63 34   tcc1.      tcc4
0a80: 74 63 6c 20 5b 66 69 6c 65 20 6a 6f 69 6e 20 24  tcl [file join $
0a90: 3a 3a 74 63 63 34 74 63 6c 3a 3a 64 69 72 20 6c  ::tcc4tcl::dir l
0aa0: 69 62 5d 20 24 74 63 63 28 63 63 29 0a 20 20 20  ib] $tcc(cc).   
0ab0: 20 20 20 24 74 63 63 28 63 63 29 20 61 64 64 5f     $tcc(cc) add_
0ac0: 6c 69 62 72 61 72 79 20 74 63 6c 38 2e 35 0a 20  library tcl8.5. 
0ad0: 20 20 20 20 20 24 74 63 63 28 63 63 29 20 61 64       $tcc(cc) ad
0ae0: 64 5f 69 6e 63 6c 75 64 65 5f 70 61 74 68 20 5b  d_include_path [
0af0: 66 69 6c 65 20 6a 6f 69 6e 20 24 3a 3a 74 63 63  file join $::tcc
0b00: 34 74 63 6c 3a 3a 64 69 72 20 69 6e 63 6c 75 64  4tcl::dir includ
0b10: 65 5d 0a 20 20 7d 0a 20 20 4c 6f 67 20 63 6f 64  e].  }.  Log cod
0b20: 65 3a 24 63 6f 64 65 0a 20 20 24 74 63 63 28 63  e:$code.  $tcc(c
0b30: 63 29 20 63 6f 6d 70 69 6c 65 20 24 63 6f 64 65  c) compile $code
0b40: 0a 7d 0a 23 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d  .}.#------------
0b50: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d  ----------------
0b60: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d  ----------------
0b70: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 20  --------------- 
0b80: 4e 65 77 20 44 4c 4c 20 41 50 49 0a 70 72 6f 63  New DLL API.proc
0b90: 20 3a 3a 74 63 63 34 74 63 6c 3a 3a 64 6c 6c 20   ::tcc4tcl::dll 
0ba0: 7b 7b 6e 61 6d 65 20 22 22 7d 7d 20 7b 0a 20 20  {{name ""}} {.  
0bb0: 20 20 76 61 72 69 61 62 6c 65 20 63 6f 75 6e 74    variable count
0bc0: 0a 20 20 20 20 69 66 20 7b 24 6e 61 6d 65 20 65  .    if {$name e
0bd0: 71 20 22 22 7d 20 7b 73 65 74 20 6e 61 6d 65 20  q ""} {set name 
0be0: 64 6c 6c 5b 69 6e 63 72 20 63 6f 75 6e 74 5d 7d  dll[incr count]}
0bf0: 0a 20 20 20 20 6e 61 6d 65 73 70 61 63 65 20 65  .    namespace e
0c00: 76 61 6c 20 3a 3a 74 63 63 34 74 63 6c 3a 3a 64  val ::tcc4tcl::d
0c10: 6c 6c 3a 3a 24 6e 61 6d 65 20 7b 0a 20 20 20 20  ll::$name {.    
0c20: 20 20 20 20 76 61 72 69 61 62 6c 65 20 63 6f 64      variable cod
0c30: 65 20 22 23 69 6e 63 6c 75 64 65 20 3c 74 63 6c  e "#include <tcl
0c40: 2e 68 3e 5c 6e 22 20 3b 23 20 61 6c 77 61 79 73  .h>\n" ;# always
0c50: 20 6e 65 65 64 65 64 0a 20 20 20 20 20 20 20 20   needed.        
0c60: 76 61 72 69 61 62 6c 65 20 63 6d 64 73 20 7b 7d  variable cmds {}
0c70: 0a 20 20 20 20 7d 0a 20 20 20 20 70 72 6f 63 20  .    }.    proc 
0c80: 3a 3a 24 6e 61 6d 65 20 7b 63 6d 64 20 61 72 67  ::$name {cmd arg
0c90: 73 7d 20 22 3a 3a 74 63 63 34 74 63 6c 3a 3a 64  s} "::tcc4tcl::d
0ca0: 6c 6c 3a 3a 5c 24 63 6d 64 20 24 6e 61 6d 65 20  ll::\$cmd $name 
0cb0: 5c 24 61 72 67 73 22 0a 20 20 20 20 72 65 74 75  \$args".    retu
0cc0: 72 6e 20 24 6e 61 6d 65 0a 7d 0a 6e 61 6d 65 73  rn $name.}.names
0cd0: 70 61 63 65 20 65 76 61 6c 20 3a 3a 74 63 63 34  pace eval ::tcc4
0ce0: 74 63 6c 3a 3a 64 6c 6c 20 7b 7d 0a 70 72 6f 63  tcl::dll {}.proc
0cf0: 20 3a 3a 74 63 63 34 74 63 6c 3a 3a 64 6c 6c 3a   ::tcc4tcl::dll:
0d00: 3a 63 63 6f 64 65 20 7b 6e 61 6d 65 20 61 72 67  :ccode {name arg
0d10: 6c 7d 20 7b 0a 20 20 20 20 61 70 70 65 6e 64 20  l} {.    append 
0d20: 24 7b 6e 61 6d 65 7d 3a 3a 63 6f 64 65 20 5c 6e  ${name}::code \n
0d30: 20 5b 6c 69 6e 64 65 78 20 24 61 72 67 6c 20 30   [lindex $argl 0
0d40: 5d 0a 20 20 20 20 72 65 74 75 72 6e 0a 7d 0a 70  ].    return.}.p
0d50: 72 6f 63 20 3a 3a 74 63 63 34 74 63 6c 3a 3a 64  roc ::tcc4tcl::d
0d60: 6c 6c 3a 3a 63 70 72 6f 63 20 7b 6e 61 6d 65 20  ll::cproc {name 
0d70: 61 72 67 6c 7d 20 7b 0a 20 20 20 20 66 6f 72 65  argl} {.    fore
0d80: 61 63 68 20 7b 70 6e 61 6d 65 20 70 61 72 67 73  ach {pname pargs
0d90: 20 72 74 79 70 65 20 62 6f 64 79 7d 20 24 61 72   rtype body} $ar
0da0: 67 6c 20 62 72 65 61 6b 0a 20 20 20 20 73 65 74  gl break.    set
0db0: 20 63 6f 64 65 20 5b 3a 3a 74 63 63 34 74 63 6c   code [::tcc4tcl
0dc0: 3a 3a 77 72 61 70 43 6d 64 20 24 70 6e 61 6d 65  ::wrapCmd $pname
0dd0: 20 24 70 61 72 67 73 20 24 72 74 79 70 65 20 63   $pargs $rtype c
0de0: 78 5f 24 70 6e 61 6d 65 20 24 62 6f 64 79 5d 0a  x_$pname $body].
0df0: 20 20 20 20 6c 61 70 70 65 6e 64 20 24 7b 6e 61      lappend ${na
0e00: 6d 65 7d 3a 3a 63 6d 64 73 20 24 70 6e 61 6d 65  me}::cmds $pname
0e10: 20 63 78 5f 24 70 6e 61 6d 65 0a 20 20 20 20 61   cx_$pname.    a
0e20: 70 70 65 6e 64 20 24 7b 6e 61 6d 65 7d 3a 3a 63  ppend ${name}::c
0e30: 6f 64 65 20 5c 6e 20 24 63 6f 64 65 0a 20 20 20  ode \n $code.   
0e40: 20 72 65 74 75 72 6e 0a 7d 0a 70 72 6f 63 20 3a   return.}.proc :
0e50: 3a 74 63 63 34 74 63 6c 3a 3a 64 6c 6c 3a 3a 77  :tcc4tcl::dll::w
0e60: 72 69 74 65 20 7b 6e 61 6d 65 20 61 72 67 6c 7d  rite {name argl}
0e70: 20 7b 0a 20 20 20 20 73 65 74 20 28 2d 64 69 72   {.    set (-dir
0e80: 29 20 2e 0a 20 20 20 20 73 65 74 20 28 2d 63 6f  ) ..    set (-co
0e90: 64 65 29 20 22 22 20 3b 23 20 70 6f 73 73 69 62  de) "" ;# possib
0ea0: 6c 65 20 65 78 74 72 61 20 63 6f 64 65 20 74 6f  le extra code to
0eb0: 20 67 6f 20 69 6e 74 6f 20 74 68 65 20 5f 49 6e   go into the _In
0ec0: 69 74 20 66 75 6e 63 74 69 6f 6e 0a 20 20 20 20  it function.    
0ed0: 73 65 74 20 28 2d 6c 69 62 73 29 20 22 22 0a 20  set (-libs) "". 
0ee0: 20 20 20 73 65 74 20 28 2d 6e 61 6d 65 29 20 5b     set (-name) [
0ef0: 73 74 72 69 6e 67 20 74 6f 6c 6f 77 65 72 20 24  string tolower $
0f00: 6e 61 6d 65 5d 0a 20 20 20 20 61 72 72 61 79 20  name].    array 
0f10: 73 65 74 20 22 22 20 24 61 72 67 6c 0a 20 20 20  set "" $argl.   
0f20: 20 61 70 70 65 6e 64 20 24 7b 6e 61 6d 65 7d 3a   append ${name}:
0f30: 3a 63 6f 64 65 20 5c 6e 20 5c 0a 20 20 20 20 20  :code \n \.     
0f40: 20 20 20 5b 3a 3a 74 63 63 34 74 63 6c 3a 3a 77     [::tcc4tcl::w
0f50: 72 61 70 45 78 70 6f 72 74 20 24 28 2d 6e 61 6d  rapExport $(-nam
0f60: 65 29 20 5b 73 65 74 20 24 7b 6e 61 6d 65 7d 3a  e) [set ${name}:
0f70: 3a 63 6d 64 73 5d 20 24 28 2d 63 6f 64 65 29 5d  :cmds] $(-code)]
0f80: 0a 20 20 20 20 73 65 74 20 6f 75 74 66 69 6c 65  .    set outfile
0f90: 20 24 28 2d 64 69 72 29 2f 24 28 2d 6e 61 6d 65   $(-dir)/$(-name
0fa0: 29 5b 69 6e 66 6f 20 73 68 61 72 65 64 6c 69 62  )[info sharedlib
0fb0: 65 78 74 65 6e 73 69 6f 6e 5d 0a 20 20 20 20 3a  extension].    :
0fc0: 3a 74 63 63 34 74 63 6c 3a 3a 74 6f 5f 64 6c 6c  :tcc4tcl::to_dll
0fd0: 20 5b 73 65 74 20 24 7b 6e 61 6d 65 7d 3a 3a 63   [set ${name}::c
0fe0: 6f 64 65 5d 20 24 6f 75 74 66 69 6c 65 20 24 28  ode] $outfile $(
0ff0: 2d 6c 69 62 73 29 0a 7d 0a 23 2d 2d 2d 2d 2d 2d  -libs).}.#------
1000: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d  ----------------
1010: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d  ----------------
1020: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d  ----------------
1030: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 0a  ---------------.
1040: 70 72 6f 63 20 3a 3a 74 63 63 34 74 63 6c 3a 3a  proc ::tcc4tcl::
1050: 77 72 61 70 20 7b 6e 61 6d 65 20 61 64 65 66 73  wrap {name adefs
1060: 20 72 74 79 70 65 20 7b 62 6f 64 79 20 22 23 22   rtype {body "#"
1070: 7d 7d 20 7b 0a 20 20 73 65 74 20 63 6e 61 6d 65  }} {.  set cname
1080: 20 63 5f 24 6e 61 6d 65 0a 20 20 73 65 74 20 77   c_$name.  set w
1090: 6e 61 6d 65 20 74 63 6c 5f 24 6e 61 6d 65 0a 20  name tcl_$name. 
10a0: 20 61 72 72 61 79 20 73 65 74 20 74 79 70 65 73   array set types
10b0: 20 7b 7d 0a 20 20 73 65 74 20 6e 61 6d 65 73 20   {}.  set names 
10c0: 7b 7d 0a 20 20 73 65 74 20 63 61 72 67 73 20 7b  {}.  set cargs {
10d0: 7d 0a 20 20 73 65 74 20 63 6e 61 6d 65 73 20 7b  }.  set cnames {
10e0: 7d 20 20 0a 20 20 23 20 69 66 20 66 69 72 73 74  }  .  # if first
10f0: 20 61 72 67 20 69 73 20 22 54 63 6c 5f 49 6e 74   arg is "Tcl_Int
1100: 65 72 70 2a 22 2c 20 70 61 73 73 20 69 74 20 77  erp*", pass it w
1110: 69 74 68 6f 75 74 20 63 6f 75 6e 74 69 6e 67 20  ithout counting 
1120: 69 74 20 61 73 20 61 20 63 6d 64 20 61 72 67 0a  it as a cmd arg.
1130: 20 20 69 66 20 7b 5b 6c 69 6e 64 65 78 20 24 61    if {[lindex $a
1140: 64 65 66 73 20 30 5d 20 65 71 20 22 54 63 6c 5f  defs 0] eq "Tcl_
1150: 49 6e 74 65 72 70 2a 22 7d 20 7b 0a 20 20 20 20  Interp*"} {.    
1160: 6c 61 70 70 65 6e 64 20 63 6e 61 6d 65 73 20 69  lappend cnames i
1170: 70 0a 20 20 20 20 6c 61 70 70 65 6e 64 20 63 61  p.    lappend ca
1180: 72 67 73 20 5b 6c 72 61 6e 67 65 20 24 61 64 65  rgs [lrange $ade
1190: 66 73 20 30 20 31 5d 0a 20 20 20 20 73 65 74 20  fs 0 1].    set 
11a0: 61 64 65 66 73 20 5b 6c 72 61 6e 67 65 20 24 61  adefs [lrange $a
11b0: 64 65 66 73 20 32 20 65 6e 64 5d 0a 20 20 7d 0a  defs 2 end].  }.
11c0: 20 20 66 6f 72 65 61 63 68 20 7b 74 20 6e 7d 20    foreach {t n} 
11d0: 24 61 64 65 66 73 20 7b 0a 20 20 20 20 73 65 74  $adefs {.    set
11e0: 20 74 79 70 65 73 28 24 6e 29 20 24 74 0a 20 20   types($n) $t.  
11f0: 20 20 6c 61 70 70 65 6e 64 20 6e 61 6d 65 73 20    lappend names 
1200: 24 6e 0a 20 20 20 20 6c 61 70 70 65 6e 64 20 63  $n.    lappend c
1210: 6e 61 6d 65 73 20 5f 24 6e 0a 20 20 20 20 6c 61  names _$n.    la
1220: 70 70 65 6e 64 20 63 61 72 67 73 20 22 24 74 20  ppend cargs "$t 
1230: 24 6e 22 0a 20 20 7d 0a 20 20 73 77 69 74 63 68  $n".  }.  switch
1240: 20 2d 2d 20 24 72 74 79 70 65 20 7b 0a 20 20 20   -- $rtype {.   
1250: 20 6f 6b 20 20 20 20 20 20 7b 20 73 65 74 20 72   ok      { set r
1260: 74 79 70 65 32 20 22 69 6e 74 22 20 7d 0a 20 20  type2 "int" }.  
1270: 20 20 73 74 72 69 6e 67 20 2d 20 64 73 74 72 69    string - dstri
1280: 6e 67 20 2d 20 76 73 74 72 69 6e 67 20 7b 20 73  ng - vstring { s
1290: 65 74 20 72 74 79 70 65 32 20 22 63 68 61 72 2a  et rtype2 "char*
12a0: 22 20 7d 0a 20 20 20 20 64 65 66 61 75 6c 74 20  " }.    default 
12b0: 7b 20 73 65 74 20 72 74 79 70 65 32 20 24 72 74  { set rtype2 $rt
12c0: 79 70 65 20 7d 0a 20 20 7d 0a 20 20 73 65 74 20  ype }.  }.  set 
12d0: 63 6f 64 65 20 22 22 0a 20 20 61 70 70 65 6e 64  code "".  append
12e0: 20 63 6f 64 65 20 22 5c 6e 23 69 6e 63 6c 75 64   code "\n#includ
12f0: 65 20 3c 74 63 6c 2e 68 3e 22 20 22 5c 6e 22 0a  e <tcl.h>" "\n".
1300: 20 20 69 66 20 7b 5b 69 6e 66 6f 20 65 78 69 73    if {[info exis
1310: 74 73 20 74 63 63 28 74 6b 29 5d 20 26 26 20 24  ts tcc(tk)] && $
1320: 74 63 63 28 74 6b 29 7d 20 7b 0a 20 20 20 20 61  tcc(tk)} {.    a
1330: 70 70 65 6e 64 20 63 6f 64 65 20 22 5c 23 69 6e  ppend code "\#in
1340: 63 6c 75 64 65 20 3c 74 6b 2e 68 3e 22 20 22 5c  clude <tk.h>" "\
1350: 6e 22 0a 20 20 7d 0a 20 20 69 66 20 7b 24 62 6f  n".  }.  if {$bo
1360: 64 79 20 6e 65 20 22 23 22 7d 20 7b 0a 20 20 20  dy ne "#"} {.   
1370: 20 61 70 70 65 6e 64 20 63 6f 64 65 20 22 73 74   append code "st
1380: 61 74 69 63 20 24 72 74 79 70 65 32 22 20 22 5c  atic $rtype2" "\
1390: 6e 22 0a 20 20 20 20 61 70 70 65 6e 64 20 63 6f  n".    append co
13a0: 64 65 20 22 24 7b 63 6e 61 6d 65 7d 28 5b 6a 6f  de "${cname}([jo
13b0: 69 6e 20 24 63 61 72 67 73 20 7b 2c 20 7d 5d 29  in $cargs {, }])
13c0: 20 5c 7b 5c 6e 22 0a 20 20 20 20 61 70 70 65 6e   \{\n".    appen
13d0: 64 20 63 6f 64 65 20 24 62 6f 64 79 0a 20 20 20  d code $body.   
13e0: 20 61 70 70 65 6e 64 20 63 6f 64 65 20 22 5c 7d   append code "\}
13f0: 22 20 22 5c 6e 22 0a 20 20 7d 20 65 6c 73 65 20  " "\n".  } else 
1400: 7b 0a 20 20 20 20 61 70 70 65 6e 64 20 63 6f 64  {.    append cod
1410: 65 20 22 23 64 65 66 69 6e 65 20 24 63 6e 61 6d  e "#define $cnam
1420: 65 20 24 6e 61 6d 65 22 20 22 5c 6e 22 0a 20 20  e $name" "\n".  
1430: 7d 0a 20 20 23 20 53 75 70 70 6f 72 74 65 64 20  }.  # Supported 
1440: 69 6e 70 75 74 20 74 79 70 65 73 0a 20 20 23 20  input types.  # 
1450: 20 20 54 63 6c 5f 49 6e 74 65 72 70 2a 0a 20 20    Tcl_Interp*.  
1460: 23 20 20 20 69 6e 74 0a 20 20 23 20 20 20 6c 6f  #   int.  #   lo
1470: 6e 67 0a 20 20 23 20 20 20 66 6c 6f 61 74 0a 20  ng.  #   float. 
1480: 20 23 20 20 20 64 6f 75 62 6c 65 0a 20 20 23 20   #   double.  # 
1490: 20 20 63 68 61 72 2a 0a 20 20 23 20 20 20 54 63    char*.  #   Tc
14a0: 6c 5f 4f 62 6a 2a 0a 20 20 23 20 20 20 76 6f 69  l_Obj*.  #   voi
14b0: 64 2a 0a 20 20 66 6f 72 65 61 63 68 20 78 20 24  d*.  foreach x $
14c0: 6e 61 6d 65 73 20 7b 0a 20 20 20 20 73 65 74 20  names {.    set 
14d0: 74 20 24 74 79 70 65 73 28 24 78 29 0a 20 20 20  t $types($x).   
14e0: 20 73 77 69 74 63 68 20 2d 2d 20 24 74 20 7b 0a   switch -- $t {.
14f0: 20 20 20 20 20 20 69 6e 74 20 2d 20 6c 6f 6e 67        int - long
1500: 20 2d 20 66 6c 6f 61 74 20 2d 20 64 6f 75 62 6c   - float - doubl
1510: 65 20 2d 20 63 68 61 72 2a 20 2d 20 54 63 6c 5f  e - char* - Tcl_
1520: 4f 62 6a 2a 20 7b 0a 20 20 20 20 20 20 20 20 20  Obj* {.         
1530: 20 61 70 70 65 6e 64 20 63 62 6f 64 79 20 22 20   append cbody " 
1540: 20 24 74 79 70 65 73 28 24 78 29 20 5f 24 78 3b   $types($x) _$x;
1550: 22 20 22 5c 6e 22 0a 20 20 20 20 20 20 7d 0a 20  " "\n".      }. 
1560: 20 20 20 20 20 64 65 66 61 75 6c 74 20 7b 61 70       default {ap
1570: 70 65 6e 64 20 63 62 6f 64 79 20 22 20 20 76 6f  pend cbody "  vo
1580: 69 64 20 2a 5f 24 78 3b 22 20 22 5c 6e 22 7d 0a  id *_$x;" "\n"}.
1590: 20 20 20 20 7d 0a 20 20 7d 0a 20 20 69 66 20 7b      }.  }.  if {
15a0: 24 72 74 79 70 65 20 6e 65 20 22 76 6f 69 64 22  $rtype ne "void"
15b0: 7d 20 7b 20 61 70 70 65 6e 64 20 63 62 6f 64 79  } { append cbody
15c0: 20 20 22 20 20 24 72 74 79 70 65 32 20 72 76 3b    "  $rtype2 rv;
15d0: 22 20 22 5c 6e 22 20 7d 20 20 0a 20 20 61 70 70  " "\n" }  .  app
15e0: 65 6e 64 20 63 62 6f 64 79 20 22 20 20 69 66 20  end cbody "  if 
15f0: 28 6f 62 6a 63 20 21 3d 20 5b 65 78 70 72 20 7b  (objc != [expr {
1600: 5b 6c 6c 65 6e 67 74 68 20 24 6e 61 6d 65 73 5d  [llength $names]
1610: 20 2b 20 31 7d 5d 29 20 7b 22 20 22 5c 6e 22 0a   + 1}]) {" "\n".
1620: 20 20 61 70 70 65 6e 64 20 63 62 6f 64 79 20 22    append cbody "
1630: 20 20 20 20 54 63 6c 5f 57 72 6f 6e 67 4e 75 6d      Tcl_WrongNum
1640: 41 72 67 73 28 69 70 2c 20 31 2c 20 6f 62 6a 76  Args(ip, 1, objv
1650: 2c 20 5c 22 5b 6a 6f 69 6e 20 24 6e 61 6d 65 73  , \"[join $names
1660: 20 7b 20 7d 5d 5c 22 29 3b 5c 6e 22 0a 20 20 61   { }]\");\n".  a
1670: 70 70 65 6e 64 20 63 62 6f 64 79 20 22 20 20 20  ppend cbody "   
1680: 20 72 65 74 75 72 6e 20 54 43 4c 5f 45 52 52 4f   return TCL_ERRO
1690: 52 3b 22 20 22 5c 6e 22 0a 20 20 61 70 70 65 6e  R;" "\n".  appen
16a0: 64 20 63 62 6f 64 79 20 22 20 20 7d 22 20 22 5c  d cbody "  }" "\
16b0: 6e 22 0a 20 20 73 65 74 20 6e 20 30 0a 20 20 66  n".  set n 0.  f
16c0: 6f 72 65 61 63 68 20 78 20 24 6e 61 6d 65 73 20  oreach x $names 
16d0: 7b 0a 20 20 20 20 69 6e 63 72 20 6e 0a 20 20 20  {.    incr n.   
16e0: 20 73 77 69 74 63 68 20 2d 2d 20 24 74 79 70 65   switch -- $type
16f0: 73 28 24 78 29 20 7b 0a 20 20 20 20 20 20 69 6e  s($x) {.      in
1700: 74 20 7b 0a 09 61 70 70 65 6e 64 20 63 62 6f 64  t {..append cbod
1710: 79 20 22 20 20 69 66 20 28 54 63 6c 5f 47 65 74  y "  if (Tcl_Get
1720: 49 6e 74 46 72 6f 6d 4f 62 6a 28 69 70 2c 20 6f  IntFromObj(ip, o
1730: 62 6a 76 5c 5b 24 6e 5d 2c 20 26 5f 24 78 29 20  bjv\[$n], &_$x) 
1740: 21 3d 20 54 43 4c 5f 4f 4b 29 22 0a 09 61 70 70  != TCL_OK)"..app
1750: 65 6e 64 20 63 62 6f 64 79 20 22 20 20 20 20 72  end cbody "    r
1760: 65 74 75 72 6e 20 54 43 4c 5f 45 52 52 4f 52 3b  eturn TCL_ERROR;
1770: 22 20 22 5c 6e 22 0a 20 20 20 20 20 20 7d 0a 20  " "\n".      }. 
1780: 20 20 20 20 20 6c 6f 6e 67 20 7b 0a 09 61 70 70       long {..app
1790: 65 6e 64 20 63 62 6f 64 79 20 22 20 20 69 66 20  end cbody "  if 
17a0: 28 54 63 6c 5f 47 65 74 4c 6f 6e 67 46 72 6f 6d  (Tcl_GetLongFrom
17b0: 4f 62 6a 28 69 70 2c 20 6f 62 6a 76 5c 5b 24 6e  Obj(ip, objv\[$n
17c0: 5d 2c 20 26 5f 24 78 29 20 21 3d 20 54 43 4c 5f  ], &_$x) != TCL_
17d0: 4f 4b 29 22 0a 09 61 70 70 65 6e 64 20 63 62 6f  OK)"..append cbo
17e0: 64 79 20 22 20 20 20 20 72 65 74 75 72 6e 20 54  dy "    return T
17f0: 43 4c 5f 45 52 52 4f 52 3b 22 20 22 5c 6e 22 0a  CL_ERROR;" "\n".
1800: 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 66 6c        }.      fl
1810: 6f 61 74 20 7b 0a 09 61 70 70 65 6e 64 20 63 62  oat {..append cb
1820: 6f 64 79 20 22 20 20 7b 22 20 22 5c 6e 22 0a 09  ody "  {" "\n"..
1830: 61 70 70 65 6e 64 20 63 62 6f 64 79 20 22 20 20  append cbody "  
1840: 20 20 64 6f 75 62 6c 65 20 74 3b 22 20 22 5c 6e    double t;" "\n
1850: 22 0a 09 61 70 70 65 6e 64 20 63 62 6f 64 79 20  "..append cbody 
1860: 22 20 20 20 20 69 66 20 28 54 63 6c 5f 47 65 74  "    if (Tcl_Get
1870: 44 6f 75 62 6c 65 46 72 6f 6d 4f 62 6a 28 69 70  DoubleFromObj(ip
1880: 2c 20 6f 62 6a 76 5c 5b 24 6e 5d 2c 20 26 74 29  , objv\[$n], &t)
1890: 20 21 3d 20 54 43 4c 5f 4f 4b 29 22 0a 09 61 70   != TCL_OK)"..ap
18a0: 70 65 6e 64 20 63 62 6f 64 79 20 22 20 20 20 20  pend cbody "    
18b0: 20 20 72 65 74 75 72 6e 20 54 43 4c 5f 45 52 52    return TCL_ERR
18c0: 4f 52 3b 22 20 22 5c 6e 22 0a 09 61 70 70 65 6e  OR;" "\n"..appen
18d0: 64 20 63 62 6f 64 79 20 22 20 20 20 20 5f 24 78  d cbody "    _$x
18e0: 20 3d 20 28 66 6c 6f 61 74 29 20 74 3b 22 20 22   = (float) t;" "
18f0: 5c 6e 22 0a 09 61 70 70 65 6e 64 20 63 62 6f 64  \n"..append cbod
1900: 79 20 22 20 20 7d 22 20 22 5c 6e 22 0a 20 20 20  y "  }" "\n".   
1910: 20 20 20 7d 0a 20 20 20 20 20 20 64 6f 75 62 6c     }.      doubl
1920: 65 20 7b 0a 09 61 70 70 65 6e 64 20 63 62 6f 64  e {..append cbod
1930: 79 20 22 20 20 69 66 20 28 54 63 6c 5f 47 65 74  y "  if (Tcl_Get
1940: 44 6f 75 62 6c 65 46 72 6f 6d 4f 62 6a 28 69 70  DoubleFromObj(ip
1950: 2c 20 6f 62 6a 76 5c 5b 24 6e 5d 2c 20 26 5f 24  , objv\[$n], &_$
1960: 78 29 20 21 3d 20 54 43 4c 5f 4f 4b 29 22 0a 09  x) != TCL_OK)"..
1970: 61 70 70 65 6e 64 20 63 62 6f 64 79 20 22 20 20  append cbody "  
1980: 20 20 72 65 74 75 72 6e 20 54 43 4c 5f 45 52 52    return TCL_ERR
1990: 4f 52 3b 22 20 22 5c 6e 22 0a 20 20 20 20 20 20  OR;" "\n".      
19a0: 7d 0a 20 20 20 20 20 20 63 68 61 72 2a 20 7b 0a  }.      char* {.
19b0: 09 61 70 70 65 6e 64 20 63 62 6f 64 79 20 22 20  .append cbody " 
19c0: 20 5f 24 78 20 3d 20 54 63 6c 5f 47 65 74 53 74   _$x = Tcl_GetSt
19d0: 72 69 6e 67 28 6f 62 6a 76 5c 5b 24 6e 5d 29 3b  ring(objv\[$n]);
19e0: 22 20 22 5c 6e 22 0a 20 20 20 20 20 20 7d 0a 20  " "\n".      }. 
19f0: 20 20 20 20 20 64 65 66 61 75 6c 74 20 7b 0a 09       default {..
1a00: 61 70 70 65 6e 64 20 63 62 6f 64 79 20 22 20 20  append cbody "  
1a10: 5f 24 78 20 3d 20 6f 62 6a 76 5c 5b 24 6e 5d 3b  _$x = objv\[$n];
1a20: 22 20 22 5c 6e 22 0a 20 20 20 20 20 20 7d 0a 20  " "\n".      }. 
1a30: 20 20 20 7d 0a 20 20 7d 0a 20 20 61 70 70 65 6e     }.  }.  appen
1a40: 64 20 63 62 6f 64 79 20 22 5c 6e 20 20 22 0a 20  d cbody "\n  ". 
1a50: 20 69 66 20 7b 24 72 74 79 70 65 20 21 3d 20 22   if {$rtype != "
1a60: 76 6f 69 64 22 7d 20 7b 61 70 70 65 6e 64 20 63  void"} {append c
1a70: 62 6f 64 79 20 22 72 76 20 3d 20 22 7d 0a 20 20  body "rv = "}.  
1a80: 61 70 70 65 6e 64 20 63 62 6f 64 79 20 22 24 7b  append cbody "${
1a90: 63 6e 61 6d 65 7d 28 5b 6a 6f 69 6e 20 24 63 6e  cname}([join $cn
1aa0: 61 6d 65 73 20 7b 2c 20 7d 5d 29 3b 22 20 22 5c  ames {, }]);" "\
1ab0: 6e 22 0a 20 20 23 20 52 65 74 75 72 6e 20 74 79  n".  # Return ty
1ac0: 70 65 73 20 73 75 70 70 6f 72 74 65 64 20 62 79  pes supported by
1ad0: 20 63 72 69 74 63 6c 0a 20 20 23 20 20 20 76 6f   critcl.  #   vo
1ae0: 69 64 0a 20 20 23 20 20 20 6f 6b 0a 20 20 23 20  id.  #   ok.  # 
1af0: 20 20 69 6e 74 0a 20 20 23 20 20 20 6c 6f 6e 67    int.  #   long
1b00: 0a 20 20 23 20 20 20 66 6c 6f 61 74 0a 20 20 23  .  #   float.  #
1b10: 20 20 20 64 6f 75 62 6c 65 0a 20 20 23 20 20 20     double.  #   
1b20: 63 68 61 72 2a 20 20 20 20 20 28 54 43 4c 5f 53  char*     (TCL_S
1b30: 54 41 54 49 43 20 63 68 61 72 2a 29 0a 20 20 23  TATIC char*).  #
1b40: 20 20 20 73 74 72 69 6e 67 20 20 20 20 28 54 43     string    (TC
1b50: 4c 5f 44 59 4e 41 4d 49 43 20 63 68 61 72 2a 29  L_DYNAMIC char*)
1b60: 0a 20 20 23 20 20 20 64 73 74 72 69 6e 67 20 20  .  #   dstring  
1b70: 20 28 54 43 4c 5f 44 59 4e 41 4d 49 43 20 63 68   (TCL_DYNAMIC ch
1b80: 61 72 2a 29 0a 20 20 23 20 20 20 76 73 74 72 69  ar*).  #   vstri
1b90: 6e 67 20 20 20 28 54 43 4c 5f 56 4f 4c 41 54 49  ng   (TCL_VOLATI
1ba0: 4c 45 20 63 68 61 72 2a 29 0a 20 20 23 20 20 20  LE char*).  #   
1bb0: 64 65 66 61 75 6c 74 20 20 20 28 54 63 6c 5f 4f  default   (Tcl_O
1bc0: 62 6a 2a 29 0a 20 20 23 20 4f 75 72 20 65 78 74  bj*).  # Our ext
1bd0: 65 6e 73 69 6f 6e 73 0a 20 20 23 20 20 20 77 69  ensions.  #   wi
1be0: 64 65 0a 20 20 73 77 69 74 63 68 20 2d 2d 20 24  de.  switch -- $
1bf0: 72 74 79 70 65 20 7b 0a 20 20 20 20 76 6f 69 64  rtype {.    void
1c00: 20 20 20 20 09 7b 20 7d 0a 20 20 20 20 6f 6b 09      .{ }.    ok.
1c10: 20 20 20 20 20 20 20 20 7b 20 61 70 70 65 6e 64          { append
1c20: 20 63 62 6f 64 79 20 22 20 20 72 65 74 75 72 6e   cbody "  return
1c30: 20 72 76 3b 22 20 22 5c 6e 22 20 7d 0a 20 20 20   rv;" "\n" }.   
1c40: 20 69 6e 74 09 20 20 20 20 20 20 20 20 7b 20 61   int.        { a
1c50: 70 70 65 6e 64 20 63 62 6f 64 79 20 22 20 20 54  ppend cbody "  T
1c60: 63 6c 5f 53 65 74 49 6e 74 4f 62 6a 28 54 63 6c  cl_SetIntObj(Tcl
1c70: 5f 47 65 74 4f 62 6a 52 65 73 75 6c 74 28 69 70  _GetObjResult(ip
1c80: 29 2c 20 72 76 29 3b 22 20 22 5c 6e 22 20 7d 0a  ), rv);" "\n" }.
1c90: 20 20 20 20 6c 6f 6e 67 09 7b 20 61 70 70 65 6e      long.{ appen
1ca0: 64 20 63 62 6f 64 79 20 22 20 20 54 63 6c 5f 53  d cbody "  Tcl_S
1cb0: 65 74 4c 6f 6e 67 4f 62 6a 28 54 63 6c 5f 47 65  etLongObj(Tcl_Ge
1cc0: 74 4f 62 6a 52 65 73 75 6c 74 28 69 70 29 2c 20  tObjResult(ip), 
1cd0: 72 76 29 3b 22 20 22 5c 6e 22 20 7d 0a 20 20 20  rv);" "\n" }.   
1ce0: 20 66 6c 6f 61 74 20 20 20 20 20 20 20 2d 0a 20   float       -. 
1cf0: 20 20 20 64 6f 75 62 6c 65 09 7b 20 61 70 70 65     double.{ appe
1d00: 6e 64 20 63 62 6f 64 79 20 22 20 20 54 63 6c 5f  nd cbody "  Tcl_
1d10: 53 65 74 44 6f 75 62 6c 65 4f 62 6a 28 54 63 6c  SetDoubleObj(Tcl
1d20: 5f 47 65 74 4f 62 6a 52 65 73 75 6c 74 28 69 70  _GetObjResult(ip
1d30: 29 2c 20 72 76 29 3b 22 20 22 5c 6e 22 20 7d 0a  ), rv);" "\n" }.
1d40: 20 20 20 20 63 68 61 72 2a 09 7b 20 61 70 70 65      char*.{ appe
1d50: 6e 64 20 63 62 6f 64 79 20 22 20 20 54 63 6c 5f  nd cbody "  Tcl_
1d60: 53 65 74 52 65 73 75 6c 74 28 69 70 2c 20 72 76  SetResult(ip, rv
1d70: 2c 20 54 43 4c 5f 53 54 41 54 49 43 29 3b 22 20  , TCL_STATIC);" 
1d80: 22 5c 6e 22 20 7d 0a 20 20 20 20 73 74 72 69 6e  "\n" }.    strin
1d90: 67 20 20 20 20 20 20 2d 0a 20 20 20 20 64 73 74  g      -.    dst
1da0: 72 69 6e 67 09 7b 20 61 70 70 65 6e 64 20 63 62  ring.{ append cb
1db0: 6f 64 79 20 22 20 20 54 63 6c 5f 53 65 74 52 65  ody "  Tcl_SetRe
1dc0: 73 75 6c 74 28 69 70 2c 20 72 76 2c 20 54 43 4c  sult(ip, rv, TCL
1dd0: 5f 44 59 4e 41 4d 49 43 29 3b 22 20 22 5c 6e 22  _DYNAMIC);" "\n"
1de0: 20 7d 0a 20 20 20 20 76 73 74 72 69 6e 67 09 7b   }.    vstring.{
1df0: 20 61 70 70 65 6e 64 20 63 62 6f 64 79 20 22 20   append cbody " 
1e00: 20 54 63 6c 5f 53 65 74 52 65 73 75 6c 74 28 69   Tcl_SetResult(i
1e10: 70 2c 20 72 76 2c 20 54 43 4c 5f 56 4f 4c 41 54  p, rv, TCL_VOLAT
1e20: 49 4c 45 29 3b 22 20 22 5c 6e 22 20 7d 0a 20 20  ILE);" "\n" }.  
1e30: 20 20 64 65 66 61 75 6c 74 20 09 7b 20 61 70 70    default .{ app
1e40: 65 6e 64 20 63 62 6f 64 79 20 22 20 20 54 63 6c  end cbody "  Tcl
1e50: 5f 53 65 74 4f 62 6a 52 65 73 75 6c 74 28 69 70  _SetObjResult(ip
1e60: 2c 20 72 76 29 3b 20 54 63 6c 5f 44 65 63 72 52  , rv); Tcl_DecrR
1e70: 65 66 43 6f 75 6e 74 28 72 76 29 3b 22 20 22 5c  efCount(rv);" "\
1e80: 6e 22 20 7d 0a 20 20 7d 0a 20 20 69 66 20 7b 24  n" }.  }.  if {$
1e90: 72 74 79 70 65 20 21 3d 20 22 6f 6b 22 7d 20 7b  rtype != "ok"} {
1ea0: 61 70 70 65 6e 64 20 63 62 6f 64 79 20 22 20 20  append cbody "  
1eb0: 72 65 74 75 72 6e 20 54 43 4c 5f 4f 4b 3b 22 20  return TCL_OK;" 
1ec0: 5c 6e 7d 0a 0a 20 20 23 70 75 74 73 20 2d 2d 2d  \n}..  #puts ---
1ed0: 2d 63 6f 64 65 3a 5c 6e 24 63 6f 64 65 0a 20 20  -code:\n$code.  
1ee0: 23 70 75 74 73 20 2d 2d 2d 2d 63 62 6f 64 79 3a  #puts ----cbody:
1ef0: 5c 6e 24 63 62 6f 64 79 0a 20 20 6c 69 73 74 20  \n$cbody.  list 
1f00: 24 63 6f 64 65 20 24 63 62 6f 64 79 0a 7d 0a 70  $code $cbody.}.p
1f10: 72 6f 63 20 3a 3a 74 63 63 34 74 63 6c 3a 3a 77  roc ::tcc4tcl::w
1f20: 72 61 70 43 6d 64 20 7b 74 63 6c 6e 61 6d 65 20  rapCmd {tclname 
1f30: 61 72 67 6c 20 72 74 79 70 65 20 63 6e 61 6d 65  argl rtype cname
1f40: 20 62 6f 64 79 7d 20 7b 0a 20 20 20 20 66 6f 72   body} {.    for
1f50: 65 61 63 68 20 7b 63 6f 64 65 20 63 62 6f 64 79  each {code cbody
1f60: 7d 20 5b 77 72 61 70 20 24 74 63 6c 6e 61 6d 65  } [wrap $tclname
1f70: 20 24 61 72 67 6c 20 24 72 74 79 70 65 20 24 62   $argl $rtype $b
1f80: 6f 64 79 5d 20 62 72 65 61 6b 0a 20 20 20 20 61  ody] break.    a
1f90: 70 70 65 6e 64 20 63 6f 64 65 20 22 5c 6e 73 74  ppend code "\nst
1fa0: 61 74 69 63 20 69 6e 74 20 24 63 6e 61 6d 65 22  atic int $cname"
1fb0: 0a 20 20 20 20 61 70 70 65 6e 64 20 63 6f 64 65  .    append code
1fc0: 20 7b 28 43 6c 69 65 6e 74 44 61 74 61 20 63 64   {(ClientData cd
1fd0: 61 74 61 2c 54 63 6c 5f 49 6e 74 65 72 70 20 2a  ata,Tcl_Interp *
1fe0: 69 70 2c 0a 20 20 20 20 20 20 20 20 69 6e 74 20  ip,.        int 
1ff0: 6f 62 6a 63 2c 54 63 6c 5f 4f 62 6a 2a 20 43 4f  objc,Tcl_Obj* CO
2000: 4e 53 54 20 6f 62 6a 76 5b 5d 29 7d 20 22 20 5c  NST objv[])} " \
2010: 7b 22 0a 20 20 20 20 61 70 70 65 6e 64 20 63 6f  {".    append co
2020: 64 65 20 5c 6e 24 63 62 6f 64 79 20 5c 6e 5c 7d  de \n$cbody \n\}
2030: 5c 6e 0a 7d 0a 70 72 6f 63 20 3a 3a 74 63 63 34  \n.}.proc ::tcc4
2040: 74 63 6c 3a 3a 77 72 61 70 45 78 70 6f 72 74 20  tcl::wrapExport 
2050: 7b 6e 61 6d 65 20 63 6d 64 73 20 7b 62 6f 64 79  {name cmds {body
2060: 20 22 22 7d 7d 20 7b 0a 20 20 20 20 73 65 74 20   ""}} {.    set 
2070: 63 6f 64 65 20 22 44 4c 4c 5f 45 58 50 4f 52 54  code "DLL_EXPORT
2080: 20 69 6e 74 20 5b 73 74 72 69 6e 67 20 74 6f 74   int [string tot
2090: 69 74 6c 65 20 24 6e 61 6d 65 5d 5f 49 6e 69 74  itle $name]_Init
20a0: 28 54 63 6c 5f 49 6e 74 65 72 70 20 2a 69 6e 74  (Tcl_Interp *int
20b0: 65 72 70 29 22 0a 20 20 20 20 61 70 70 65 6e 64  erp)".    append
20c0: 20 63 6f 64 65 20 22 20 5c 7b 5c 6e 22 0a 20 20   code " \{\n".  
20d0: 20 20 66 6f 72 65 61 63 68 20 7b 74 63 6c 6e 61    foreach {tclna
20e0: 6d 65 20 63 6e 61 6d 65 7d 20 24 63 6d 64 73 20  me cname} $cmds 
20f0: 7b 0a 20 20 20 20 20 20 20 20 61 70 70 65 6e 64  {.        append
2100: 20 63 6f 64 65 20 5c 0a 20 20 20 20 20 20 20 20   code \.        
2110: 20 20 20 20 22 54 63 6c 5f 43 72 65 61 74 65 4f      "Tcl_CreateO
2120: 62 6a 43 6f 6d 6d 61 6e 64 28 69 6e 74 65 72 70  bjCommand(interp
2130: 2c 5c 22 24 74 63 6c 6e 61 6d 65 5c 22 2c 24 63  ,\"$tclname\",$c
2140: 6e 61 6d 65 2c 4e 55 4c 4c 2c 4e 55 4c 4c 29 3b  name,NULL,NULL);
2150: 5c 6e 22 0a 20 20 20 20 7d 0a 20 20 20 20 61 70  \n".    }.    ap
2160: 70 65 6e 64 20 63 6f 64 65 20 24 62 6f 64 79 0a  pend code $body.
2170: 20 20 20 20 61 70 70 65 6e 64 20 63 6f 64 65 20      append code 
2180: 22 5c 6e 72 65 74 75 72 6e 20 54 43 4c 5f 4f 4b  "\nreturn TCL_OK
2190: 3b 5c 6e 5c 7d 22 0a 7d 0a 23 2d 2d 2d 2d 2d 2d  ;\n\}".}.#------
21a0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d  ----------------
21b0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d  ----------------
21c0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d  ----------------
21d0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 0a  ---------------.
21e0: 70 72 6f 63 20 3a 3a 74 63 63 34 74 63 6c 3a 3a  proc ::tcc4tcl::
21f0: 63 70 72 6f 63 20 7b 6e 61 6d 65 20 61 64 65 66  cproc {name adef
2200: 73 20 72 74 79 70 65 20 7b 62 6f 64 79 20 22 23  s rtype {body "#
2210: 22 7d 7d 20 7b 0a 20 20 66 6f 72 65 61 63 68 20  "}} {.  foreach 
2220: 7b 63 6f 64 65 20 63 62 6f 64 79 7d 20 5b 77 72  {code cbody} [wr
2230: 61 70 20 24 6e 61 6d 65 20 24 61 64 65 66 73 20  ap $name $adefs 
2240: 24 72 74 79 70 65 20 24 62 6f 64 79 5d 20 62 72  $rtype $body] br
2250: 65 61 6b 0a 20 20 63 63 6f 64 65 20 24 63 6f 64  eak.  ccode $cod
2260: 65 0a 20 20 73 65 74 20 6e 73 20 5b 6e 61 6d 65  e.  set ns [name
2270: 73 70 61 63 65 20 63 75 72 72 65 6e 74 5d 0a 20  space current]. 
2280: 20 75 70 6c 65 76 65 6c 20 31 20 5b 6c 69 73 74   uplevel 1 [list
2290: 20 24 7b 6e 73 7d 3a 3a 63 63 6f 6d 6d 61 6e 64   ${ns}::ccommand
22a0: 20 24 6e 61 6d 65 20 7b 64 75 6d 6d 79 20 69 70   $name {dummy ip
22b0: 20 6f 62 6a 63 20 6f 62 6a 76 7d 20 24 63 62 6f   objc objv} $cbo
22c0: 64 79 5d 0a 7d 0a 23 2d 2d 2d 2d 2d 2d 2d 2d 2d  dy].}.#---------
22d0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d  ----------------
22e0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d  ----------------
22f0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d  ----------------
2300: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 0a 70 72 6f  ------------.pro
2310: 63 20 3a 3a 74 63 63 34 74 63 6c 3a 3a 63 64 61  c ::tcc4tcl::cda
2320: 74 61 20 7b 6e 61 6d 65 20 64 61 74 61 7d 20 7b  ta {name data} {
2330: 0a 20 20 23 20 45 78 74 72 61 63 74 20 62 79 74  .  # Extract byt
2340: 65 73 20 66 72 6f 6d 20 64 61 74 61 0a 20 20 62  es from data.  b
2350: 69 6e 61 72 79 20 73 63 61 6e 20 24 64 61 74 61  inary scan $data
2360: 20 63 2a 20 62 79 74 65 73 0a 20 20 20 20 73 65   c* bytes.    se
2370: 74 20 69 6e 69 74 74 65 78 74 20 22 5c 6e 22 0a  t inittext "\n".
2380: 20 20 73 65 74 20 6c 69 6e 65 20 22 22 0a 20 20    set line "".  
2390: 73 65 74 20 6e 20 30 0a 20 20 73 65 74 20 6c 20  set n 0.  set l 
23a0: 30 0a 20 20 66 6f 72 65 61 63 68 20 63 20 24 62  0.  foreach c $b
23b0: 79 74 65 73 20 7b 0a 20 20 20 20 69 66 20 7b 24  ytes {.    if {$
23c0: 6e 3e 30 7d 20 7b 61 70 70 65 6e 64 20 69 6e 69  n>0} {append ini
23d0: 74 74 65 78 74 20 22 2c 22 7d 0a 20 20 20 20 69  ttext ","}.    i
23e0: 66 20 7b 24 6c 3e 32 30 7d 20 7b 0a 20 20 20 20  f {$l>20} {.    
23f0: 20 20 61 70 70 65 6e 64 20 69 6e 69 74 74 65 78    append inittex
2400: 74 20 22 5c 6e 22 0a 20 20 20 20 20 20 73 65 74  t "\n".      set
2410: 20 6c 20 30 0a 20 20 20 20 7d 0a 20 20 20 20 69   l 0.    }.    i
2420: 66 20 7b 24 6c 3d 3d 30 7d 20 7b 61 70 70 65 6e  f {$l==0} {appen
2430: 64 20 69 6e 69 74 74 65 78 74 20 22 20 20 22 7d  d inittext "  "}
2440: 0a 20 20 20 20 61 70 70 65 6e 64 20 69 6e 69 74  .    append init
2450: 74 65 78 74 20 5b 66 6f 72 6d 61 74 20 22 30 78  text [format "0x
2460: 25 30 32 58 22 20 5b 65 78 70 72 20 7b 24 63 20  %02X" [expr {$c 
2470: 26 20 30 78 66 66 7d 5d 5d 0a 20 20 20 20 69 6e  & 0xff}]].    in
2480: 63 72 20 6e 0a 20 20 20 20 69 6e 63 72 20 6c 0a  cr n.    incr l.
2490: 20 20 7d 0a 20 20 61 70 70 65 6e 64 20 69 6e 69    }.  append ini
24a0: 74 74 65 78 74 20 22 5c 6e 22 0a 20 20 73 65 74  ttext "\n".  set
24b0: 20 63 6f 75 6e 74 20 5b 6c 6c 65 6e 67 74 68 20   count [llength 
24c0: 24 62 79 74 65 73 5d 20 20 0a 20 20 73 65 74 20  $bytes]  .  set 
24d0: 63 62 6f 64 79 20 22 22 0a 20 20 61 70 70 65 6e  cbody "".  appen
24e0: 64 20 63 62 6f 64 79 20 22 73 74 61 74 69 63 20  d cbody "static 
24f0: 75 6e 73 69 67 6e 65 64 20 63 68 61 72 20 73 63  unsigned char sc
2500: 72 69 70 74 5c 5b 24 63 6f 75 6e 74 5c 5d 20 3d  ript\[$count\] =
2510: 20 5c 7b 22 20 22 5c 6e 22 0a 20 20 61 70 70 65   \{" "\n".  appe
2520: 6e 64 20 63 62 6f 64 79 20 24 69 6e 69 74 74 65  nd cbody $initte
2530: 78 74 0a 20 20 61 70 70 65 6e 64 20 63 62 6f 64  xt.  append cbod
2540: 79 20 22 5c 7d 3b 22 20 22 5c 6e 22 0a 20 20 61  y "\};" "\n".  a
2550: 70 70 65 6e 64 20 63 62 6f 64 79 20 22 54 63 6c  ppend cbody "Tcl
2560: 5f 53 65 74 42 79 74 65 41 72 72 61 79 4f 62 6a  _SetByteArrayObj
2570: 28 54 63 6c 5f 47 65 74 4f 62 6a 52 65 73 75 6c  (Tcl_GetObjResul
2580: 74 28 69 70 29 2c 20 28 75 6e 73 69 67 6e 65 64  t(ip), (unsigned
2590: 20 63 68 61 72 2a 29 20 73 63 72 69 70 74 2c 20   char*) script, 
25a0: 24 63 6f 75 6e 74 29 3b 5c 6e 22 0a 20 20 61 70  $count);\n".  ap
25b0: 70 65 6e 64 20 63 62 6f 64 79 20 22 72 65 74 75  pend cbody "retu
25c0: 72 6e 20 54 43 4c 5f 4f 4b 3b 22 20 22 5c 6e 22  rn TCL_OK;" "\n"
25d0: 0a 20 20 73 65 74 20 6e 73 20 5b 6e 61 6d 65 73  .  set ns [names
25e0: 70 61 63 65 20 63 75 72 72 65 6e 74 5d 0a 20 20  pace current].  
25f0: 75 70 6c 65 76 65 6c 20 31 20 5b 6c 69 73 74 20  uplevel 1 [list 
2600: 24 7b 6e 73 7d 3a 3a 63 63 6f 6d 6d 61 6e 64 20  ${ns}::ccommand 
2610: 24 6e 61 6d 65 20 7b 64 75 6d 6d 79 20 69 70 20  $name {dummy ip 
2620: 6f 62 6a 63 20 6f 62 6a 76 7d 20 24 63 62 6f 64  objc objv} $cbod
2630: 79 5d 0a 20 20 72 65 74 75 72 6e 20 24 6e 61 6d  y].  return $nam
2640: 65 0a 7d 0a 23 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d  e.}.#-----------
2650: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d  ----------------
2660: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d  ----------------
2670: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d  ----------------
2680: 2d 2d 2d 2d 2d 2d 2d 2d 0a 70 72 6f 63 20 3a 3a  --------.proc ::
2690: 74 63 63 34 74 63 6c 3a 3a 63 63 6f 6d 6d 61 6e  tcc4tcl::ccomman
26a0: 64 20 7b 70 72 6f 63 6e 61 6d 65 20 61 6e 61 6d  d {procname anam
26b0: 65 73 20 61 72 67 73 7d 20 7b 0a 20 20 76 61 72  es args} {.  var
26c0: 69 61 62 6c 65 20 74 63 63 0a 20 20 23 20 46 75  iable tcc.  # Fu
26d0: 6c 6c 79 20 71 75 61 6c 69 66 69 65 64 20 70 72  lly qualified pr
26e0: 6f 63 20 6e 61 6d 65 0a 20 20 69 66 20 7b 5b 73  oc name.  if {[s
26f0: 74 72 69 6e 67 20 6d 61 74 63 68 20 22 3a 3a 2a  tring match "::*
2700: 22 20 24 70 72 6f 63 6e 61 6d 65 5d 7d 20 7b 0a  " $procname]} {.
2710: 20 20 20 20 23 20 70 72 6f 63 6e 61 6d 65 20 69      # procname i
2720: 73 20 61 6c 72 65 61 64 79 20 61 62 73 6f 6c 75  s already absolu
2730: 74 65 0a 20 20 7d 20 65 6c 73 65 20 7b 0a 20 20  te.  } else {.  
2740: 20 20 73 65 74 20 6e 73 66 72 6f 6d 20 5b 75 70    set nsfrom [up
2750: 6c 65 76 65 6c 20 31 20 7b 6e 61 6d 65 73 70 61  level 1 {namespa
2760: 63 65 20 63 75 72 72 65 6e 74 7d 5d 20 20 20 20  ce current}]    
2770: 0a 20 20 20 20 69 66 20 7b 24 6e 73 66 72 6f 6d  .    if {$nsfrom
2780: 20 65 71 20 22 3a 3a 22 7d 20 7b 73 65 74 20 6e   eq "::"} {set n
2790: 73 66 72 6f 6d 20 22 22 7d 0a 20 20 20 20 73 65  sfrom ""}.    se
27a0: 74 20 70 72 6f 63 6e 61 6d 65 20 22 24 7b 6e 73  t procname "${ns
27b0: 66 72 6f 6d 7d 3a 3a 24 7b 70 72 6f 63 6e 61 6d  from}::${procnam
27c0: 65 7d 22 0a 20 20 7d 20 20 20 20 20 20 0a 20 20  e}".  }      .  
27d0: 73 65 74 20 76 28 63 6c 69 65 6e 74 64 61 74 61  set v(clientdata
27e0: 29 20 63 6c 69 65 6e 74 64 61 74 61 0a 20 20 73  ) clientdata.  s
27f0: 65 74 20 76 28 69 6e 74 65 72 70 29 20 20 20 20  et v(interp)    
2800: 20 69 6e 74 65 72 70 0a 20 20 73 65 74 20 76 28   interp.  set v(
2810: 6f 62 6a 63 29 20 20 20 20 20 20 20 6f 62 6a 63  objc)       objc
2820: 0a 20 20 73 65 74 20 76 28 6f 62 6a 76 29 20 20  .  set v(objv)  
2830: 20 20 20 20 20 6f 62 6a 76 0a 20 20 73 65 74 20       objv.  set 
2840: 69 64 20 30 0a 20 20 66 6f 72 65 61 63 68 20 64  id 0.  foreach d
2850: 65 66 6e 61 6d 65 20 7b 63 6c 69 65 6e 74 64 61  efname {clientda
2860: 74 61 20 69 6e 74 65 72 70 20 6f 62 6a 63 20 6f  ta interp objc o
2870: 62 6a 76 7d 20 7b 0a 20 20 20 20 69 66 20 7b 5b  bjv} {.    if {[
2880: 6c 6c 65 6e 67 74 68 20 24 61 6e 61 6d 65 73 5d  llength $anames]
2890: 3e 24 69 64 7d 20 7b 0a 20 20 20 20 20 20 73 65  >$id} {.      se
28a0: 74 20 76 6e 61 6d 65 20 5b 6c 69 6e 64 65 78 20  t vname [lindex 
28b0: 24 61 6e 61 6d 65 73 20 24 69 64 5d 0a 20 20 20  $anames $id].   
28c0: 20 20 20 69 66 20 7b 21 5b 63 68 65 63 6b 6e 61     if {![checkna
28d0: 6d 65 20 24 76 6e 61 6d 65 5d 7d 20 7b 0a 09 65  me $vname]} {..e
28e0: 72 72 6f 72 20 22 69 6e 76 61 6c 69 64 20 76 61  rror "invalid va
28f0: 72 69 61 62 6c 65 20 6e 61 6d 65 20 5c 22 24 76  riable name \"$v
2900: 6e 61 6d 65 5c 22 22 0a 20 20 20 20 20 20 7d 0a  name\"".      }.
2910: 20 20 20 20 7d 20 65 6c 73 65 20 7b 73 65 74 20      } else {set 
2920: 76 6e 61 6d 65 20 24 64 65 66 6e 61 6d 65 7d 0a  vname $defname}.
2930: 20 20 20 20 73 65 74 20 76 28 24 64 65 66 6e 61      set v($defna
2940: 6d 65 29 20 24 76 6e 61 6d 65 0a 20 20 20 20 69  me) $vname.    i
2950: 6e 63 72 20 69 64 0a 20 20 7d 0a 20 20 73 65 74  ncr id.  }.  set
2960: 20 63 6e 61 6d 65 20 43 6d 64 5f 4e 24 7b 69 64   cname Cmd_N${id
2970: 7d 5f 5b 63 6c 65 61 6e 6e 61 6d 65 20 24 70 72  }_[cleanname $pr
2980: 6f 63 6e 61 6d 65 5d 0a 20 20 73 65 74 20 63 6f  ocname].  set co
2990: 64 65 20 22 22 0a 20 20 69 66 20 7b 5b 69 6e 66  de "".  if {[inf
29a0: 6f 20 65 78 69 73 74 73 20 74 63 63 28 74 6b 29  o exists tcc(tk)
29b0: 5d 20 26 26 20 24 74 63 63 28 74 6b 29 7d 20 7b  ] && $tcc(tk)} {
29c0: 0a 20 20 20 20 61 70 70 65 6e 64 20 63 6f 64 65  .    append code
29d0: 20 22 5c 23 69 6e 63 6c 75 64 65 20 3c 74 6b 2e   "\#include <tk.
29e0: 68 3e 22 20 22 5c 6e 22 0a 20 20 7d 0a 20 20 69  h>" "\n".  }.  i
29f0: 66 20 7b 5b 69 6e 66 6f 20 65 78 69 73 74 73 20  f {[info exists 
2a00: 74 63 63 28 63 6f 64 65 29 5d 20 26 26 20 5b 73  tcc(code)] && [s
2a10: 74 72 69 6e 67 20 6c 65 6e 67 74 68 20 24 74 63  tring length $tc
2a20: 63 28 63 6f 64 65 29 5d 3e 30 7d 20 7b 0a 20 20  c(code)]>0} {.  
2a30: 20 20 61 70 70 65 6e 64 20 63 6f 64 65 20 24 74    append code $t
2a40: 63 63 28 63 6f 64 65 29 0a 20 20 20 20 61 70 70  cc(code).    app
2a50: 65 6e 64 20 63 6f 64 65 20 22 5c 6e 22 0a 20 20  end code "\n".  
2a60: 7d 0a 20 20 61 70 70 65 6e 64 20 63 6f 64 65 20  }.  append code 
2a70: 22 69 6e 74 20 24 63 6e 61 6d 65 20 28 43 6c 69  "int $cname (Cli
2a80: 65 6e 74 44 61 74 61 20 24 76 28 63 6c 69 65 6e  entData $v(clien
2a90: 74 64 61 74 61 29 2c 54 63 6c 5f 49 6e 74 65 72  tdata),Tcl_Inter
2aa0: 70 20 2a 24 76 28 69 6e 74 65 72 70 29 2c 22 0a  p *$v(interp),".
2ab0: 20 20 61 70 70 65 6e 64 20 63 6f 64 65 20 22 69    append code "i
2ac0: 6e 74 20 24 76 28 6f 62 6a 63 29 2c 54 63 6c 5f  nt $v(objc),Tcl_
2ad0: 4f 62 6a 20 2a 43 4f 4e 53 54 20 24 76 28 6f 62  Obj *CONST $v(ob
2ae0: 6a 76 29 5c 5b 5c 5d 29 20 7b 22 20 22 5c 6e 22  jv)\[\]) {" "\n"
2af0: 0a 20 20 61 70 70 65 6e 64 20 63 6f 64 65 20 5b  .  append code [
2b00: 6c 69 6e 64 65 78 20 24 61 72 67 73 20 65 6e 64  lindex $args end
2b10: 5d 20 22 5c 6e 22 0a 20 20 61 70 70 65 6e 64 20  ] "\n".  append 
2b20: 63 6f 64 65 20 22 7d 22 20 22 5c 6e 22 0a 20 20  code "}" "\n".  
2b30: 73 65 74 20 6e 73 20 5b 6e 61 6d 65 73 70 61 63  set ns [namespac
2b40: 65 20 63 75 72 72 65 6e 74 5d 0a 20 20 75 70 6c  e current].  upl
2b50: 65 76 65 6c 20 31 20 5b 6c 69 73 74 20 24 7b 6e  evel 1 [list ${n
2b60: 73 7d 3a 3a 63 63 20 24 63 6f 64 65 5d 0a 20 20  s}::cc $code].  
2b70: 4c 6f 67 20 22 43 52 45 41 54 49 4e 47 20 54 43  Log "CREATING TC
2b80: 4c 20 43 4f 4d 4d 41 4e 44 20 24 70 72 6f 63 6e  L COMMAND $procn
2b90: 61 6d 65 20 2f 20 24 63 6e 61 6d 65 22 0a 20 20  ame / $cname".  
2ba0: 75 70 6c 65 76 65 6c 20 31 20 5b 6c 69 73 74 20  uplevel 1 [list 
2bb0: 24 74 63 63 28 63 63 29 20 63 6f 6d 6d 61 6e 64  $tcc(cc) command
2bc0: 20 24 70 72 6f 63 6e 61 6d 65 20 24 63 6e 61 6d   $procname $cnam
2bd0: 65 5d 0a 20 20 75 6e 73 65 74 20 74 63 63 28 63  e].  unset tcc(c
2be0: 63 29 20 3b 23 20 63 61 6e 27 74 20 62 65 20 75  c) ;# can't be u
2bf0: 73 65 64 20 66 6f 72 20 63 6f 6d 70 69 6c 69 6e  sed for compilin
2c00: 67 20 61 6e 79 6d 6f 72 65 0a 7d 0a 70 72 6f 63  g anymore.}.proc
2c10: 20 3a 3a 74 63 63 34 74 63 6c 3a 3a 74 6b 20 7b   ::tcc4tcl::tk {
2c20: 61 72 67 73 7d 20 7b 0a 20 20 76 61 72 69 61 62  args} {.  variab
2c30: 6c 65 20 74 63 63 0a 20 20 73 65 74 20 74 63 63  le tcc.  set tcc
2c40: 28 74 6b 29 20 31 0a 7d 0a 3a 3a 74 63 63 34 74  (tk) 1.}.::tcc4t
2c50: 63 6c 3a 3a 72 65 73 65 74 0a 6e 61 6d 65 73 70  cl::reset.namesp
2c60: 61 63 65 20 65 76 61 6c 20 74 63 63 34 74 63 6c  ace eval tcc4tcl
2c70: 20 7b 6e 61 6d 65 73 70 61 63 65 20 65 78 70 6f   {namespace expo
2c80: 72 74 20 63 70 72 6f 63 20 63 63 6f 64 65 20 63  rt cproc ccode c
2c90: 64 61 74 61 7d 0a 0a                             data}..