1## -*- tcl -*- 2# # ## ### ##### ######## ############# ##################### 3# Pragmas for MetaData Scanner. 4# @mdgen OWNER: Config 5# @mdgen OWNER: critcl_c 6# 7# Copyright (c) 2001-20?? Jean-Claude Wippler 8# Copyright (c) 2002-20?? Steve Landers 9# Copyright (c) 20??-2017 Andreas Kupries <andreas_kupries@users.sourceforge.net> 10 11# # ## ### ##### ######## ############# ##################### 12# CriTcl Core. 13 14package provide critcl 3.1.18 15 16namespace eval ::critcl {} 17 18# # ## ### ##### ######## ############# ##################### 19## Requirements. 20 21package require Tcl 8.4 ; # Minimal supported Tcl runtime. 22if {[catch { 23 package require platform 1.0.2 ; # Determine current platform. 24}]} { 25 # Fall back to our internal copy (currently equivalent to platform 26 # 1.0.14(+)) if the environment does not have the official 27 # package. 28 package require critcl::platform 29} elseif { 30 [string match freebsd* [platform::generic]] && 31 ([platform::generic] eq [platform::identify]) 32} { 33 # Again fall back to the internal package if we are on FreeBSD and 34 # the official package does not properly identify the OS ABI 35 # version. 36 package require critcl::platform 37} 38 39# # ## ### ##### ######## ############# ##################### 40# Ensure forward compatibility of commands defined in 8.5+. 41package require lassign84 42package require dict84 43package require lmap84 44 45# # ## ### ##### ######## ############# ##################### 46## Ensure that we have maximal 'info frame' data, if supported 47 48catch { interp debug {} -frame 1 } 49 50# # ## ### ##### ######## ############# ##################### 51# This is the md5 package bundled with critcl. 52# No need to look for fallbacks. 53 54proc ::critcl::md5_hex {s} { 55 if {$v::uuidcounter} { 56 return [format %032d [incr v::uuidcounter]] 57 } 58 package require critcl_md5c 59 binary scan [md5c $s] H* md; return $md 60} 61 62# # ## ### ##### ######## ############# ##################### 63 64if {[package vsatisfies [package present Tcl] 8.5]} { 65 # 8.5+ 66 proc ::critcl::lappendlist {lvar list} { 67 if {![llength $list]} return 68 upvar $lvar dest 69 lappend dest {*}$list 70 return 71 } 72} else { 73 # 8.4 74 proc ::critcl::lappendlist {lvar list} { 75 if {![llength $list]} return 76 upvar $lvar dest 77 set dest [eval [linsert $list 0 linsert $dest end]] 78 #set dest [concat $dest $list] 79 return 80 } 81} 82 83# # ## ### ##### ######## ############# ##################### 84## 85 86proc ::critcl::buildrequirement {script} { 87 # In regular code this does nothing. It is a marker for 88 # the static scanner to change under what key to record 89 # the 'package require' found in the script. 90 uplevel 1 $script 91} 92 93proc ::critcl::TeapotPlatform {} { 94 # Platform identifier HACK. Most of the data in critcl is based on 95 # 'platform::generic'. The TEApot MD however uses 96 # 'platform::identify' with its detail information (solaris kernel 97 # version, linux glibc version). But, if a cross-compile is 98 # running we are SOL, because we have no place to pull the 99 # necessary detail from, 'identify' is a purely local operation :( 100 101 set platform [actualtarget] 102 if {[platform::generic] eq $platform} { 103 set platform [platform::identify] 104 } 105 106 return $platform 107} 108 109proc ::critcl::TeapotRequire {dspec} { 110 # Syntax of dspec: (a) pname 111 # ...: (b) pname req-version... 112 # ...: (c) pname -exact req-version 113 # 114 # We can assume that the syntax is generally ok, because otherwise 115 # the 'package require' itself will fail in a moment, blocking the 116 # further execution of the .critcl file. So we only have to 117 # distinguish the cases. 118 119 if {([llength $dspec] == 3) && 120 ([lindex $dspec 1] eq "-exact")} { 121 # (c) 122 lassign $dspec pn _ pv 123 set spec [list $pn ${pv}-$pv] 124 } else { 125 # (a, b) 126 set spec $dspec 127 } 128 129 return $spec 130} 131 132# # ## ### ##### ######## ############# ##################### 133## Implementation -- API: Embed C Code 134 135proc ::critcl::HeaderLines {text} { 136 if {![regexp {^[\t\n ]+} $text header]} { 137 return [list 0 $text] 138 } 139 set lines [regexp -all {\n} $header] 140 # => The C code begins $lines lines after location of the c** 141 # command. This goes as offset into the generated #line pragma, 142 # because now (see next line) we throw away this leading 143 # whitespace. 144 set text [string trim $text] 145 return [list $lines $text] 146} 147 148proc ::critcl::Lines {text} { 149 set n [regexp -all {\n} $text] 150 return $n 151} 152 153proc ::critcl::ccode {text} { 154 set file [SkipIgnored [This]] 155 HandleDeclAfterBuild 156 CCodeCore $file $text 157 return 158} 159 160proc ::critcl::CCodeCore {file text} { 161 set digest [UUID.extend $file .ccode $text] 162 163 set block {} 164 lassign [HeaderLines $text] leadoffset text 165 if {$v::options(lines)} { 166 append block [at::CPragma $leadoffset -3 $file] 167 } 168 append block $text \n 169 dict update v::code($file) config c { 170 dict lappend c fragments $digest 171 dict set c block $digest $block 172 dict lappend c defs $digest 173 } 174 return 175} 176 177proc ::critcl::ccommand {name anames args} { 178 SkipIgnored [set file [This]] 179 HandleDeclAfterBuild 180 181 # Basic key for the clientdata and delproc arrays. 182 set cname $name[UUID.serial $file] 183 184 if {[llength $args]} { 185 set body [lindex $args 0] 186 set args [lrange $args 1 end] 187 } else { 188 set body {} 189 } 190 191 set clientdata NULL ;# Default: ClientData expression 192 set delproc NULL ;# Default: Function pointer expression 193 set acname 0 194 set tname "" 195 while {[string match "-*" $args]} { 196 switch -- [set opt [lindex $args 0]] { 197 -clientdata { set clientdata [lindex $args 1] } 198 -delproc { set delproc [lindex $args 1] } 199 -cname { set acname [lindex $args 1] } 200 -tracename { set tname [lindex $args 1] } 201 default { 202 error "Unknown option $opt, expected one of -clientdata, -cname, -delproc" 203 } 204 } 205 set args [lrange $args 2 end] 206 } 207 208 # Put body back into args for integration into the MD5 uuid 209 # generated for mode compile&run. Bug and fix reported by Peter 210 # Spjuth. 211 lappend args $body 212 213 if {$acname} { 214 BeginCommand static $name $anames $args 215 set ns {} 216 set cns {} 217 set key $cname 218 set wname $name 219 if {$tname ne {}} { 220 set traceref \"$tname\" 221 } else { 222 set traceref \"$name\" 223 } 224 } else { 225 lassign [BeginCommand public $name $anames $args] ns cns name cname 226 set key [string map {:: _} $ns$cname] 227 set wname tcl_$cns$cname 228 set traceref ns_$cns$cname 229 } 230 231 # XXX clientdata/delproc, either note clashes, or keep information per-file. 232 233 set v::clientdata($key) $clientdata 234 set v::delproc($key) $delproc 235 236 #set body [join $args] 237 if {$body != ""} { 238 lappend anames "" 239 foreach {cd ip oc ov} $anames break 240 if {$cd eq ""} { set cd clientdata } 241 if {$ip eq ""} { set ip interp } 242 if {$oc eq ""} { set oc objc } 243 if {$ov eq ""} { set ov objv } 244 245 set ca "(ClientData $cd, Tcl_Interp *$ip, int $oc, Tcl_Obj *CONST $ov\[])" 246 247 if {$v::options(trace)} { 248 # For ccommand tracing we will emit a shim after the implementation. 249 # Give the implementation a different name. 250 Emitln "static int\n${wname}_actual$ca" 251 } else { 252 Emitln "static int\n$wname$ca" 253 } 254 255 Emit \{\n 256 lassign [HeaderLines $body] leadoffset body 257 if {$v::options(lines)} { 258 Emit [at::CPragma $leadoffset -2 $file] 259 } 260 Emit $body 261 Emitln \n\} 262 263 # Now emit the call to the ccommand tracing shim. It simply 264 # calls the regular implementation and places the tracing 265 # around that. 266 if {$v::options(trace)} { 267 Emitln "\nstatic int\n$wname$ca" 268 Emitln \{ 269 Emitln " int _rv;" 270 Emitln " critcl_trace_cmd_args ($traceref, $oc, $ov);" 271 Emitln " _rv = ${wname}_actual ($cd, $ip, $oc, $ov);" 272 Emitln " return critcl_trace_cmd_result (_rv, $ip);" 273 Emitln \} 274 } 275 } else { 276 # if no body is specified, then $anames is alias for the real cmd proc 277 Emitln "#define $wname $anames" 278 Emitln "int $anames\(\);" 279 } 280 EndCommand 281 return 282} 283 284proc ::critcl::cdata {name data} { 285 SkipIgnored [This] 286 HandleDeclAfterBuild 287 binary scan $data c* bytes ;# split as bytes, not (unicode) chars 288 289 set inittext "" 290 set line "" 291 foreach x $bytes { 292 if {[string length $line] > 70} { 293 append inittext " " $line \n 294 set line "" 295 } 296 append line $x , 297 } 298 append inittext " " $line 299 300 set count [llength $bytes] 301 302 set body [subst [Cat [Template cdata.c]]] 303 # ^=> count, inittext 304 305 # NOTE: The uplevel is needed because otherwise 'ccommand' will 306 # not properly determine the caller's namespace. 307 uplevel 1 [list critcl::ccommand $name {dummy ip objc objv} [at::caller!]$body] 308 return $name 309} 310 311proc ::critcl::cdefines {defines {namespace "::"}} { 312 set file [SkipIgnored [This]] 313 HandleDeclAfterBuild 314 set digest [UUID.extend $file .cdefines [list $defines $namespace]] 315 316 dict update v::code($file) config c { 317 foreach def $defines { 318 dict set c const $def $namespace 319 } 320 } 321 return 322} 323 324proc ::critcl::MakeVariadicTypeFor {type} { 325 # Note: The type "Tcl_Obj*" required special treatment and is 326 # directly defined as a builtin, see 'Initialize'. The has-argtype 327 # check below will prevent us from trying to create something 328 # generic, and wrong. 329 330 set ltype variadic_$type 331 if {![has-argtype $ltype]} { 332 # Generate a type representing a list/array of <type> 333 # elements, plus conversion code. Similar to the 'list' type, 334 # except for custom C types, and conversion assumes variadic, 335 # not single argument. 336 337 # XXXA auto-create derived type from known base types. 338 339 lappend one @@ src 340 lappend one &@A dst 341 lappend one @A *dst 342 lappend one @A. dst-> 343 lappend map @1conv@ [Deline [string map $one [ArgumentConversion $type]]] 344 345 lappend map @type@ [ArgumentCType $type] 346 lappend map @ltype@ $ltype 347 348 argtype $ltype [string map $map { 349 int src, dst, leftovers = @C; 350 @A.c = leftovers; 351 @A.v = (@type@*) ((!leftovers) ? 0 : ckalloc (leftovers * sizeof (@type@))); 352 for (src = @I, dst = 0; leftovers > 0; dst++, src++, leftovers--) { 353 if (_critcl_variadic_@type@_item (interp, ov[src], &(@A.v[dst])) != TCL_OK) { 354 ckfree ((char*) @A.v); /* Cleanup partial work */ 355 return TCL_ERROR; 356 } 357 } 358 }] critcl_$ltype critcl_$ltype 359 360 argtypesupport $ltype [string map $map { 361 /* NOTE: Array 'v' is allocated on the heap. The argument 362 // release code is used to free it after the worker 363 // function returned. Depending on type and what is done 364 // by the worker it may have to make copies of the data. 365 */ 366 367 typedef struct critcl_@ltype@ { 368 int c; /* Element count */ 369 @type@* v; /* Allocated array of the elements */ 370 } critcl_@ltype@; 371 372 static int 373 _critcl_variadic_@type@_item (Tcl_Interp* interp, Tcl_Obj* src, @type@* dst) { 374 @1conv@ 375 return TCL_OK; 376 } 377 }] 378 379 argtyperelease $ltype [string map $map { 380 if (@A.c) { ckfree ((char*) @A.v); } 381 }] 382 } 383 return $ltype 384} 385 386proc ::critcl::ArgsInprocess {adefs skip} { 387 # Convert the regular arg spec from the API into a dictionary 388 # containing all the derived data we need in the various places of 389 # the cproc implementation. 390 391 set db {} 392 393 set names {} ; # list of raw argument names 394 set cnames {} ; # list of C var names for the arguments. 395 set optional {} ; # list of flags signaling optional args. 396 set variadic {} ; # list of flags signaling variadic args. 397 set islast {} ; # list of flags signaling the last arg. 398 set varargs no ; # flag signaling 'args' collector. 399 set defaults {} ; # list of default values. 400 set csig {} ; # C signature of worker function. 401 set tsig {} ; # Tcl signature for frontend/shim command. 402 set vardecls {} ; # C variables for arg conversion in the shim. 403 set support {} ; # Conversion support code for arguments. 404 set has {} ; # Types for which we have emitted the support 405 # code already. (dict: type -> '.' (presence)) 406 set hasopt no ; # Overall flag - Have optionals ... 407 set min 0 ; # Count required args - minimal needed. 408 set max 0 ; # Count all args - maximal allowed. 409 set aconv {} ; # list of the basic argument conversions. 410 set achdr {} ; # list of arg conversion annotations. 411 set arel {} ; # List of arg release code fragments, for those which have them. 412 413 # A 1st argument matching "Tcl_Interp*" does not count as a user 414 # visible command argument. But appears in both signature and 415 # actual list of arguments. 416 if {[lindex $adefs 0] eq "Tcl_Interp*"} { 417 lappend csig [lrange $adefs 0 1] 418 lappend cnames interp;#Fixed name for cproc[lindex $adefs 1] 419 set adefs [lrange $adefs 2 end] 420 } 421 422 set last [expr {[llength $adefs]/2-1}] 423 set current 0 424 425 foreach {t a} $adefs { 426 # t = type 427 # a = name | {name default} 428 429 # Base type support 430 if {![dict exists $has $t]} { 431 dict set has $t . 432 lappend support "[ArgumentSupport $t]" 433 } 434 435 lassign $a name defaultvalue 436 set hasdefault [expr {[llength $a] == 2}] 437 438 lappend islast [expr {$current == $last}] 439 440 # Cases to consider: 441 # 1. 'args' as the last argument, without a default. 442 # 2. Any argument with a default value. 443 # 3. Any argument. 444 445 if {($current == $last) && ($name eq "args") && !$hasdefault} { 446 set hdr " /* ($t $name, ...) - - -- --- ----- -------- */" 447 lappend optional 0 448 lappend variadic 1 449 lappend defaults n/a 450 lappend tsig ?${name}...? 451 set varargs yes 452 set max Inf ; # No limit on the number of args. 453 454 # Dynamically create an arg-type for "variadic list of T". 455 set t [MakeVariadicTypeFor $t] 456 # List support. 457 if {![dict exists $has $t]} { 458 dict set has $t . 459 lappend support "[ArgumentSupport $t]" 460 } 461 462 } elseif {$hasdefault} { 463 incr max 464 set hasopt yes 465 set hdr " /* ($t $name, optional, default $defaultvalue) - - -- --- ----- -------- */" 466 lappend tsig ?${name}? 467 lappend optional 1 468 lappend variadic 0 469 lappend defaults $defaultvalue 470 lappend cnames _has_$name 471 # Argument to signal if the optional argument was set 472 # (true) or is the default (false). 473 lappend csig "int has_$name" 474 lappend vardecls "int _has_$name = 0;" 475 476 } else { 477 set hdr " /* ($t $name) - - -- --- ----- -------- */" 478 lappend tsig $name 479 incr max 480 incr min 481 lappend optional 0 482 lappend variadic 0 483 lappend defaults n/a 484 } 485 486 lappend achdr $hdr 487 lappend csig "[ArgumentCTypeB $t] $name" 488 lappend vardecls "[ArgumentCType $t] _$name;" 489 490 lappend names $name 491 lappend cnames _$name 492 lappend aconv [TraceReturns "\"$t\" argument" [ArgumentConversion $t]] 493 494 set rel [ArgumentRelease $t] 495 if {$rel ne {}} { 496 set rel [string map [list @A _$name] $rel] 497 set hdr [string map {( {(Release: }} $hdr] 498 lappend arel "$hdr$rel" 499 } 500 501 incr current 502 } 503 504 set thresholds {} 505 if {$hasopt} { 506 # Compute thresholds for optional arguments. The threshold T 507 # of an optional argument A is the number of required 508 # arguments _after_ A. If during arg processing more than T 509 # arguments are left then A can take the current word, 510 # otherwise A is left to its default. We compute them from the 511 # end. 512 set t 0 513 foreach o [lreverse $optional] { 514 if {$o} { 515 lappend thresholds $t 516 } else { 517 lappend thresholds - 518 incr t 519 } 520 } 521 set thresholds [lreverse $thresholds] 522 } 523 524 set tsig [join $tsig { }] 525 if {$tsig eq {}} { 526 set tsig NULL 527 } else { 528 set tsig \"$tsig\" 529 } 530 531 # Generate code for wrong#args checking, based on the collected 532 # min/max information. Cases to consider: 533 # 534 # a. max == Inf && min == 0 <=> All argc allowed. 535 # b. max == Inf && min > 0 <=> Fail argc < min. 536 # c. max < Inf && min == max <=> Fail argc != min. 537 # d. max < Inf && min < max <=> Fail argc < min || max < argc 538 539 if {$max == Inf} { 540 # a, b 541 if {!$min} { 542 # a: nothing to check. 543 set wacondition {} 544 } else { 545 # b: argc < min 546 set wacondition {oc < MIN_ARGS} 547 } 548 } else { 549 # c, d 550 if {$min == $max} { 551 # c: argc != min 552 set wacondition {oc != MIN_ARGS} 553 } else { 554 # d: argc < min || max < argc 555 set wacondition {(oc < MIN_ARGS) || (MAX_ARGS < oc)} 556 } 557 } 558 559 # Generate conversion code for arguments. Use the threshold 560 # information to handle optional arguments at all positions. 561 # The code is executed after the wrong#args check. 562 # That means we have at least 'min' arguments, enough to fill 563 # all the required parameters. 564 565 set map {} 566 set conv {} 567 set opt no 568 set idx $skip 569 set prefix " idx_ = $idx;" ; # Start at skip offset! 570 append prefix "\n argc_ = oc - $idx;" 571 foreach \ 572 name $names \ 573 t $thresholds \ 574 o $optional \ 575 v $variadic \ 576 l $islast \ 577 h $achdr \ 578 c $aconv \ 579 d $defaults { 580 581 # Things to consider: 582 # 1. Required variables at the beginning. 583 # We can access these using fixed indices. 584 # 2. Any other variable require access using a dynamic index 585 # (idx_). During (1) we maintain the code initializing 586 # this. 587 588 set useindex [expr {!$l}] ;# last arg => no need for idx/argc updates 589 590 if {$v} { 591 # Variadic argument. Can only be last. 592 # opt => dynamic access at idx_..., collect argc_ 593 # !opt => static access at $idx ..., collect oc-$idx 594 595 unset map 596 lappend map @A _$name 597 if {$opt} { 598 lappend map @I idx_ @C argc_ 599 } else { 600 lappend map @I $idx @C (oc-$idx) 601 } 602 603 set c [string map $map $c] 604 605 lappend conv $h 606 lappend conv $c 607 lappend conv {} 608 lappend conv {} 609 break 610 } 611 612 if {$o} { 613 # Optional argument. Anywhere. Check threshold. 614 615 unset map 616 lappend map @@ "ov\[idx_\]" 617 lappend map @A _$name 618 619 set c [string map $map $c] 620 621 if {$prefix ne {}} { lappend conv $prefix\n } 622 lappend conv $h 623 lappend conv " if (argc_ > $t) \{" 624 lappend conv $c 625 if {$useindex} { 626 lappend conv " idx_++;" 627 lappend conv " argc_--;" 628 } 629 lappend conv " _has_$name = 1;" 630 lappend conv " \} else \{" 631 lappend conv " _$name = $d;" 632 lappend conv " \}" 633 lappend conv {} 634 lappend conv {} 635 636 set prefix {} 637 set opt yes 638 continue 639 } 640 641 if {$opt} { 642 # Required argument, after one or more optional arguments 643 # were processed. Access to current word is dynamic. 644 645 unset map 646 lappend map @@ "ov\[idx_\]" 647 lappend map @A _$name 648 649 set c [string map $map $c] 650 651 lappend conv $h 652 lappend conv $c 653 lappend conv {} 654 if {$useindex} { 655 lappend conv " idx_++;" 656 lappend conv " argc_--;" 657 } 658 lappend conv {} 659 lappend conv {} 660 continue 661 } 662 663 # Required argument. No optionals processed yet. Access to 664 # current word is via static index. 665 666 unset map 667 lappend map @@ "ov\[$idx\]" 668 lappend map @A _$name 669 670 set c [string map $map $c] 671 672 lappend conv $h 673 lappend conv $c 674 lappend conv {} 675 lappend conv {} 676 677 incr idx 678 set prefix " idx_ = $idx;" 679 append prefix "\n argc_ = oc - $idx;" 680 } 681 set conv [Deline [join $conv \n]] 682 683 # Save results ... 684 685 dict set db skip $skip 686 dict set db aconv $conv 687 dict set db arelease $arel 688 dict set db thresholds $thresholds 689 dict set db wacondition $wacondition 690 dict set db min $min 691 dict set db max $max 692 dict set db tsignature $tsig 693 dict set db names $names 694 dict set db cnames $cnames 695 dict set db optional $optional 696 dict set db variadic $variadic 697 dict set db islast $islast 698 dict set db defaults $defaults 699 dict set db varargs $varargs 700 dict set db csignature $csig 701 dict set db vardecls $vardecls 702 dict set db support $support 703 dict set db hasoptional $hasopt 704 705 #puts ___________________________________________________________|$adefs 706 #array set __ $db ; parray __ 707 #puts _______________________________________________________________\n 708 return $db 709} 710 711proc ::critcl::argoptional {adefs} { 712 set optional {} 713 714 # A 1st argument matching "Tcl_Interp*" does not count as a user 715 # visible command argument. 716 if {[lindex $adefs 0] eq "Tcl_Interp*"} { 717 set adefs [lrange $adefs 2 end] 718 } 719 720 foreach {t a} $adefs { 721 if {[llength $a] == 2} { 722 lappend optional 1 723 } else { 724 lappend optional 0 725 } 726 } 727 728 return $optional 729} 730 731proc ::critcl::argdefaults {adefs} { 732 set defaults {} 733 734 # A 1st argument matching "Tcl_Interp*" does not count as a user 735 # visible command argument. 736 if {[lindex $adefs 0] eq "Tcl_Interp*"} { 737 set adefs [lrange $adefs 2 end] 738 } 739 740 foreach {t a} $adefs { 741 if {[llength $a] == 2} { 742 lappend defaults [lindex $a 1] 743 } 744 } 745 746 return $defaults 747} 748 749proc ::critcl::argnames {adefs} { 750 set names {} 751 752 # A 1st argument matching "Tcl_Interp*" does not count as a user 753 # visible command argument. 754 if {[lindex $adefs 0] eq "Tcl_Interp*"} { 755 set adefs [lrange $adefs 2 end] 756 } 757 758 foreach {t a} $adefs { 759 if {[llength $a] == 2} { 760 set a [lindex $a 0] 761 } 762 lappend names $a 763 } 764 765 return $names 766} 767 768proc ::critcl::argcnames {adefs {interp ip}} { 769 set cnames {} 770 771 if {[lindex $adefs 0] eq "Tcl_Interp*"} { 772 lappend cnames interp 773 set adefs [lrange $adefs 2 end] 774 } 775 776 foreach {t a} $adefs { 777 if {[llength $a] == 2} { 778 set a [lindex $a 0] 779 lappend cnames _has_$a 780 } 781 lappend cnames _$a 782 } 783 784 return $cnames 785} 786 787proc ::critcl::argcsignature {adefs} { 788 # Construct the signature of the low-level C function. 789 790 set cargs {} 791 792 # If the 1st argument is "Tcl_Interp*", we pass it without 793 # counting it as a command argument. 794 795 if {[lindex $adefs 0] eq "Tcl_Interp*"} { 796 lappend cargs [lrange $adefs 0 1] 797 set adefs [lrange $adefs 2 end] 798 } 799 800 foreach {t a} $adefs { 801 if {[llength $a] == 2} { 802 set a [lindex $a 0] 803 # Argument to signal if the optional argument was set 804 # (true) or is the default (false). 805 lappend cargs "int has_$a" 806 } 807 lappend cargs "[ArgumentCTypeB $t] $a" 808 } 809 810 return $cargs 811} 812 813proc ::critcl::argvardecls {adefs} { 814 # Argument variables, destinations for the Tcl -> C conversion. 815 816 # A 1st argument matching "Tcl_Interp*" does not count as a user 817 # visible command argument. 818 if {[lindex $adefs 0] eq "Tcl_Interp*"} { 819 set adefs [lrange $adefs 2 end] 820 } 821 822 set result {} 823 foreach {t a} $adefs { 824 if {[llength $a] == 2} { 825 set a [lindex $a 0] 826 lappend result "[ArgumentCType $t] _$a;\n int _has_$a = 0;" 827 } else { 828 lappend result "[ArgumentCType $t] _$a;" 829 } 830 } 831 832 return $result 833} 834 835proc ::critcl::argsupport {adefs} { 836 # Argument global support, outside/before function. 837 838 # A 1st argument matching "Tcl_Interp*" does not count as a user 839 # visible command argument. 840 if {[lindex $adefs 0] eq "Tcl_Interp*"} { 841 set adefs [lrange $adefs 2 end] 842 } 843 844 set has {} 845 846 set result {} 847 foreach {t a} $adefs { 848 if {[lsearch -exact $has $t] >= 0} continue 849 lappend has $t 850 lappend result "[ArgumentSupport $t]" 851 } 852 853 return $result 854} 855 856proc ::critcl::argconversion {adefs {n 1}} { 857 # A 1st argument matching "Tcl_Interp*" does not count as a user 858 # visible command argument. 859 if {[lindex $adefs 0] eq "Tcl_Interp*"} { 860 set adefs [lrange $adefs 2 end] 861 } 862 863 set min $n ; # count all non-optional arguments. min required. 864 foreach {t a} $adefs { 865 if {[llength $a] == 2} continue 866 incr min 867 } 868 869 set result {} 870 set opt 0 871 set prefix " idx_ = $n;\n" 872 873 foreach {t a} $adefs { 874 if {[llength $a] == 2} { 875 # Optional argument. Can be first, or later. 876 # For the first the prefix gives us the code to initialize idx_. 877 878 lassign $a a default 879 880 set map [list @@ "ov\[idx_\]" @A _$a] 881 set code [string map $map [ArgumentConversion $t]] 882 883 set code "${prefix} if (oc > $min) \{\n$code\n idx_++;\n _has_$a = 1;\n \} else \{\n _$a = $default;\n \}" 884 incr min 885 886 lappend result " /* ($t $a, optional, default $default) - - -- --- ----- -------- */" 887 lappend result $code 888 lappend result {} 889 set opt 1 890 set prefix "" 891 } elseif {$opt} { 892 # Fixed argument, after the optionals. 893 # Main issue: Use idx_ to access the array. 894 # We know that no optionals can follow, only the same. 895 896 set map [list @@ "ov\[idx_\]" @A _$a] 897 lappend result " /* ($t $a) - - -- --- ----- -------- */" 898 lappend result [string map $map [ArgumentConversion $t]] 899 lappend result " idx_++;" 900 lappend result {} 901 902 } else { 903 # Fixed argument, before any optionals. 904 set map [list @@ "ov\[$n\]" @A _$a] 905 lappend result " /* ($t $a) - - -- --- ----- -------- */" 906 lappend result [string map $map [ArgumentConversion $t]] 907 lappend result {} 908 incr n 909 set prefix " idx_ = $n;\n" 910 } 911 } 912 913 return [Deline $result] 914} 915 916proc ::critcl::has-argtype {name} { 917 variable v::aconv 918 return [info exists aconv($name)] 919} 920 921proc ::critcl::argtype-def {name} { 922 lappend def [ArgumentCType $name] 923 lappend def [ArgumentCTypeB $name] 924 lappend def [ArgumentConversion $name] 925 lappend def [ArgumentRelease $name] 926 lappend def [ArgumentSupport $name] 927 return $def 928} 929 930proc ::critcl::argtype {name conversion {ctype {}} {ctypeb {}}} { 931 variable v::actype 932 variable v::actypeb 933 variable v::aconv 934 variable v::acrel 935 variable v::acsup 936 937 # ctype Type of variable holding the argument. 938 # ctypeb Type of formal C function argument. 939 940 # Handle aliases by copying the original definition. 941 if {$conversion eq "="} { 942 # XXXA auto-create derived type from known base types. 943 944 if {![info exists aconv($ctype)]} { 945 return -code error "Unable to alias unknown type '$ctype'." 946 } 947 948 # Do not forget to copy support and release code, if present. 949 if {[info exists acsup($ctype)]} { 950 #puts COPY/S:$ctype 951 set acsup($name) $acsup($ctype) 952 } 953 if {[info exists acrel($ctype)]} { 954 #puts COPY/R:$ctype 955 set acrel($name) $acrel($ctype) 956 } 957 958 set conversion $aconv($ctype) 959 set ctypeb $actypeb($ctype) 960 set ctype $actype($ctype) 961 } else { 962 lassign [HeaderLines $conversion] leadoffset conversion 963 set conversion "\t\{\n[at::caller! $leadoffset]\t[string trim $conversion] \}" 964 } 965 if {$ctype eq {}} { 966 set ctype $name 967 } 968 if {$ctypeb eq {}} { 969 set ctypeb $name 970 } 971 972 if {[info exists aconv($name)] && 973 (($aconv($name) ne $conversion) || 974 ($actype($name) ne $ctype) || 975 ($actypeb($name) ne $ctypeb)) 976 } { 977 return -code error "Illegal duplicate definition of '$name'." 978 } 979 980 set aconv($name) $conversion 981 set actype($name) $ctype 982 set actypeb($name) $ctypeb 983 return 984} 985 986proc ::critcl::argtypesupport {name code {guard {}}} { 987 variable v::aconv 988 variable v::acsup 989 if {![info exists aconv($name)]} { 990 return -code error "No definition for '$name'." 991 } 992 if {$guard eq {}} { 993 set guard $name ; # Handle non-identifier chars! 994 } 995 lappend lines "#ifndef CRITCL_$guard" 996 lappend lines "#define CRITCL_$guard" 997 lappend lines $code 998 lappend lines "#endif /* CRITCL_$guard _________ */" 999 set support [join $lines \n]\n 1000 1001 if {[info exists acsup($name)] && 1002 ($acsup($name) ne $support) 1003 } { 1004 return -code error "Illegal duplicate support of '$name'." 1005 } 1006 1007 set acsup($name) $support 1008 return 1009} 1010 1011proc ::critcl::argtyperelease {name code} { 1012 variable v::aconv 1013 variable v::acrel 1014 if {![info exists aconv($name)]} { 1015 return -code error "No definition for '$name'." 1016 } 1017 if {[info exists acrel($name)] && 1018 ($acrel($name) ne $code) 1019 } { 1020 return -code error "Illegal duplicate release of '$name'." 1021 } 1022 1023 set acrel($name) $code 1024 return 1025} 1026 1027proc ::critcl::has-resulttype {name} { 1028 variable v::rconv 1029 return [info exists rconv($name)] 1030} 1031 1032proc ::critcl::resulttype {name conversion {ctype {}}} { 1033 variable v::rctype 1034 variable v::rconv 1035 1036 # Handle aliases by copying the original definition. 1037 if {$conversion eq "="} { 1038 if {![info exists rconv($ctype)]} { 1039 return -code error "Unable to alias unknown type '$ctype'." 1040 } 1041 set conversion $rconv($ctype) 1042 set ctype $rctype($ctype) 1043 } else { 1044 lassign [HeaderLines $conversion] leadoffset conversion 1045 set conversion [at::caller! $leadoffset]\t[string trimright $conversion] 1046 } 1047 if {$ctype eq {}} { 1048 set ctype $name 1049 } 1050 1051 if {[info exists rconv($name)] && 1052 (($rconv($name) ne $conversion) || 1053 ($rctype($name) ne $ctype)) 1054 } { 1055 return -code error "Illegal duplicate definition of '$name'." 1056 } 1057 1058 set rconv($name) $conversion 1059 set rctype($name) $ctype 1060 return 1061} 1062 1063proc ::critcl::cconst {name rtype rvalue} { 1064 # The semantics are equivalent to 1065 # 1066 # cproc $name {} $rtype { return $rvalue ; } 1067 # 1068 # The main feature of this new command is the knowledge of a 1069 # constant return value, which allows the optimization of the 1070 # generated code. Only the shim is emitted, with the return value 1071 # in place. No need for a lower-level C function containing a 1072 # function body. 1073 1074 SkipIgnored [set file [This]] 1075 HandleDeclAfterBuild 1076 1077 # A void result does not make sense for constants. 1078 if {$rtype eq "void"} { 1079 error "Constants cannot be of type \"void\"" 1080 } 1081 1082 lassign [BeginCommand public $name $rtype $rvalue] ns cns name cname 1083 set traceref ns_$cns$cname 1084 set wname tcl_$cns$cname 1085 set cname c_$cns$cname 1086 1087 # Construct the shim handling the conversion between Tcl and C 1088 # realms. 1089 1090 set adb [ArgsInprocess {} 1] 1091 1092 EmitShimHeader $wname 1093 EmitShimVariables $adb $rtype 1094 EmitArgTracing $traceref 1095 EmitWrongArgsCheck $adb 1096 EmitConst $rtype $rvalue 1097 EmitShimFooter $adb $rtype 1098 EndCommand 1099 return 1100} 1101 1102proc ::critcl::CheckForTracing {} { 1103 if {!$v::options(trace)} return 1104 if {[info exists ::critcl::v::__trace__]} return 1105 1106 package require critcl::cutil 1107 ::critcl::cutil::tracer on 1108 set ::critcl::v::__trace__ marker ;# See above 1109 return 1110} 1111 1112proc ::critcl::cproc {name adefs rtype {body "#"} args} { 1113 SkipIgnored [set file [This]] 1114 HandleDeclAfterBuild 1115 CheckForTracing 1116 1117 set acname 0 1118 set passcd 0 1119 set aoffset 0 1120 set tname "" 1121 while {[string match "-*" $args]} { 1122 switch -- [set opt [lindex $args 0]] { 1123 -cname { set acname [lindex $args 1] } 1124 -pass-cdata { set passcd [lindex $args 1] } 1125 -arg-offset { set aoffset [lindex $args 1] } 1126 -tracename { set tname [lindex $args 1] } 1127 default { 1128 error "Unknown option $opt, expected one of -cname, or -pass-cdata" 1129 } 1130 } 1131 set args [lrange $args 2 end] 1132 } 1133 1134 # XXXA auto-create derived type from known base types. 1135 1136 incr aoffset ; # always include the command name. 1137 set adb [ArgsInprocess $adefs $aoffset] 1138 1139 if {$acname} { 1140 BeginCommand static $name $adefs $rtype $body 1141 set ns {} 1142 set cns {} 1143 set wname $name 1144 set cname c_$name 1145 if {$tname ne {}} { 1146 set traceref \"$tname\" 1147 } else { 1148 set traceref \"$name\" 1149 } 1150 } else { 1151 lassign [BeginCommand public $name $adefs $rtype $body] ns cns name cname 1152 set traceref ns_$cns$cname 1153 set wname tcl_$cns$cname 1154 set cname c_$cns$cname 1155 } 1156 1157 set names [dict get $adb names] 1158 set cargs [dict get $adb csignature] 1159 set cnames [dict get $adb cnames] 1160 1161 if {$passcd} { 1162 set cargs [linsert $cargs 0 {ClientData clientdata}] 1163 set cnames [linsert $cnames 0 cd] 1164 } 1165 1166 # Support code for argument conversions (i.e. structures, helper 1167 # functions, etc. ...) 1168 EmitSupport $adb 1169 1170 # Emit either the low-level function, or, if it wasn't defined 1171 # here, a reference to the shim we can use. 1172 1173 if {$body ne "#"} { 1174 Emit "static [ResultCType $rtype] " 1175 Emitln "${cname}([join $cargs {, }])" 1176 Emit \{\n 1177 lassign [HeaderLines $body] leadoffset body 1178 if {$v::options(lines)} { 1179 Emit [at::CPragma $leadoffset -2 $file] 1180 } 1181 Emit $body 1182 Emitln \n\} 1183 } else { 1184 Emitln "#define $cname $name" 1185 } 1186 1187 # Construct the shim handling the conversion between Tcl and C 1188 # realms. 1189 1190 EmitShimHeader $wname 1191 EmitShimVariables $adb $rtype 1192 EmitArgTracing $traceref 1193 EmitWrongArgsCheck $adb 1194 Emit [dict get $adb aconv] 1195 EmitCall $cname $cnames $rtype 1196 EmitShimFooter $adb $rtype 1197 EndCommand 1198 return 1199} 1200 1201proc ::critcl::cinit {text edecls} { 1202 set file [SkipIgnored [set file [This]]] 1203 HandleDeclAfterBuild 1204 CInitCore $file $text $edecls 1205 return 1206} 1207 1208proc ::critcl::CInitCore {file text edecls} { 1209 set digesta [UUID.extend $file .cinit.f $text] 1210 set digestb [UUID.extend $file .cinit.e $edecls] 1211 1212 set initc {} 1213 set skip [Lines $text] 1214 lassign [HeaderLines $text] leadoffset text 1215 if {$v::options(lines)} { 1216 append initc [at::CPragma $leadoffset -2 $file] 1217 } 1218 append initc $text \n 1219 1220 set edec {} 1221 lassign [HeaderLines $edecls] leadoffset edecls 1222 if {$v::options(lines)} { 1223 incr leadoffset $skip 1224 append edec [at::CPragma $leadoffset -2 $file] 1225 } 1226 append edec $edecls \n 1227 1228 dict update v::code($file) config c { 1229 dict append c initc $initc \n 1230 dict append c edecls $edec \n 1231 } 1232 return 1233} 1234 1235# # ## ### ##### ######## ############# ##################### 1236## Public API to code origin handling. 1237 1238namespace eval ::critcl::at { 1239 namespace export caller caller! here here! get get* incr incrt = 1240 catch { namespace ensemble create } 1241} 1242 1243# caller - stash caller location, possibly modified (level change, line offset) 1244# caller! - format & return caller location, clears stash 1245# here - stash current location 1246# here! - return format & return current location, clears stash 1247# incr* - modify stashed location (only line number, not file). 1248# get - format, return, and clear stash 1249# get* - format & return stash 1250 1251proc ::critcl::at::caller {{off 0} {level 0}} { 1252 ::incr level -3 1253 Where $off $level [::critcl::This] 1254 return 1255} 1256 1257proc ::critcl::at::caller! {{off 0} {level 0}} { 1258 ::incr level -3 1259 Where $off $level [::critcl::This] 1260 return [get] 1261} 1262 1263proc ::critcl::at::here {} { 1264 Where 0 -2 [::critcl::This] 1265 return 1266} 1267 1268proc ::critcl::at::here! {} { 1269 Where 0 -2 [::critcl::This] 1270 return [get] 1271} 1272 1273proc ::critcl::at::get {} { 1274 variable where 1275 if {!$::critcl::v::options(lines)} { 1276 return {} 1277 } 1278 if {![info exists where]} { 1279 return -code error "No location defined" 1280 } 1281 set result [Format $where] 1282 unset where 1283 return $result 1284} 1285 1286proc ::critcl::at::get* {} { 1287 variable where 1288 if {!$::critcl::v::options(lines)} { 1289 return {} 1290 } 1291 if {![info exists where]} { 1292 return -code error "No location defined" 1293 } 1294 return [Format $where] 1295} 1296 1297proc ::critcl::at::= {file line} { 1298 variable where 1299 set where [list $file $line] 1300 return 1301} 1302 1303proc ::critcl::at::incr {args} { 1304 variable where 1305 lassign $where file line 1306 foreach offset $args { 1307 ::incr line $offset 1308 } 1309 set where [list $file $line] 1310 return 1311} 1312 1313proc ::critcl::at::incrt {args} { 1314 variable where 1315 if {$where eq {}} { 1316 return -code error "No location to change" 1317 } 1318 lassign $where file line 1319 foreach text $args { 1320 ::incr line [::critcl::Lines $text] 1321 } 1322 set where [list $file $line] 1323 return 1324} 1325 1326# # ## ### ##### ######## ############# ##################### 1327## Implementation -- API: Input and Output control 1328 1329proc ::critcl::collect {script {slot {}}} { 1330 collect_begin $slot 1331 uplevel 1 $script 1332 return [collect_end] 1333} 1334 1335proc ::critcl::collect_begin {{slot {}}} { 1336 # Divert the collection of code fragments to slot 1337 # (output control). Stack on any previous diversion. 1338 variable v::this 1339 # See critcl::This for where this information is injected into the 1340 # code generation system. 1341 1342 if {$slot eq {}} { 1343 set slot MEMORY[expr { [info exists this] 1344 ? [llength $this] 1345 : 0 }] 1346 } 1347 # Prefix prevents collision of slot names and file paths. 1348 lappend this critcl://$slot 1349 return 1350} 1351 1352proc ::critcl::collect_end {} { 1353 # Stop last diversion, and return the collected information as 1354 # single string of C code. 1355 variable v::this 1356 # See critcl::This for where this information is injected into the 1357 # code generation system. 1358 1359 # Ensure that a diversion is actually open. 1360 if {![info exists this] || ![llength $this]} { 1361 return -code error "collect_end mismatch, no diversions active" 1362 } 1363 1364 set slot [Dpop] 1365 set block {} 1366 1367 foreach digest [dict get $v::code($slot) config fragments] { 1368 append block "[Separator]\n\n" 1369 append block [dict get $v::code($slot) config block $digest]\n 1370 } 1371 1372 # Drop all the collected data. Note how anything other than the C 1373 # code fragments is lost, and how cbuild results are removed 1374 # also. These do not belong anyway. 1375 unset v::code($slot) 1376 1377 return $block 1378} 1379 1380 1381proc ::critcl::Dpop {} { 1382 variable v::this 1383 1384 # Get current slot, and pop from the diversion stack. 1385 # Remove stack when it becomes empty. 1386 set slot [lindex $this end] 1387 set v::this [lrange $this 0 end-1] 1388 if {![llength $this]} { 1389 unset this 1390 } 1391 return $slot 1392} 1393 1394proc ::critcl::include {path args} { 1395 # Include headers or other C files into the current code. 1396 set args [linsert $args 0 $path] 1397 msg -nonewline " (include <[join $args ">) (include <"]>)" 1398 ccode "#include <[join $args ">\n#include <"]>" 1399} 1400 1401proc ::critcl::make {path contents} { 1402 # Generate a header or other C file for pickup by other parts of 1403 # the current package. Stored in the cache dir, making it local. 1404 file mkdir [cache] 1405 set cname [file join [cache] $path] 1406 1407 set c [open $cname.[pid] w] 1408 puts -nonewline $c $contents\n\n 1409 close $c 1410 file rename -force $cname.[pid] $cname 1411 1412 return $path 1413} 1414 1415proc ::critcl::source {path} { 1416 # Source a critcl file in the context of the current file, 1417 # i.e. [This]. Enables the factorization of a large critcl 1418 # file into smaller, easier to read pieces. 1419 SkipIgnored [set file [This]] 1420 HandleDeclAfterBuild 1421 1422 msg -nonewline " (importing $path)" 1423 1424 set undivert 0 1425 variable v::this 1426 if {![info exists this] || ![llength $this]} { 1427 # critcl::source is recording the critcl commands in the 1428 # context of the toplevel file which started the chain the 1429 # critcl::source. So why are we twiddling with the diversion 1430 # state? 1431 # 1432 # The condition above tells us that we are in the first 1433 # non-diverted critcl::source called by the context. [This] 1434 # returns that context. Due to our use of regular 'source' (*) 1435 # during its execution [This] would return the sourced file as 1436 # context. Wrong. Our fix for this is to perform, essentially, 1437 # an anti-diversion. Saving [This] as diversion, forces it to 1438 # return the proper value during the whole sourcing. 1439 # 1440 # And if the critcl::source is run in an already diverted 1441 # context then the changes to [info script] by 'source' do not 1442 # matter, making an anti-diversion unnecessary. 1443 # 1444 # Diversions inside of 'source' will work as usual, given 1445 # their nesting nature. 1446 # 1447 # (Ad *) And we use 'source' as only this ensures proper 1448 # collection of [info frame] location information. 1449 1450 lappend this [This] 1451 set undivert 1 1452 } 1453 1454 foreach f [Expand $file $path] { 1455 set v::source $f 1456 # The source file information is used by critcl::at::Where 1457 #uplevel 1 [Cat $f] 1458 uplevel #0 [list ::source $f] 1459 unset -nocomplain v::source 1460 } 1461 1462 if {$undivert} Dpop 1463 return 1464} 1465 1466# # ## ### ##### ######## ############# ##################### 1467## Implementation -- API: Control & Interface 1468 1469proc ::critcl::owns {args} {} 1470 1471proc ::critcl::cheaders {args} { 1472 SkipIgnored [This] 1473 HandleDeclAfterBuild 1474 return [SetParam cheaders $args] 1475} 1476 1477proc ::critcl::csources {args} { 1478 SkipIgnored [This] 1479 HandleDeclAfterBuild 1480 return [SetParam csources $args 1 1 1] 1481} 1482 1483proc ::critcl::clibraries {args} { 1484 SkipIgnored [This] 1485 HandleDeclAfterBuild 1486 return [SetParam clibraries $args] 1487} 1488 1489proc ::critcl::cobjects {args} { 1490 SkipIgnored [This] 1491 HandleDeclAfterBuild 1492 return [SetParam cobjects $args] 1493} 1494 1495proc ::critcl::tsources {args} { 1496 set file [SkipIgnored [This]] 1497 HandleDeclAfterBuild 1498 # This, 'license', 'meta?' and 'meta' are the only places where we 1499 # are not extending the UUID. Because the companion Tcl sources 1500 # (count, order, and content) have no bearing on the binary at 1501 # all. 1502 InitializeFile $file 1503 1504 set dfiles {} 1505 dict update v::code($file) config c { 1506 foreach f $args { 1507 foreach e [Expand $file $f] { 1508 dict lappend c tsources $e 1509 lappend dfiles $e 1510 } 1511 } 1512 } 1513 # Attention: The actual scanning is done outside of the `dict 1514 # update`, because it makes changes to the dictionary which would 1515 # be revert on exiting the update. 1516 foreach e $dfiles { 1517 ScanDependencies $file $e 1518 } 1519 return 1520} 1521 1522proc ::critcl::cflags {args} { 1523 set file [SkipIgnored [This]] 1524 HandleDeclAfterBuild 1525 if {![llength $args]} return 1526 CFlagsCore $file $args 1527 return 1528} 1529 1530proc ::critcl::CFlagsCore {file flags} { 1531 UUID.extend $file .cflags $flags 1532 dict update v::code($file) config c { 1533 foreach flag $flags { 1534 dict lappend c cflags $flag 1535 } 1536 } 1537 return 1538} 1539 1540proc ::critcl::ldflags {args} { 1541 set file [SkipIgnored [This]] 1542 HandleDeclAfterBuild 1543 if {![llength $args]} return 1544 1545 UUID.extend $file .ldflags $args 1546 dict update v::code($file) config c { 1547 foreach flag $args { 1548 # Drop any -Wl prefix which will be added back a moment 1549 # later, otherwise it would be doubled, breaking the command. 1550 regsub -all {^-Wl,} $flag {} flag 1551 dict lappend c ldflags -Wl,$flag 1552 } 1553 } 1554 return 1555} 1556 1557proc ::critcl::framework {args} { 1558 SkipIgnored [This] 1559 HandleDeclAfterBuild 1560 1561 # Check if we are building for OSX and ignore the command if we 1562 # are not. Our usage of "actualtarget" means that we allow for a 1563 # cross-compilation environment to OS X as well. 1564 if {![string match "macosx*" [actualtarget]]} return 1565 1566 foreach arg $args { 1567 # if an arg contains a slash it must be a framework path 1568 if {[string first / $arg] == -1} { 1569 ldflags -framework $arg 1570 } else { 1571 cflags -F$arg 1572 ldflags -F$arg 1573 } 1574 } 1575 return 1576} 1577 1578proc ::critcl::tcl {version} { 1579 set file [SkipIgnored [This]] 1580 HandleDeclAfterBuild 1581 1582 UUID.extend $file .mintcl $version 1583 dict set v::code($file) config mintcl $version 1584 1585 # This is also a dependency to record in the meta data. A 'package 1586 # require' is not needed. This can be inside of the generated and 1587 # loaded C code. 1588 1589 ImetaAdd $file require [list [list Tcl $version]] 1590 return 1591} 1592 1593proc ::critcl::tk {} { 1594 set file [SkipIgnored [This]] 1595 HandleDeclAfterBuild 1596 1597 UUID.extend $file .tk 1 1598 dict set v::code($file) config tk 1 1599 1600 # This is also a dependency to record in the meta data. A 'package 1601 # require' is not needed. This can be inside of the generated and 1602 # loaded C code. 1603 1604 ImetaAdd $file require Tk 1605 return 1606} 1607 1608# Register a shared library for pre-loading - this will eventually be 1609# redundant when TIP #239 is widely available 1610proc ::critcl::preload {args} { 1611 set file [SkipIgnored [This]] 1612 HandleDeclAfterBuild 1613 if {![llength $args]} return 1614 1615 UUID.extend $file .preload $args 1616 dict update v::code($file) config c { 1617 foreach lib $args { 1618 dict lappend c preload $lib 1619 } 1620 } 1621 return 1622} 1623 1624proc ::critcl::license {who args} { 1625 set file [SkipIgnored [This]] 1626 HandleDeclAfterBuild 1627 1628 set who [string trim $who] 1629 if {$who ne ""} { 1630 set license "This software is copyrighted by $who.\n" 1631 } else { 1632 set license "" 1633 } 1634 1635 set elicense [LicenseText $args] 1636 1637 append license $elicense 1638 1639 # This, 'tsources', 'meta?', and 'meta' are the only places where 1640 # we are not extending the UUID. Because the license text has no 1641 # bearing on the binary at all. 1642 InitializeFile $file 1643 1644 ImetaSet $file license [Text2Words $elicense] 1645 ImetaSet $file author [Text2Authors $who] 1646 return 1647} 1648 1649proc ::critcl::LicenseText {words} { 1650 if {[llength $words]} { 1651 # Use the supplied license details as our suffix. 1652 return [join $words] 1653 } else { 1654 # No details were supplied, fall back to the critcl license as 1655 # template for the generated package. This is found in a 1656 # sibling of this file. 1657 1658 # We strip the first 2 lines from the file, this gets rid of 1659 # the author information for critcl itself, allowing us to 1660 # replace it by the user-supplied author. 1661 1662 variable mydir 1663 set f [file join $mydir license.terms] 1664 return [join [lrange [split [Cat $f] \n] 2 end] \n] 1665 } 1666} 1667 1668# # ## ### ##### ######## ############# ##################### 1669## Implementation -- API: meta data (teapot) 1670 1671proc ::critcl::description {text} { 1672 set file [SkipIgnored [This]] 1673 HandleDeclAfterBuild 1674 InitializeFile $file 1675 1676 ImetaSet $file description [Text2Words $text] 1677 return 1678} 1679 1680proc ::critcl::summary {text} { 1681 set file [SkipIgnored [This]] 1682 HandleDeclAfterBuild 1683 InitializeFile $file 1684 1685 ImetaSet $file summary [Text2Words $text] 1686 return 1687} 1688 1689proc ::critcl::subject {args} { 1690 set file [SkipIgnored [This]] 1691 HandleDeclAfterBuild 1692 InitializeFile $file 1693 1694 ImetaAdd $file subject $args 1695 return 1696} 1697 1698proc ::critcl::meta {key args} { 1699 set file [SkipIgnored [This]] 1700 HandleDeclAfterBuild 1701 1702 # This, 'meta?', 'license', and 'tsources' are the only places 1703 # where we are not extending the UUID. Because the meta data has 1704 # no bearing on the binary at all. 1705 InitializeFile $file 1706 1707 dict update v::code($file) config c { 1708 dict update c meta m { 1709 foreach v $args { dict lappend m $key $v } 1710 } 1711 } 1712 return 1713} 1714 1715proc ::critcl::meta? {key} { 1716 set file [SkipIgnored [This]] 1717 HandleDeclAfterBuild 1718 1719 # This, 'meta', 'license', and 'tsources' are the only places 1720 # where we are not extending the UUID. Because the meta data has 1721 # no bearing on the binary at all. 1722 InitializeFile $file 1723 1724 if {[dict exists $v::code($file) config package $key]} { 1725 return [dict get $v::code($file) config package $key] 1726 } 1727 if {[dict exists $v::code($file) config meta $key]} { 1728 return [dict get $v::code($file) config meta $key] 1729 } 1730 return -code error "Unknown meta data key \"$key\"" 1731} 1732 1733proc ::critcl::ImetaSet {file key words} { 1734 dict set v::code($file) config package $key $words 1735 #puts |||$key|%|[dict get $v::code($file) config package $key]| 1736 return 1737} 1738 1739proc ::critcl::ImetaAdd {file key words} { 1740 dict update v::code($file) config c { 1741 dict update c package p { 1742 foreach word $words { 1743 dict lappend p $key $word 1744 } 1745 } 1746 } 1747 #puts XXX|$file||$key|+|[dict get $v::code($file) config package $key]| 1748 return 1749} 1750 1751proc ::critcl::Text2Words {text} { 1752 regsub -all {[ \t\n]+} $text { } text 1753 return [split [string trim $text]] 1754} 1755 1756proc ::critcl::Text2Authors {text} { 1757 regsub -all {[ \t\n]+} $text { } text 1758 set authors {} 1759 foreach a [split [string trim $text] ,] { 1760 lappend authors [string trim $a] 1761 } 1762 return $authors 1763} 1764 1765proc ::critcl::GetMeta {file} { 1766 if {![dict exists $v::code($file) config meta]} { 1767 set result {} 1768 } else { 1769 set result [dict get $v::code($file) config meta] 1770 } 1771 1772 # Merge the package information (= system meta data) with the 1773 # user's meta data. The system information overrides anything the 1774 # user may have declared for the reserved keys (name, version, 1775 # platform, as::author, as::build::date, license, description, 1776 # summary, require). Note that for the internal bracketing code 1777 # the system information may not exist, hence the catch. Might be 1778 # better to indicate the bracket somehow and make it properly 1779 # conditional. 1780 1781 #puts %$file 1782 1783 catch { 1784 set result [dict merge $result [dict get $v::code($file) config package]] 1785 } 1786 1787 # A few keys need a cleanup, i.e. removal of duplicates, and the like 1788 catch { 1789 dict set result require [lsort -dict -unique [dict get $result require]] 1790 } 1791 catch { 1792 dict set result build::require [lsort -dict -unique [dict get $result build::require]] 1793 } 1794 catch { 1795 dict set result platform [lindex [dict get $result platform] 0] 1796 } 1797 catch { 1798 dict set result generated::by [lrange [dict get $result generated::by] 0 1] 1799 } 1800 catch { 1801 dict set result generated::date [lindex [dict get $result generated::by] 0] 1802 } 1803 1804 #array set ___M $result ; parray ___M ; unset ___M 1805 return $result 1806} 1807 1808# # ## ### ##### ######## ############# ##################### 1809## Implementation -- API: user configuration options. 1810 1811proc ::critcl::userconfig {cmd args} { 1812 set file [SkipIgnored [This]] 1813 HandleDeclAfterBuild 1814 InitializeFile $file 1815 1816 if {![llength [info commands ::critcl::UC$cmd]]} { 1817 return -code error "Unknown method \"$cmd\"" 1818 } 1819 1820 # Dispatch 1821 return [eval [linsert $args 0 ::critcl::UC$cmd $file]] 1822} 1823 1824proc ::critcl::UCdefine {file oname odesc otype {odefault {}}} { 1825 # When declared without a default determine one of our own. Bool 1826 # flag default to true, whereas enum flags, which is the rest, 1827 # default to their first value. 1828 1829 # The actual definition ignores the config description. This 1830 # argument is only used by the static code scanner supporting 1831 # TEA. See ::critcl::scan::userconfig. 1832 1833 if {[llength [info level 0]] < 6} { 1834 set odefault [UcDefault $otype] 1835 } 1836 1837 # Validate the default against the type too, before saving 1838 # everything. 1839 UcValidate $oname $otype $odefault 1840 1841 UUID.extend $file .uc-def [list $oname $otype $odefault] 1842 1843 dict set v::code($file) config userflag $oname type $otype 1844 dict set v::code($file) config userflag $oname default $odefault 1845 return 1846} 1847 1848proc ::critcl::UCset {file oname value} { 1849 # NOTE: We can set any user flag we choose, even if not declared 1850 # yet. Validation of the value happens on query, at which time the 1851 # flag must be declared. 1852 1853 dict set v::code($file) config userflag $oname value $value 1854 return 1855} 1856 1857proc ::critcl::UCquery {file oname} { 1858 # Prefer cached data. This is known as declared, defaults merged, 1859 # validated. 1860 if {[dict exists $v::code($file) config userflag $oname =]} { 1861 return [dict get $v::code($file) config userflag $oname =] 1862 } 1863 1864 # Reject use of undeclared user flags. 1865 if {![dict exists $v::code($file) config userflag $oname type]} { 1866 error "Unknown user flag \"$oname\"" 1867 } 1868 1869 # Check if a value was supplied by the calling app. If not, fall 1870 # back to the declared default. 1871 1872 if {[dict exists $v::code($file) config userflag $oname value]} { 1873 set value [dict get $v::code($file) config userflag $oname value] 1874 } else { 1875 set value [dict get $v::code($file) config userflag $oname default] 1876 } 1877 1878 # Validate value against the flag's type. 1879 set otype [dict get $v::code($file) config userflag $oname type] 1880 UcValidate $oname $otype $value 1881 1882 # Fill cache 1883 dict set v::code($file) config userflag $oname = $value 1884 return $value 1885} 1886 1887proc ::critcl::UcValidate {oname otype value} { 1888 switch -exact -- $otype { 1889 bool { 1890 if {![string is bool -strict $value]} { 1891 error "Expected boolean for user flag \"$oname\", got \"$value\"" 1892 } 1893 } 1894 default { 1895 if {[lsearch -exact $otype $value] < 0} { 1896 error "Expected one of [linsert [join $otype {, }] end-1 or] for user flag \"$oname\", got \"$value\"" 1897 } 1898 } 1899 } 1900} 1901 1902proc ::critcl::UcDefault {otype} { 1903 switch -exact -- $otype { 1904 bool { 1905 return 1 1906 } 1907 default { 1908 return [lindex $otype 0] 1909 } 1910 } 1911} 1912 1913# # ## ### ##### ######## ############# ##################### 1914## Implementation -- API: API (stubs) management 1915 1916proc ::critcl::api {cmd args} { 1917 set file [SkipIgnored [This]] 1918 HandleDeclAfterBuild 1919 1920 if {![llength [info commands ::critcl::API$cmd]]} { 1921 return -code error "Unknown method \"$cmd\"" 1922 } 1923 1924 # Dispatch 1925 return [eval [linsert $args 0 ::critcl::API$cmd $file]] 1926} 1927 1928proc ::critcl::APIscspec {file scspec} { 1929 UUID.extend $file .api-scspec $scspec 1930 dict set v::code($file) config api_scspec $scspec 1931 return 1932} 1933 1934proc ::critcl::APIimport {file name version} { 1935 1936 # First we request the imported package, giving it a chance to 1937 # generate the headers searched for in a moment (maybe it was 1938 # critcl based as well, and generates things dynamically). 1939 1940 # Note that this can fail, for example in a cross-compilation 1941 # environment. Such a failure however does not imply that the 1942 # required API headers are not present, so we can continue. 1943 1944 catch { 1945 package require $name $version 1946 } 1947 1948 ImetaAdd $file require [list [list $name $version]] 1949 1950 # Now we check that the relevant headers of the imported package 1951 # can be found in the specified search paths. 1952 1953 set cname [string map {:: _} $name] 1954 1955 set at [API_locate $cname searched] 1956 if {$at eq {}} { 1957 error "Headers for API $name not found in \n-\t[join $searched \n-\t]" 1958 } else { 1959 msg -nonewline " (stubs import $name $version @ $at/$cname)" 1960 } 1961 1962 set def [list $name $version] 1963 UUID.extend $file .api-import $def 1964 dict update v::code($file) config c { 1965 dict lappend c api_use $def 1966 } 1967 1968 # At last look for the optional .decls file. Ignore if there is 1969 # none. Decode and return contained stubs table otherwise. 1970 1971 set decls $at/$cname/$cname.decls 1972 if {[file exists $decls]} { 1973 package require stubs::reader 1974 set T [stubs::container::new] 1975 stubs::reader::file T $decls 1976 return $T 1977 } 1978 return 1979} 1980 1981proc ::critcl::APIexport {file name} { 1982 msg -nonewline " (stubs export $name)" 1983 1984 UUID.extend $file .api-self $name 1985 return [dict set v::code($file) config api_self $name] 1986} 1987 1988proc ::critcl::APIheader {file args} { 1989 UUID.extend $file .api-headers $args 1990 return [SetParam api_hdrs $args] 1991} 1992 1993proc ::critcl::APIextheader {file args} { 1994 UUID.extend $file .api-eheaders $args 1995 return [SetParam api_ehdrs $args 0] 1996} 1997 1998proc ::critcl::APIfunction {file rtype name arguments} { 1999 package require stubs::reader 2000 2001 # Generate a declaration as it would have come straight out of the 2002 # stubs reader. To this end we generate a C code fragment as it 2003 # would be have been written inside of a .decls file. 2004 2005 # TODO: We should record this as well, and later generate a .decls 2006 # file as part of the export. Or regenerate it from the internal 2007 # representation. 2008 2009 if {[llength $arguments]} { 2010 foreach {t a} $arguments { 2011 lappend ax "$t $a" 2012 } 2013 } else { 2014 set ax void 2015 } 2016 set decl [stubs::reader::ParseDecl "$rtype $name ([join $ax ,])"] 2017 2018 UUID.extend $file .api-fun $decl 2019 dict update v::code($file) config c { 2020 dict lappend c api_fun $decl 2021 } 2022 return 2023} 2024 2025proc ::critcl::API_locate {name sv} { 2026 upvar 1 $sv searched 2027 foreach dir [SystemIncludePaths [This]] { 2028 lappend searched $dir 2029 if {[API_at $dir $name]} { return $dir } 2030 } 2031 return {} 2032} 2033 2034proc ::critcl::API_at {dir name} { 2035 foreach suffix { 2036 Decls.h StubLib.h 2037 } { 2038 if {![file exists [file join $dir $name $name$suffix]]} { return 0 } 2039 } 2040 return 1 2041} 2042 2043proc ::critcl::API_setup {file} { 2044 package require stubs::gen 2045 2046 lassign [API_setup_import $file] iprefix idefines 2047 dict set v::code($file) result apidefines $idefines 2048 2049 append prefix $iprefix 2050 append prefix [API_setup_export $file] 2051 2052 # Save prefix to result dictionary for pickup by Compile. 2053 if {$prefix eq ""} return 2054 2055 dict set v::code($file) result apiprefix $prefix\n 2056 return 2057} 2058 2059proc ::critcl::API_setup_import {file} { 2060 if {![dict exists $v::code($file) config api_use]} { 2061 return "" 2062 } 2063 2064 #msg -nonewline " (stubs import)" 2065 2066 set prefix "" 2067 set defines {} 2068 2069 foreach def [dict get $v::code($file) config api_use] { 2070 lassign $def iname iversion 2071 2072 set cname [string map {:: _} $iname] 2073 set upname [string toupper $cname] 2074 set capname [stubs::gen::cap $cname] 2075 2076 set import [critcl::at::here!][subst -nocommands { 2077 /* Import API: $iname */ 2078 #define USE_${upname}_STUBS 1 2079 #include <$cname/${cname}Decls.h> 2080 }] 2081 append prefix \n$import 2082 CCodeCore $file $import 2083 2084 # TODO :: DOCUMENT environment of the cinit code. 2085 CInitCore $file [subst -nocommands { 2086 if (!${capname}_InitStubs (ip, "$iversion", 0)) { 2087 return TCL_ERROR; 2088 } 2089 }] [subst -nocommands { 2090 #include <$cname/${cname}StubLib.h> 2091 }] 2092 2093 lappend defines -DUSE_${upname}_STUBS=1 2094 } 2095 2096 return [list $prefix $defines] 2097} 2098 2099proc ::critcl::API_setup_export {file} { 2100 if {![dict exists $v::code($file) config api_hdrs] && 2101 ![dict exists $v::code($file) config api_ehdrs] && 2102 ![dict exists $v::code($file) config api_fun]} return 2103 2104 if {[dict exists $v::code($file) config api_self]} { 2105 # API name was declared explicitly 2106 set ename [dict get $v::code($file) config api_self] 2107 } else { 2108 # API name is implicitly defined, is package name. 2109 set ename [dict get $v::code($file) config package name] 2110 } 2111 2112 set prefix "" 2113 2114 #msg -nonewline " (stubs export)" 2115 2116 set cname [string map {:: _} $ename] 2117 set upname [string toupper $cname] 2118 set capname [stubs::gen::cap $cname] 2119 2120 set import [at::here!][subst -nocommands { 2121 /* Import our own exported API: $ename, mapping disabled */ 2122 #undef USE_${upname}_STUBS 2123 #include <$cname/${cname}Decls.h> 2124 }] 2125 append prefix \n$import 2126 CCodeCore $file $import 2127 2128 # Generate the necessary header files. 2129 2130 append sdecls "\#ifndef ${cname}_DECLS_H\n" 2131 append sdecls "\#define ${cname}_DECLS_H\n" 2132 append sdecls "\n" 2133 append sdecls "\#include <tcl.h>\n" 2134 2135 if {[dict exists $v::code($file) config api_ehdrs]} { 2136 append sdecls "\n" 2137 file mkdir [cache]/$cname 2138 foreach hdr [dict get $v::code($file) config api_ehdrs] { 2139 append sdecls "\#include \"[file tail $hdr]\"\n" 2140 } 2141 } 2142 2143 if {[dict exists $v::code($file) config api_hdrs]} { 2144 append sdecls "\n" 2145 file mkdir [cache]/$cname 2146 foreach hdr [dict get $v::code($file) config api_hdrs] { 2147 Copy $hdr [cache]/$cname 2148 append sdecls "\#include \"[file tail $hdr]\"\n" 2149 } 2150 } 2151 2152 # Insert code to handle the storage class settings on Windows. 2153 2154 append sdecls [string map \ 2155 [list @cname@ $cname @up@ $upname] \ 2156 $v::storageclass] 2157 2158 package require stubs::container 2159 package require stubs::reader 2160 package require stubs::gen 2161 package require stubs::gen::header 2162 package require stubs::gen::init 2163 package require stubs::gen::lib 2164 package require stubs::writer 2165 2166 # Implied .decls file. Not actually written, only implied in the 2167 # stubs container invocations, as if read from such a file. 2168 2169 set T [stubs::container::new] 2170 stubs::container::library T $ename 2171 stubs::container::interface T $cname 2172 2173 if {[dict exists $v::code($file) config api_scspec]} { 2174 stubs::container::scspec T \ 2175 [dict get $v::code($file) config api_scspec] 2176 } 2177 2178 if {[dict exists $v::code($file) config api_fun]} { 2179 set index 0 2180 foreach decl [dict get $v::code($file) config api_fun] { 2181 #puts D==|$decl| 2182 stubs::container::declare T $cname $index generic $decl 2183 incr index 2184 } 2185 append sdecls "\n" 2186 append sdecls [stubs::gen::header::gen $T $cname] 2187 } 2188 2189 append sdecls "\#endif /* ${cname}_DECLS_H */\n" 2190 2191 set comment "/* Stubs API Export: $ename */" 2192 2193 set thedecls [stubs::writer::gen $T] 2194 set slib [stubs::gen::lib::gen $T] 2195 set sinitstatic " $comment\n " 2196 append sinitstatic [stubs::gen::init::gen $T] 2197 2198 set pn [dict get $v::code($file) config package name] 2199 set pv [dict get $v::code($file) config package version] 2200 2201 set sinitrun $comment\n 2202 append sinitrun "Tcl_PkgProvideEx (ip, \"$pn\", \"$pv\", (ClientData) &${cname}Stubs);" 2203 2204 # Save the header files to the result cache for pickup (importers 2205 # in mode "compile & run", or by the higher-level code doing a 2206 # "generate package") 2207 2208 WriteCache $cname/${cname}Decls.h $sdecls 2209 WriteCache $cname/${cname}StubLib.h $slib 2210 WriteCache $cname/${cname}.decls $thedecls 2211 2212 dict update v::code($file) result r { 2213 dict lappend r apiheader [file join [cache] $cname] 2214 } 2215 2216 CInitCore $file $sinitrun $sinitstatic 2217 CFlagsCore $file [list -DBUILD_$cname] 2218 2219 return $prefix 2220} 2221 2222# # ## ### ##### ######## ############# ##################### 2223## Implementation -- API: Introspection 2224 2225proc ::critcl::check {args} { 2226 set file [SkipIgnored [This] 0] 2227 HandleDeclAfterBuild 2228 2229 switch -exact -- [llength $args] { 2230 1 { 2231 set label Checking 2232 set code [lindex $args 0] 2233 } 2234 2 { 2235 lassign $args label code 2236 } 2237 default { 2238 return -code error "wrong#args: Expected ?label? code" 2239 } 2240 } 2241 2242 set src [WriteCache check_[pid].c $code] 2243 set obj [file rootname $src][getconfigvalue object] 2244 2245 # See also the internal helper 'Compile'. Thre code here is in 2246 # essence a simplified form of that. 2247 2248 set cmdline [getconfigvalue compile] 2249 lappendlist cmdline [GetParam $file cflags] 2250 lappendlist cmdline [SystemIncludes $file] 2251 lappendlist cmdline [CompileResult $obj] 2252 lappend cmdline $src 2253 2254 LogOpen $file 2255 Log* "${label}... " 2256 StatusReset 2257 set ok [ExecWithLogging $cmdline OK FAILED] 2258 StatusReset 2259 2260 LogClose 2261 clean_cache check_[pid].* 2262 return $ok 2263} 2264 2265proc ::critcl::checklink {args} { 2266 set file [SkipIgnored [This] 0] 2267 HandleDeclAfterBuild 2268 2269 switch -exact -- [llength $args] { 2270 1 { 2271 set label Checking 2272 set code [lindex $args 0] 2273 } 2274 2 { 2275 lassign $args label code 2276 } 2277 default { 2278 return -code error "wrong#args: Expected ?label? code" 2279 } 2280 } 2281 2282 set src [WriteCache check_[pid].c $code] 2283 set obj [file rootname $src][getconfigvalue object] 2284 2285 # See also the internal helper 'Compile'. Thre code here is in 2286 # essence a simplified form of that. 2287 2288 set cmdline [getconfigvalue compile] 2289 lappendlist cmdline [GetParam $file cflags] 2290 lappendlist cmdline [SystemIncludes $file] 2291 lappendlist cmdline [CompileResult $obj] 2292 lappend cmdline $src 2293 2294 LogOpen $file 2295 Log* "${label} (build)... " 2296 StatusReset 2297 set ok [ExecWithLogging $cmdline OK FAILED] 2298 StatusReset 2299 2300 if {!$ok} { 2301 LogClose 2302 clean_cache check_[pid].* 2303 return 0 2304 } 2305 2306 set out [file join [cache] a_[pid].out] 2307 set cmdline [getconfigvalue link] 2308 2309 if {$option::debug_symbols} { 2310 lappendlist cmdline [getconfigvalue link_debug] 2311 } else { 2312 lappendlist cmdline [getconfigvalue strip] 2313 lappendlist cmdline [getconfigvalue link_release] 2314 } 2315 2316 lappendlist cmdline [LinkResult $out] 2317 lappendlist cmdline $obj 2318 lappendlist cmdline [SystemLibraries] 2319 lappendlist cmdline [FixLibraries [GetParam $file clibraries]] 2320 lappendlist cmdline [GetParam $file ldflags] 2321 2322 Log* "${label} (link)... " 2323 StatusReset 2324 set ok [ExecWithLogging $cmdline OK ERR] 2325 2326 LogClose 2327 clean_cache check_[pid].* a_[pid].* 2328 return $ok 2329} 2330 2331proc ::critcl::compiled {} { 2332 SkipIgnored [This] 1 2333 HandleDeclAfterBuild 2334 return 0 2335} 2336 2337proc ::critcl::compiling {} { 2338 SkipIgnored [This] 0 2339 HandleDeclAfterBuild 2340 # Check that we can indeed run a compiler 2341 # Should only need to do this if we have to compile the code? 2342 if {[auto_execok [lindex [getconfigvalue compile] 0]] eq ""} { 2343 set v::compiling 0 2344 } else { 2345 set v::compiling 1 2346 } 2347 return $v::compiling 2348} 2349 2350proc ::critcl::done {} { 2351 set file [SkipIgnored [This] 1] 2352 return [expr {[info exists v::code($file)] && 2353 [dict exists $v::code($file) result closed]}] 2354} 2355 2356proc ::critcl::failed {} { 2357 SkipIgnored [This] 0 2358 if {$v::buildforpackage} { return 0 } 2359 return [cbuild [This] 0] 2360} 2361 2362proc ::critcl::load {} { 2363 SkipIgnored [This] 1 2364 if {$v::buildforpackage} { return 1 } 2365 return [expr {![cbuild [This]]}] 2366} 2367 2368# # ## ### ##### ######## ############# ##################### 2369## Default error behaviour 2370 2371proc ::critcl::error {msg} { 2372 return -code error $msg 2373} 2374 2375# # ## ### ##### ######## ############# ##################### 2376## Default message behaviour 2377 2378proc ::critcl::msg {args} { 2379 # ignore message (compile & run) 2380} 2381 2382# # ## ### ##### ######## ############# ##################### 2383## Default print behaviour 2384 2385proc ::critcl::print {args} { 2386 # API same as for builtin ::puts. Use as is. 2387 return [eval [linsert $args 0 ::puts]] 2388} 2389 2390# # ## ### ##### ######## ############# ##################### 2391## Runtime support to handle the possibility of a prebuilt package using 2392## the .tcl file with embedded C as its own companon defining regular 2393## Tcl code for the package as well. If the critcl package is loaded 2394## already this will cause it to ignore the C definitions, with best 2395## guesses for failed, done, load, check, compiled, and compiling. 2396 2397proc ::critcl::Ignore {f} { 2398 set v::ignore([file normalize $f]) . 2399 return 2400} 2401 2402proc ::critcl::SkipIgnored {f {result {}}} { 2403 if {[info exists v::ignore($f)]} { return -code return $result } 2404 return $f 2405} 2406 2407# # ## ### ##### ######## ############# ##################### 2408## Implementation -- API: Build Management 2409 2410proc ::critcl::config {option args} { 2411 if {![info exists v::options($option)] || [llength $args] > 1} { 2412 error "option must be one of: [lsort [array names v::options]]" 2413 } 2414 if {![llength $args]} { 2415 return $v::options($option) 2416 } 2417 set v::options($option) [lindex $args 0] 2418} 2419 2420proc ::critcl::debug {args} { 2421 # Replace 'all' everywhere, and squash duplicates, whether from 2422 # this, or user-specified. 2423 set args [string map {all {memory symbols}} $args] 2424 set args [lsort -unique $args] 2425 2426 foreach arg $args { 2427 switch -- $arg { 2428 memory { foreach x [getconfigvalue debug_memory] { cflags $x } } 2429 symbols { foreach x [getconfigvalue debug_symbols] { cflags $x } 2430 set option::debug_symbols 1 2431 } 2432 default { 2433 error "unknown critcl::debug option - $arg" 2434 } 2435 } 2436 } 2437 return 2438} 2439 2440# # ## ### ##### ######## ############# ##################### 2441## Implementation -- API: Result Cache 2442 2443proc ::critcl::cache {{dir ""}} { 2444 if {[llength [info level 0]] == 2} { 2445 set v::cache [file normalize $dir] 2446 } 2447 return $v::cache 2448} 2449 2450proc ::critcl::clean_cache {args} { 2451 if {![llength $args]} { lappend args * } 2452 foreach pattern $args { 2453 foreach file [glob -nocomplain -directory $v::cache $pattern] { 2454 file delete -force $file 2455 } 2456 } 2457 return 2458} 2459 2460# # ## ### ##### ######## ############# ##################### 2461## Implementation -- API: Build Configuration 2462# read toolchain information from config file 2463 2464proc ::critcl::readconfig {config} { 2465 variable run 2466 variable configfile $config 2467 2468 set cfg [open $config] 2469 set knowntargets [list] 2470 set cont "" 2471 set whenplat "" 2472 2473 interp eval $run set platform $v::buildplatform 2474 2475 set i 0 2476 while {[gets $cfg line] >= 0} { 2477 incr i 2478 if {[set line [string trim $line]] ne ""} { 2479 # config lines can be continued using trailing backslash 2480 if {[string index $line end] eq "\\"} { 2481 append cont " [string range $line 0 end-1]" 2482 continue 2483 } 2484 if {$cont ne ""} { 2485 append cont $line 2486 set line [string trim $cont] 2487 set cont "" 2488 } 2489 2490 # At this point we have a complete line/command in 'line'. 2491 # We expect the following forms of input: 2492 # 2493 # (1.) if {...} {.............} - Tcl command, run in the 2494 # backend interpreter. 2495 # Note that this can EXIT 2496 # the application using 2497 # the critcl package. 2498 # (2.) set VAR VALUE.......... - Ditto. 2499 # (3.) # ..................... - Comment. Skipped 2500 # (4.) PLATFORM VAR VALUE...... - Platform-specific 2501 # configuration variable 2502 # and value. 2503 2504 # (4a) PLATFORM when ......... - Makes the PLATFORM 2505 # conditional on the 2506 # expression after the 2507 # 'when' keyword. This 2508 # uses variables set by 2509 # (1) and/or (2). The 2510 # expression is run in the 2511 # backend interpreter. If 2512 # and only if PLATFORM is 2513 # a prefix of the current 2514 # build platform, or the 2515 # reverse, then the code 2516 # with an TRUE when is 2517 # chosen as the 2518 # configuration. 2519 2520 # (4b) PLATFORM target ?actual? - Marks the platform as a 2521 # cross-compile target, 2522 # and actual is the 2523 # platform identifier of 2524 # the result. If not 2525 # specified it defaults to 2526 # PLATFORM. 2527 # (4c) PLATFORM copy PARENT... - Copies the currently defined 2528 # configuration variables and 2529 # values to the settings for 2530 # this platform. 2531 # (5.) VAR VALUE............... - Default configuration 2532 # variable, and value. 2533 2534 set plat [lindex [split $line] 0] 2535 2536 # (1), or (2) 2537 if {$plat eq "set" || $plat eq "if"} { 2538 while {![info complete $line] && ![eof $cfg]} { 2539 if {[gets $cfg more] == -1} { 2540 set msg "incomplete command in Critcl Config file " 2541 append msg "starting at line $i" 2542 error $msg 2543 } 2544 append line "\n$more" 2545 2546 } 2547 interp eval $run $line 2548 continue 2549 } 2550 2551 # (3) 2552 if {$plat eq "#"} continue 2553 2554 # (4), or (5). 2555 if {[lsearch -exact $v::configvars $plat] != -1} { 2556 # (5) default config option 2557 set cmd "" 2558 if {![regexp {(\S+)\s+(.*)} $line -> type cmd]} { 2559 # cmd is empty 2560 set type $plat 2561 set cmd "" 2562 } 2563 set plat "" 2564 } else { 2565 # (4) platform config option 2566 if {![regexp {(\S+)\s+(\S+)\s+(.*)} $line -> p type cmd]} { 2567 # cmd is empty 2568 set type [lindex $line 1] 2569 set cmd "" 2570 } 2571 2572 # (4a) if and only if either build platform or config 2573 # code are a prefix of each other can the 'when' 2574 # condition be evaluated and override the 2575 # standard selection for the configuration. 2576 2577 if {$type eq "when" && 2578 ( [string match ${v::buildplatform}* $plat] || 2579 [string match ${plat}* $v::buildplatform] )} { 2580 set res "" 2581 catch { 2582 set res [interp eval $run expr $cmd] 2583 } 2584 switch $res { 2585 "" - 2586 0 { set whenfalse($plat) 1 } 2587 1 { set whenplat $plat } 2588 } 2589 } 2590 lappend knowntargets $plat 2591 } 2592 2593 switch -exact -- $type { 2594 target { 2595 # (4b) cross compile target. 2596 # cmd = actual target platform identifier. 2597 if {$cmd eq ""} { 2598 set cmd $plat 2599 } 2600 set v::xtargets($plat) $cmd 2601 } 2602 copy { 2603 # (4c) copy an existing config 2604 # XXX - should we error out if no definitions exist 2605 # for parent platform config 2606 # $cmd contains the parent platform 2607 foreach {key val} [array get v::toolchain "$cmd,*"] { 2608 set key [lindex [split $key ,] 1] 2609 set v::toolchain($plat,$key) $val 2610 } 2611 } 2612 default { 2613 set v::toolchain($plat,$type) $cmd 2614 } 2615 } 2616 } 2617 } 2618 set knowntargets [lsort -unique $knowntargets] 2619 close $cfg 2620 2621 # Config file processing has completed. 2622 # Now select the platform to configure the 2623 # compiler backend with. 2624 2625 set v::knowntargets $knowntargets 2626 2627 # The config file may have selected a configuration based on the 2628 # TRUE when conditions. Which were matched to v::buildplatform, 2629 # making the chosen config a variant of it. If that did not happen 2630 # a platform is chosen from the set of defined targets. 2631 if {$whenplat ne ""} { 2632 set match [list $whenplat] 2633 } else { 2634 set match [critcl::chooseconfig $v::buildplatform] 2635 } 2636 2637 # Configure the backend. 2638 2639 setconfig "" ;# defaults 2640 if {[llength $match]} { 2641 setconfig [lindex $match 0] 2642 } else { 2643 setconfig $v::buildplatform 2644 } 2645 return 2646} 2647 2648proc ::critcl::chooseconfig {targetconfig {err 0}} { 2649 # first try to match exactly 2650 set match [lsearch -exact -all -inline $v::knowntargets $targetconfig] 2651 2652 # on failure, try to match as glob pattern 2653 if {![llength $match]} { 2654 set match [lsearch -glob -all -inline $v::knowntargets $targetconfig] 2655 } 2656 2657 # on failure, error out if requested 2658 if {![llength $match] && $err} { 2659 error "unknown target $targetconfig - use one of $v::knowntargets" 2660 } 2661 return $match 2662} 2663 2664proc ::critcl::showconfig {{fd ""}} { 2665 variable run 2666 variable configfile 2667 2668 # XXX replace gen - v::buildplatform 2669 # XXX Do not use v::targetplatform here. Use v::config. 2670 # XXX Similarly in setconfig. 2671 2672 set gen $v::buildplatform 2673 if {$v::targetplatform eq ""} { 2674 set plat "default" 2675 } else { 2676 set plat $v::targetplatform 2677 } 2678 set out [list] 2679 if {$plat eq $gen} { 2680 lappend out "Config: $plat" 2681 } else { 2682 lappend out "Config: $plat (built on $gen)" 2683 } 2684 lappend out "Origin: $configfile" 2685 lappend out " [format %-15s cache] [cache]" 2686 foreach var [lsort $v::configvars] { 2687 set val [getconfigvalue $var] 2688 set line " [format %-15s $var]" 2689 foreach word [split [string trim $val]] { 2690 if {[set word [string trim $word]] eq ""} continue 2691 if {[string length "$line $word"] > 70} { 2692 lappend out "$line \\" 2693 set line " [format %-15s { }] $word" 2694 } else { 2695 set line "$line $word" 2696 } 2697 } 2698 lappend out $line 2699 } 2700 # Tcl variables - Combined LengthLongestWord (all), and filtering 2701 set vars [list] 2702 set max 0 2703 foreach idx [array names v::toolchain $v::targetplatform,*] { 2704 set var [lindex [split $idx ,] 1] 2705 if {[set len [string length $var]] > $max} { 2706 set max $len 2707 } 2708 if {$var ne "when" && ![info exists c::$var]} { 2709 lappend vars $idx $var 2710 } 2711 } 2712 if {[llength $vars]} { 2713 lappend out "Tcl variables:" 2714 foreach {idx var} $vars { 2715 set val $v::toolchain($idx) 2716 if {[llength $val] == 1} { 2717 # for when someone inevitably puts quotes around 2718 # values - e.g. "Windows NT" 2719 set val [lindex $val 0] 2720 } 2721 lappend out " [PadRight $max $var] $val" 2722 } 2723 } 2724 set out [join $out \n] 2725 if {$fd ne ""} { 2726 puts $fd $out 2727 } else { 2728 return $out 2729 } 2730} 2731 2732proc ::critcl::showallconfig {{ofd ""}} { 2733 variable configfile 2734 set txt [Cat $configfile] 2735 if {$ofd ne ""} { 2736 puts $ofd $txt 2737 } else { 2738 return $txt 2739 } 2740} 2741 2742proc ::critcl::setconfig {targetconfig} { 2743 set v::targetconfig $targetconfig 2744 2745 # Strip the compiler information from the configuration to get the 2746 # platform identifier embedded into it. This is a semi-recurrence 2747 # of the original hardwired block handling win32/gcc/cl. We can 2748 # partly emulate this with 'platform' directives in the Config 2749 # file, however this breaks down when trying to handle the default 2750 # settings. I.e. something like FOO-gcc which has no configuration 2751 # block in the file uses the defaults, and thus has no proper 2752 # place for a custom platform directive. So we have to do it here, 2753 # in code. For symmetry the other compilers (-cc, -cl) are handled 2754 # as well. 2755 2756 set v::targetplatform $targetconfig 2757 foreach p {gcc cc_r xlc xlc_r cc cl clang([[:digit:]])*} { 2758 if {[regsub -- "-$p\$" $v::targetplatform {} v::targetplatform]} break 2759 } 2760 2761 set c::platform "" 2762 set c::sharedlibext "" 2763 2764 foreach var $v::configvars { 2765 if {[info exists v::toolchain($targetconfig,$var)]} { 2766 2767 set c::$var $v::toolchain($targetconfig,$var) 2768 2769 if {$var eq "platform"} { 2770 set px [getconfigvalue platform] 2771 set v::targetplatform [lindex $px 0] 2772 set v::version [lindex $px 1] 2773 } 2774 } 2775 } 2776 if {[info exists ::env(CFLAGS)]} { 2777 variable c::compile 2778 append c::compile " $::env(CFLAGS)" 2779 } 2780 if {[info exists ::env(LDFLAGS)]} { 2781 variable c::link 2782 append c::link " $::env(LDFLAGS)" 2783 append c::link_preload " $::env(LDFLAGS)" 2784 } 2785 if {[string match $v::targetplatform $v::buildplatform]} { 2786 # expand platform to match host if it contains wildcards 2787 set v::targetplatform $v::buildplatform 2788 } 2789 if {$c::platform eq ""} { 2790 # default config platform (mainly for the "show" command) 2791 set c::platform $v::targetplatform 2792 } 2793 if {$c::sharedlibext eq ""} { 2794 set c::sharedlibext [info sharedlibextension] 2795 } 2796 2797 # The following definition of the cache directory is only relevant 2798 # for mode "compile & run". The critcl application handling the 2799 # package mode places the cache in a process-specific location 2800 # without care about platforms. For here this means that we can 2801 # ignore both cross-compilation, and the user choosing a target 2802 # for us, as neither happens nor works for "compile & run". We can 2803 # assume that build and target platforms will be the same, be the 2804 # current platform, and we can make a simple choice for the 2805 # directory. 2806 2807 cache [file join ~ .critcl [platform::identify]] 2808 2809 # Initialize Tcl variables based on the chosen tooling 2810 foreach idx [array names v::toolchain $v::targetplatform,*] { 2811 set var [lindex [split $idx ,] 1] 2812 if {![info exists c::$var]} { 2813 set val $v::toolchain($idx) 2814 if {[llength $val] == 1} { 2815 # for when someone inevitably puts quotes around 2816 # values - e.g. "Windows NT" 2817 set val [lindex $val 0] 2818 } 2819 set $var $val 2820 } 2821 } 2822 return 2823} 2824 2825proc ::critcl::getconfigvalue {var} { 2826 variable run 2827 if {[catch {set val [interp eval $run [list subst [set c::$var]]]}]} { 2828 set val [set c::$var] 2829 } 2830 return $val 2831} 2832 2833# # ## ### ##### ######## ############# ##################### 2834## Implementation -- API: Application 2835 2836# The regular commands used by the application, defined in other 2837# sections of the package are: 2838# 2839# C critcl::cache 2840# C critcl::ccode 2841# C critcl::chooseconfig 2842# C critcl::cinit 2843# C critcl::clean_cache 2844# C critcl::clibraries 2845# C critcl::cobjects 2846# C critcl::config I, lines, force, keepsrc, combine 2847# C critcl::debug 2848# C critcl::error | App overrides our implementation. 2849# C critcl::getconfigvalue 2850# C critcl::lappendlist 2851# C critcl::ldflags 2852# C critcl::preload 2853# C critcl::readconfig 2854# C critcl::setconfig 2855# C critcl::showallconfig 2856# C critcl::showconfig 2857 2858proc ::critcl::crosscheck {} { 2859 variable run 2860 global tcl_platform 2861 2862 if {$tcl_platform(platform) eq "windows"} { 2863 set null NUL: 2864 } else { 2865 set null /dev/null 2866 } 2867 2868 if {![catch { 2869 set cmd [linsert $c::version 0 exec] 2870 lappend cmd 2> $null;#@stdout 2871 set config [interp eval $run $cmd] 2872 } msg]} { 2873 set host "" 2874 set target "" 2875 foreach line $config { 2876 foreach arg [split $line] { 2877 if {[string match "--*" $arg]} { 2878 lassign [split [string trim $arg -] =] cfg val 2879 set $cfg $val 2880 } 2881 } 2882 } 2883 if {$host ne $target && [info exists v::xtargets($target)]} { 2884 setconfig $target 2885 print stderr "Cross compiling using $target" 2886 } 2887 # XXX host != target, but not know as config ? 2888 # XXX Currently ignored. 2889 # XXX Throwing an error better ? 2890 } 2891 return 2892} 2893 2894# See (XX) at the end of the file (package state variable setup) 2895# for explanations of the exact differences between these. 2896 2897proc ::critcl::knowntargets {} { 2898 return $v::knowntargets 2899} 2900 2901proc ::critcl::targetconfig {} { 2902 return $v::targetconfig 2903} 2904 2905proc ::critcl::targetplatform {} { 2906 return $v::targetplatform 2907} 2908 2909proc ::critcl::buildplatform {} { 2910 return $v::buildplatform 2911} 2912 2913proc ::critcl::actualtarget {} { 2914 # Check if the chosen target is a cross-compile target. If yes, 2915 # we return the actual platform identifier of the target. This is 2916 # used to select the proper platform director names in the critcl 2917 # cache, generated packages, when searching for preload libraries, 2918 # etc. Whereas the chosen target provides the proper compile 2919 # configuration which will invoke the proper cross-compiler, etc. 2920 2921 if {[info exists v::xtargets($v::targetplatform)]} { 2922 return $v::xtargets($v::targetplatform) 2923 } else { 2924 return $v::targetplatform 2925 } 2926} 2927 2928proc ::critcl::sharedlibext {} { 2929 return [getconfigvalue sharedlibext] 2930} 2931 2932proc ::critcl::buildforpackage {{buildforpackage 1}} { 2933 set v::buildforpackage $buildforpackage 2934 return 2935} 2936 2937proc ::critcl::fastuuid {} { 2938 set v::uuidcounter 1 ;# Activates it. 2939 return 2940} 2941 2942proc ::critcl::cbuild {file {load 1}} { 2943 if {[info exists v::code($file,failed)] && !$load} { 2944 set v::buildforpackage 0 2945 return $v::code($file,failed) 2946 } 2947 2948 StatusReset 2949 2950 # Determine if we should place stubs code into the generated file. 2951 set placestubs [expr {!$v::buildforpackage}] 2952 2953 # Determine the requested mode and reset for next call. 2954 set buildforpackage $v::buildforpackage 2955 set v::buildforpackage 0 2956 2957 if {$file eq ""} { 2958 set file [This] 2959 } 2960 2961 # NOTE: The 4 pieces of data just below has to be copied into the 2962 # result even if the build and link-steps are suppressed. Because 2963 # the load-step must have this information. 2964 2965 set shlib [DetermineShlibName $file] 2966 set initname [DetermineInitName $file [expr {$buildforpackage ? "ns" : ""}]] 2967 2968 dict set v::code($file) result tsources [GetParam $file tsources] 2969 dict set v::code($file) result mintcl [MinTclVersion $file] 2970 2971 set emsg {} 2972 set msgs {} 2973 2974 if {$v::options(force) || ![file exists $shlib]} { 2975 LogOpen $file 2976 set base [BaseOf $file] 2977 set object [DetermineObjectName $file] 2978 2979 API_setup $file 2980 2981 # Generate the main C file 2982 CollectEmbeddedSources $file $base.c $object $initname $placestubs 2983 2984 # Set the marker for critcl::done and its user, HandleDeclAfterBuild. 2985 dict set v::code($file) result closed mark 2986 2987 # Compile main file 2988 lappend objects [Compile $file $file $base.c $object] 2989 2990 # Compile the companion C sources as well, if there are any. 2991 foreach src [GetParam $file csources] { 2992 lappend objects [Compile $file $src $src \ 2993 [CompanionObject $src]] 2994 } 2995 2996 # NOTE: The data below has to be copied into the result even 2997 # if the link-step is suppressed. Because the application 2998 # (mode 'generate package') must have this information to be 2999 # able to perform the final link. 3000 3001 lappendlist objects [GetParam $file cobjects] 3002 3003 dict set v::code($file) result clibraries [GetParam $file clibraries] 3004 dict set v::code($file) result ldflags [GetParam $file ldflags] 3005 dict set v::code($file) result objects $objects 3006 dict set v::code($file) result tk [UsingTk $file] 3007 dict set v::code($file) result preload [GetParam $file preload] 3008 dict set v::code($file) result license [GetParam $file license <<Undefined>>] 3009 dict set v::code($file) result log {} 3010 dict set v::code($file) result meta [GetMeta $file] 3011 3012 # Link and load steps. 3013 if {$load || !$buildforpackage} { 3014 Link $file 3015 } 3016 3017 lassign [LogClose] msgs emsg 3018 3019 dict set v::code($file) result warnings [CheckForWarnings $emsg] 3020 } 3021 3022 dict set v::code($file) result log $msgs 3023 dict set v::code($file) result exl $emsg 3024 3025 if {$v::failed} { 3026 if {!$buildforpackage} { 3027 print stderr "$msgs\ncritcl build failed ($file)" 3028 } 3029 } elseif {$load && !$buildforpackage} { 3030 Load $file 3031 } 3032 3033 # Release the data which was collected for the just-built file, as 3034 # it is not needed any longer. 3035 dict unset v::code($file) config 3036 3037 return [StatusSave $file] 3038} 3039 3040proc ::critcl::cresults {{file {}}} { 3041 if {$file eq ""} { set file [This] } 3042 return [dict get $v::code($file) result] 3043} 3044 3045proc ::critcl::cnothingtodo {f} { 3046 # No critcl definitions at all ? 3047 if {![info exists v::code($f)]} { return 1 } 3048 3049 # We have results already, so where had been something to do. 3050 if {[dict exists $v::code($f) result]} { return 0 } 3051 3052 # No C code collected for compilation ? 3053 if {![dict exists $v::code($f) config fragments]} { return 1 } 3054 3055 # Ok, something has to be done. 3056 return 0 3057} 3058 3059proc ::critcl::c++command {tclname class constructors methods} { 3060 # Build the body of the function to define a new tcl command for 3061 # the C++ class 3062 set helpline {} 3063 set classptr ptr_$tclname 3064 set comproc " $class* $classptr;\n" 3065 append comproc " switch (objc) \{\n" 3066 3067 if {![llength $constructors]} { 3068 set constructors {{}} 3069 } 3070 3071 foreach adefs $constructors { 3072 array set types {} 3073 set names {} 3074 set cargs {} 3075 set cnames {} 3076 3077 foreach {t n} $adefs { 3078 set types($n) $t 3079 lappend names $n 3080 lappend cnames _$n 3081 lappend cargs "$t $n" 3082 } 3083 lappend helpline "$tclname pathName [join $names { }]" 3084 set nargs [llength $names] 3085 set ncargs [expr {$nargs + 2}] 3086 append comproc " case $ncargs: \{\n" 3087 3088 if {!$nargs} { 3089 append comproc " $classptr = new $class\();\n" 3090 } else { 3091 append comproc [ProcessArgs types $names $cnames] 3092 append comproc " $classptr = new $class\([join $cnames {, }]);\n" 3093 } 3094 append comproc " break;\n" 3095 append comproc " \}\n" 3096 3097 } 3098 append comproc " default: \{\n" 3099 append comproc " Tcl_SetResult(ip, \"wrong # args: should be either [join $helpline { or }]\",TCL_STATIC);\n" 3100 append comproc " return TCL_ERROR;\n" 3101 append comproc " \}\n" 3102 append comproc " \}\n" 3103 3104 append comproc " if ( $classptr == NULL ) \{\n" 3105 append comproc " Tcl_SetResult(ip, \"Not enough memory to allocate a new $tclname\", TCL_STATIC);\n" 3106 append comproc " return TCL_ERROR;\n" 3107 append comproc " \}\n" 3108 3109 append comproc " Tcl_CreateObjCommand(ip, Tcl_GetString(objv\[1]), cmdproc_$tclname, (ClientData) $classptr, delproc_$tclname);\n" 3110 append comproc " return TCL_OK;\n" 3111 # 3112 # Build the body of the c function called when the object is deleted 3113 # 3114 set delproc "void delproc_$tclname\(ClientData cd) \{\n" 3115 append delproc " if (cd != NULL)\n" 3116 append delproc " delete ($class*) cd;\n" 3117 append delproc "\}\n" 3118 3119 # 3120 # Build the body of the function that processes the tcl commands for the class 3121 # 3122 set cmdproc "int cmdproc_$tclname\(ClientData cd, Tcl_Interp* ip, int objc, Tcl_Obj *CONST objv\[]) \{\n" 3123 append cmdproc " int index;\n" 3124 append cmdproc " $class* $classptr = ($class*) cd;\n" 3125 3126 set rtypes {} 3127 set tnames {} 3128 set mnames {} 3129 set adefs {} 3130 foreach {rt n a} $methods { 3131 lappend rtypes $rt 3132 lappend tnames [lindex $n 0] 3133 set tmp [lindex $n 1] 3134 if {$tmp eq ""} { 3135 lappend mnames [lindex $n 0] 3136 } else { 3137 lappend mnames [lindex $n 1] 3138 } 3139 lappend adefs $a 3140 } 3141 append cmdproc " static const char* cmds\[]=\{\"[join $tnames {","}]\",NULL\};\n" 3142 append cmdproc " if (objc<2) \{\n" 3143 append cmdproc " Tcl_WrongNumArgs(ip, 1, objv, \"expecting pathName option\");\n" 3144 append cmdproc " return TCL_ERROR;\n" 3145 append cmdproc " \}\n\n" 3146 append cmdproc " if (Tcl_GetIndexFromObj(ip, objv\[1], cmds, \"option\", TCL_EXACT, &index) != TCL_OK)\n" 3147 append cmdproc " return TCL_ERROR;\n" 3148 append cmdproc " switch (index) \{\n" 3149 3150 set ndx 0 3151 foreach rtype $rtypes tname $tnames mname $mnames adef $adefs { 3152 array set types {} 3153 set names {} 3154 set cargs {} 3155 set cnames {} 3156 3157 switch -- $rtype { 3158 ok { set rtype2 "int" } 3159 string - 3160 dstring - 3161 vstring { set rtype2 "char*" } 3162 default { set rtype2 $rtype } 3163 } 3164 3165 foreach {t n} $adef { 3166 set types($n) $t 3167 lappend names $n 3168 lappend cnames _$n 3169 lappend cargs "$t $n" 3170 } 3171 set helpline "$tname [join $names { }]" 3172 set nargs [llength $names] 3173 set ncargs [expr {$nargs + 2}] 3174 3175 append cmdproc " case $ndx: \{\n" 3176 append cmdproc " if (objc==$ncargs) \{\n" 3177 append cmdproc [ProcessArgs types $names $cnames] 3178 append cmdproc " " 3179 if {$rtype ne "void"} { 3180 append cmdproc "$rtype2 rv = " 3181 } 3182 append cmdproc "$classptr->$mname\([join $cnames {, }]);\n" 3183 append cmdproc " " 3184 switch -- $rtype { 3185 void { } 3186 ok { append cmdproc "return rv;" } 3187 int { append cmdproc "Tcl_SetIntObj(Tcl_GetObjResult(ip), rv);" } 3188 long { append cmdproc " Tcl_SetLongObj(Tcl_GetObjResult(ip), rv);" } 3189 float - 3190 double { append cmdproc "Tcl_SetDoubleObj(Tcl_GetObjResult(ip), rv);" } 3191 char* { append cmdproc "Tcl_SetResult(ip, rv, TCL_STATIC);" } 3192 string - 3193 dstring { append cmdproc "Tcl_SetResult(ip, rv, TCL_DYNAMIC);" } 3194 vstring { append cmdproc "Tcl_SetResult(ip, rv, TCL_VOLATILE);" } 3195 default { append cmdproc "if (rv == NULL) \{ return TCL_ERROR ; \}\n Tcl_SetObjResult(ip, rv); Tcl_DecrRefCount(rv);" } 3196 } 3197 append cmdproc "\n" 3198 append cmdproc " " 3199 if {$rtype ne "ok"} { append cmdproc "return TCL_OK;\n" } 3200 3201 append cmdproc " \} else \{\n" 3202 append cmdproc " Tcl_WrongNumArgs(ip, 1, objv, \"$helpline\");\n" 3203 append cmdproc " return TCL_ERROR;\n" 3204 append cmdproc " \}\n" 3205 append cmdproc " \}\n" 3206 incr ndx 3207 } 3208 append cmdproc " \}\n\}\n" 3209 3210 # TODO: line pragma fix ?! 3211 ccode $delproc 3212 ccode $cmdproc 3213 3214 # Force the new ccommand to be defined in the caller's namespace 3215 # instead of improperly in ::critcl. 3216 namespace eval [uplevel 1 namespace current] \ 3217 [list critcl::ccommand $tclname {dummy ip objc objv} $comproc] 3218 3219 return 3220} 3221 3222proc ::critcl::ProcessArgs {typesArray names cnames} { 3223 upvar 1 $typesArray types 3224 set body "" 3225 foreach x $names c $cnames { 3226 set t $types($x) 3227 switch -- $t { 3228 int - long - float - double - char* - Tcl_Obj* { 3229 append body " $t $c;\n" 3230 } 3231 default { 3232 append body " void* $c;\n" 3233 } 3234 } 3235 } 3236 set n 1 3237 foreach x $names c $cnames { 3238 set t $types($x) 3239 incr n 3240 switch -- $t { 3241 int { 3242 append body " if (Tcl_GetIntFromObj(ip, objv\[$n], &$c) != TCL_OK)\n" 3243 append body " return TCL_ERROR;\n" 3244 } 3245 long { 3246 append body " if (Tcl_GetLongFromObj(ip, objv\[$n], &$c) != TCL_OK)\n" 3247 append body " return TCL_ERROR;\n" 3248 } 3249 float { 3250 append body " \{ double tmp;\n" 3251 append body " if (Tcl_GetDoubleFromObj(ip, objv\[$n], &tmp) != TCL_OK)\n" 3252 append body " return TCL_ERROR;\n" 3253 append body " $c = (float) tmp;\n" 3254 append body " \}\n" 3255 } 3256 double { 3257 append body " if (Tcl_GetDoubleFromObj(ip, objv\[$n], &$c) != TCL_OK)\n" 3258 append body " return TCL_ERROR;\n" 3259 } 3260 char* { 3261 append body " $c = Tcl_GetString(objv\[$n]);\n" 3262 } 3263 default { 3264 append body " $c = objv\[$n];\n" 3265 } 3266 } 3267 } 3268 return $body 3269} 3270 3271proc ::critcl::scan {file} { 3272 set lines [split [Cat $file] \n] 3273 3274 set scan::rkey require 3275 set scan::base [file dirname [file normalize $file]] 3276 set scan::capture { 3277 org {} 3278 version {} 3279 files {} 3280 imported {} 3281 config {} 3282 meta-user {} 3283 meta-system {} 3284 tsources {} 3285 } 3286 3287 ScanCore $lines { 3288 critcl::api sub 3289 critcl::api/extheader ok 3290 critcl::api/function ok 3291 critcl::api/header warn 3292 critcl::api/import ok 3293 critcl::source warn 3294 critcl::cheaders warn 3295 critcl::csources warn 3296 critcl::license warn 3297 critcl::meta warn 3298 critcl::owns warn 3299 critcl::tcl ok 3300 critcl::tk ok 3301 critcl::tsources warn 3302 critcl::userconfig sub 3303 critcl::userconfig/define ok 3304 critcl::userconfig/query ok 3305 critcl::userconfig/set ok 3306 package warn 3307 } 3308 3309 set version [dict get $scan::capture version] 3310 print "\tVersion: $version" 3311 3312 # TODO : Report requirements. 3313 # TODO : tsources - Scan files for dependencies! 3314 3315 set n [llength [dict get $scan::capture files]] 3316 print -nonewline "\tInput: $file" 3317 if {$n} { 3318 print -nonewline " + $n Companion" 3319 if {$n > 1} { print -nonewline s } 3320 } 3321 print "" 3322 3323 # Merge the system and user meta data, with system overriding the 3324 # user. See 'GetMeta' for same operation when actually builing the 3325 # package. Plus scan any Tcl companions for more requirements. 3326 3327 set md {} 3328 lappend md [dict get $scan::capture meta-user] 3329 lappend md [dict get $scan::capture meta-system] 3330 3331 foreach ts [dict get $scan::capture tsources] { 3332 lappend md [dict get [ScanDependencies $file \ 3333 [file join [file dirname $file] $ts] \ 3334 capture] meta-system] 3335 } 3336 3337 dict unset scan::capture meta-user 3338 dict unset scan::capture meta-system 3339 dict unset scan::capture tsources 3340 3341 dict set scan::capture meta \ 3342 [eval [linsert $md 0 dict merge]] 3343 # meta = dict merge {*}$md 3344 3345 if {[dict exists $scan::capture meta require]} { 3346 foreach r [dict get $scan::capture meta require] { 3347 print "\tRequired: $r" 3348 } 3349 } 3350 3351 return $scan::capture 3352} 3353 3354proc ::critcl::ScanDependencies {dfile file {mode plain}} { 3355 set lines [split [Cat $file] \n] 3356 3357 catch { 3358 set saved $scan::capture 3359 } 3360 3361 set scan::rkey require 3362 set scan::base [file dirname [file normalize $file]] 3363 set scan::capture { 3364 name {} 3365 version {} 3366 meta-system {} 3367 } 3368 3369 ScanCore $lines { 3370 critcl::buildrequirement warn 3371 package warn 3372 } 3373 3374 if {$mode eq "capture"} { 3375 set result $scan::capture 3376 set scan::capture $saved 3377 return $result 3378 } 3379 3380 dict with scan::capture { 3381 if {$mode eq "provide"} { 3382 msg -nonewline " (provide $name $version)" 3383 3384 ImetaSet $dfile name $name 3385 ImetaSet $dfile version $version 3386 } 3387 3388 dict for {k vlist} [dict get $scan::capture meta-system] { 3389 if {$k eq "name"} continue 3390 if {$k eq "version"} continue 3391 3392 ImetaAdd $dfile $k $vlist 3393 3394 if {$k ne "require"} continue 3395 # vlist = package list, each element a package name, 3396 # and optional version. 3397 msg -nonewline " ([file tail $file]: require [join [lsort -dict -unique $vlist] {, }])" 3398 } 3399 3400 # The above information also goes into the teapot meta data of 3401 # the file in question. This however is defered until the meta 3402 # data is actually pulled for delivery to the tool using the 3403 # package. See 'GetMeta' for where the merging happens. 3404 } 3405 3406 return 3407} 3408 3409proc ::critcl::ScanCore {lines theconfig} { 3410 # config = dictionary 3411 # - <cmdname> => mode (ok, warn, sub) 3412 # Unlisted commands are ignored. 3413 3414 variable scan::config $theconfig 3415 3416 set collect 0 3417 set buf {} 3418 set lno -1 3419 foreach line $lines { 3420 #puts |$line| 3421 3422 incr lno 3423 if {$collect} { 3424 if {![info complete $buf]} { 3425 append buf $line \n 3426 continue 3427 } 3428 set collect 0 3429 3430 #puts %%$buf%% 3431 3432 # Prevent heavily dynamic code from stopping the scan. 3433 # WARN the user. 3434 regexp {^(\S+)} $buf -> cmd 3435 if {[dict exists $config $cmd]} { 3436 set mode [dict get $config $cmd] 3437 3438 if {[catch { 3439 # Run in the scan namespace, with its special 3440 # command implementations. 3441 namespace eval ::critcl::scan $buf 3442 } msg]} { 3443 if {$mode eq "sub"} { 3444 regexp {^(\S+)\s+(\S+)} $buf -> _ method 3445 append cmd /$method 3446 set mode [dict get $config $cmd] 3447 } 3448 if {$mode eq "warn"} { 3449 msg "Line $lno, $cmd: Failed execution of dynamic command may" 3450 msg "Line $lno, $cmd: cause incorrect TEA results. Please check." 3451 msg "Line $lno, $cmd: $msg" 3452 } 3453 } 3454 } 3455 3456 set buf "" 3457 # fall through, to handle the line which just got NOT 3458 # added to the buf. 3459 } 3460 3461 set line [string trimleft $line " \t:"] 3462 if {[string trim $line] eq {}} continue 3463 3464 regexp {^(\S+)} $line -> cmd 3465 if {[dict exists $config $cmd]} { 3466 append buf $line \n 3467 set collect 1 3468 } 3469 } 3470} 3471 3472# Handle the extracted commands 3473namespace eval ::critcl::scan::critcl {} 3474 3475proc ::critcl::scan::critcl::buildrequirement {script} { 3476 # Recursive scan of the script, same configuration, except 3477 # switched to record 'package require's under the build::reqire 3478 # key. 3479 3480 variable ::critcl::scan::config 3481 variable ::critcl::scan::rkey 3482 3483 set saved $rkey 3484 set rkey build::require 3485 3486 ::critcl::ScanCore [split $script \n] $config 3487 3488 set rkey $saved 3489 return 3490} 3491 3492# Meta data. 3493# Capture specific dependencies 3494proc ::critcl::scan::critcl::tcl {version} { 3495 variable ::critcl::scan::capture 3496 dict update capture meta-system m { 3497 dict lappend m require [list Tcl $version] 3498 } 3499 return 3500} 3501 3502proc ::critcl::scan::critcl::tk {} { 3503 variable ::critcl::scan::capture 3504 dict update capture meta-system m { 3505 dict lappend m require Tk 3506 } 3507 return 3508} 3509 3510proc ::critcl::scan::critcl::description {text} { 3511 variable ::critcl::scan::capture 3512 dict set capture meta-system description \ 3513 [::critcl::Text2Words $text] 3514 return 3515} 3516 3517proc ::critcl::scan::critcl::summary {text} { 3518 variable ::critcl::scan::capture 3519 dict set capture meta-system summary \ 3520 [::critcl::Text2Words $text] 3521 return 3522} 3523 3524proc ::critcl::scan::critcl::subject {args} { 3525 variable ::critcl::scan::capture 3526 dict update capture meta-system m { 3527 foreach word $args { 3528 dict lappend m subject $word 3529 } 3530 } 3531 return 3532} 3533 3534proc ::critcl::scan::critcl::meta {key args} { 3535 variable ::critcl::scan::capture 3536 dict update capture meta-user m { 3537 foreach word $args { 3538 dict lappend m $key $word 3539 } 3540 } 3541 return 3542} 3543 3544# Capture files 3545proc ::critcl::scan::critcl::source {path} { 3546 # Recursively scan the imported file. 3547 # Keep the current context. 3548 variable ::critcl::scan::config 3549 3550 foreach f [Files $path] { 3551 set lines [split [::critcl::Cat $f] \n] 3552 ScanCore $lines $config 3553 } 3554 return 3555} 3556proc ::critcl::scan::critcl::owns {args} { eval [linsert $args 0 Files] } 3557proc ::critcl::scan::critcl::cheaders {args} { eval [linsert $args 0 Files] } 3558proc ::critcl::scan::critcl::csources {args} { eval [linsert $args 0 Files] } 3559proc ::critcl::scan::critcl::tsources {args} { 3560 variable ::critcl::scan::capture 3561 foreach ts [eval [linsert $args 0 Files]] { 3562 dict lappend capture tsources $ts 3563 } 3564 return 3565} 3566 3567proc ::critcl::scan::critcl::Files {args} { 3568 variable ::critcl::scan::capture 3569 set res {} 3570 foreach v $args { 3571 if {[string match "-*" $v]} continue 3572 foreach f [Expand $v] { 3573 dict lappend capture files $f 3574 lappend res $f 3575 } 3576 } 3577 return $res 3578} 3579 3580proc ::critcl::scan::critcl::Expand {pattern} { 3581 variable ::critcl::scan::base 3582 3583 # Note: We cannot use -directory here. The PATTERN may already be 3584 # an absolute path, in which case the join will return the 3585 # unmodified PATTERN to glob on, whereas with -directory the final 3586 # pattern will be BASE/PATTERN which won't find anything, even if 3587 # PATTERN actually exists. 3588 3589 set prefix [file split $base] 3590 3591 set files {} 3592 foreach vfile [glob [file join $base $pattern]] { 3593 set xfile [file normalize $vfile] 3594 if {![file exists $xfile]} { 3595 error "$vfile: not found" 3596 } 3597 3598 # Constrain to be inside of the base directory. 3599 # Snarfed from fileutil::stripPath 3600 3601 set npath [file split $xfile] 3602 3603 if {![string match -nocase "${prefix} *" $npath]} { 3604 error "$vfile: Not inside of $base" 3605 } 3606 3607 set xfile [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] 3608 lappend files $xfile 3609 } 3610 return $files 3611} 3612 3613# Capture license (org name) 3614proc ::critcl::scan::critcl::license {who args} { 3615 variable ::critcl::scan::capture 3616 dict set capture org $who 3617 3618 ::critcl::print "\tOrganization: $who" 3619 3620 # Meta data. 3621 set elicense [::critcl::LicenseText $args] 3622 3623 dict set capture meta-system license \ 3624 [::critcl::Text2Words $elicense] 3625 dict set capture meta-system author \ 3626 [::critcl::Text2Authors $who] 3627 return 3628} 3629 3630# Capture version of the provided package. 3631proc ::critcl::scan::package {cmd args} { 3632 if {$cmd eq "provide"} { 3633 # Syntax: package provide <name> <version> 3634 3635 variable capture 3636 lassign $args name version 3637 dict set capture name $name 3638 dict set capture version $version 3639 3640 # Save as meta data as well. 3641 3642 dict set capture meta-system name $name 3643 dict set capture meta-system version $version 3644 dict set capture meta-system platform source 3645 dict set capture meta-system generated::by \ 3646 [list \ 3647 [list critcl [::package present critcl]] \ 3648 $::tcl_platform(user)] 3649 dict set capture meta-system generated::date \ 3650 [list [clock format [clock seconds] -format {%Y-%m-%d}]] 3651 return 3652 } elseif {$cmd eq "require"} { 3653 # Syntax: package require <name> ?-exact? <version> 3654 # : package require <name> <version-range>... 3655 3656 # Save dependencies as meta data. 3657 3658 # Ignore the critcl core 3659 if {[lindex $args 0] eq "critcl"} return 3660 3661 variable capture 3662 variable rkey 3663 dict update capture meta-system m { 3664 dict lappend m $rkey [::critcl::TeapotRequire $args] 3665 } 3666 return 3667 } 3668 3669 # ignore anything else. 3670 return 3671} 3672 3673# Capture the APIs imported by the package 3674proc ::critcl::scan::critcl::api {cmd args} { 3675 variable ::critcl::scan::capture 3676 switch -exact -- $cmd { 3677 header { 3678 eval [linsert $args 0 Files] 3679 } 3680 import { 3681 # Syntax: critcl::api import <name> <version> 3682 lassign $args name _ 3683 dict lappend capture imported $name 3684 print "\tImported: $name" 3685 } 3686 default {} 3687 } 3688 return 3689} 3690 3691# Capture the user config options declared by the package 3692proc ::critcl::scan::critcl::userconfig {cmd args} { 3693 variable ::critcl::scan::capture 3694 switch -exact -- $cmd { 3695 define { 3696 # Syntax: critcl::userconfig define <name> <description> <type> ?<default>? 3697 lassign $args oname odesc otype odefault 3698 set odesc [string trim $odesc] 3699 if {[llength $args] < 4} { 3700 set odefault [::critcl::UcDefault $otype] 3701 } 3702 dict lappend capture config [list $oname $odesc $otype $odefault] 3703 print "\tUser Config: $oname ([join $otype { }] -> $odefault) $odesc" 3704 } 3705 set - query - 3706 default {} 3707 } 3708 return 3709} 3710 3711# # ## ### ##### ######## ############# ##################### 3712## Implementation -- Internals - cproc conversion helpers. 3713 3714proc ::critcl::EmitShimHeader {wname} { 3715 # Function head 3716 set ca "(ClientData cd, Tcl_Interp *interp, int oc, Tcl_Obj *CONST ov\[])" 3717 Emitln 3718 Emitln "static int" 3719 Emitln "$wname$ca" 3720 Emitln \{ 3721 return 3722} 3723 3724proc ::critcl::EmitShimVariables {adb rtype} { 3725 foreach d [dict get $adb vardecls] { 3726 Emitln " $d" 3727 } 3728 if {[dict get $adb hasoptional]} { 3729 Emitln " int idx_;" 3730 Emitln " int argc_;" 3731 } 3732 3733 # Result variable, source for the C -> Tcl conversion. 3734 if {$rtype ne "void"} { Emit " [ResultCType $rtype] rv;" } 3735 return 3736} 3737 3738proc ::critcl::EmitArgTracing {fun} { 3739 if {!$v::options(trace)} return 3740 Emitln "\n critcl_trace_cmd_args ($fun, oc, ov);" 3741 return 3742} 3743 3744proc ::critcl::EmitWrongArgsCheck {adb} { 3745 # Code checking for the correct count of arguments, and generating 3746 # the proper error if not. 3747 3748 set wac [dict get $adb wacondition] 3749 if {$wac eq {}} return 3750 3751 # Have a check, put the pieces together. 3752 3753 set offset [dict get $adb skip] 3754 set tsig [dict get $adb tsignature] 3755 set min [dict get $adb min] 3756 set max [dict get $adb max] 3757 3758 incr min $offset 3759 if {$max != Inf} { 3760 incr max $offset 3761 } 3762 3763 lappend map MIN_ARGS $min 3764 lappend map MAX_ARGS $max 3765 set wac [string map $map $wac] 3766 3767 Emitln "" 3768 Emitln " if ($wac) \{" 3769 Emitln " Tcl_WrongNumArgs(interp, $offset, ov, $tsig);" 3770 Emitln [TraceReturns "wrong-arg-num check" " return TCL_ERROR;"] 3771 Emitln " \}" 3772 Emitln "" 3773 return 3774} 3775 3776proc ::critcl::EmitSupport {adb} { 3777 set s [dict get $adb support] 3778 if {![llength $s]} return 3779 if {[join $s {}] eq {}} return 3780 Emit [join $s \n]\n 3781 return 3782} 3783 3784proc ::critcl::EmitCall {cname cnames rtype} { 3785 # Invoke the low-level function. 3786 3787 Emitln " /* Call - - -- --- ----- -------- */" 3788 Emit " " 3789 if {$rtype ne "void"} { Emit "rv = " } 3790 Emitln "${cname}([join $cnames {, }]);" 3791 Emitln 3792 return 3793} 3794 3795proc ::critcl::EmitConst {rtype rvalue} { 3796 # Assign the constant directly to the shim's result variable. 3797 3798 Emitln " /* Const - - -- --- ----- -------- */" 3799 Emit " " 3800 if {$rtype ne "void"} { Emit "rv = " } 3801 Emitln "${rvalue};" 3802 Emitln 3803 return 3804} 3805 3806proc ::critcl::TraceReturns {label code} { 3807 if {!$v::options(trace)} { 3808 return $code 3809 } 3810 3811 # Inject tracing into the 'return's. 3812 regsub -all \ 3813 {return[[:space:]]*([^;]*);} $code \ 3814 {return critcl_trace_cmd_result (\1, interp);} newcode 3815 if {[string match {*return *} $code] && ($newcode eq $code)} { 3816 error "Failed to inject tracing code into $label" 3817 } 3818 return $newcode 3819} 3820 3821proc ::critcl::EmitShimFooter {adb rtype} { 3822 # Run release code for arguments which allocated temp memory. 3823 set arelease [dict get $adb arelease] 3824 if {[llength $arelease]} { 3825 Emit "[join $arelease "\n "]\n" 3826 } 3827 3828 # Convert the returned low-level result from C to Tcl, if required. 3829 # Return a standard status, if required. 3830 3831 set code [Deline [ResultConversion $rtype]] 3832 if {$code ne {}} { 3833 set code [TraceReturns "\"$rtype\" result" $code] 3834 Emitln " /* ($rtype return) - - -- --- ----- -------- */" 3835 Emitln $code 3836 } else { 3837 if {$v::options(trace)} { 3838 Emitln " critcl_trace_header (1, 0, 0);" 3839 Emitln " critcl_trace_printf (1, \"RETURN (void)\");" 3840 Emitln " critcl_trace_closer (1);" 3841 Emitln " critcl_trace_pop();" 3842 Emitln " return;" 3843 } 3844 } 3845 Emitln \} 3846 return 3847} 3848 3849proc ::critcl::ArgumentSupport {type} { 3850 if {[info exists v::acsup($type)]} { return $v::acsup($type) } 3851 return {} 3852} 3853 3854proc ::critcl::ArgumentRelease {type} { 3855 if {[info exists v::acrel($type)]} { return $v::acrel($type) } 3856 return {} 3857} 3858 3859proc ::critcl::ArgumentCType {type} { 3860 if {[info exists v::actype($type)]} { return $v::actype($type) } 3861 return -code error "Unknown argument type \"$type\"" 3862} 3863 3864proc ::critcl::ArgumentCTypeB {type} { 3865 if {[info exists v::actypeb($type)]} { return $v::actypeb($type) } 3866 return -code error "Unknown argument type \"$type\"" 3867} 3868 3869proc ::critcl::ArgumentConversion {type} { 3870 if {[info exists v::aconv($type)]} { return $v::aconv($type) } 3871 return -code error "Unknown argument type \"$type\"" 3872} 3873 3874proc ::critcl::ResultCType {type} { 3875 if {[info exists v::rctype($type)]} { 3876 return $v::rctype($type) 3877 } 3878 return -code error "Unknown result type \"$type\"" 3879} 3880 3881proc ::critcl::ResultConversion {type} { 3882 if {[info exists v::rconv($type)]} { 3883 return $v::rconv($type) 3884 } 3885 return -code error "Unknown result type \"$type\"" 3886} 3887 3888# # ## ### ##### ######## ############# ##################### 3889## Implementation -- Internals - Manage complex per-file settings. 3890 3891proc ::critcl::GetParam {file type {default {}}} { 3892 if {[info exists v::code($file)] && 3893 [dict exists $v::code($file) config $type]} { 3894 return [dict get $v::code($file) config $type] 3895 } else { 3896 return $default 3897 } 3898} 3899 3900proc ::critcl::SetParam {type values {expand 1} {uuid 0} {unique 0}} { 3901 set file [This] 3902 if {![llength $values]} return 3903 3904 UUID.extend $file .$type $values 3905 3906 if {[llength $values]} { 3907 # Process the list of flags, treat non-option arguments as 3908 # glob patterns and expand them to a set of files, stored as 3909 # absolute paths. 3910 3911 set have {} 3912 if {$unique && [dict exists $v::code($file) config $type]} { 3913 foreach v [dict get $v::code($file) config $type] { 3914 dict set have $v . 3915 } 3916 } 3917 3918 set tmp {} 3919 foreach v $values { 3920 if {[string match "-*" $v]} { 3921 lappend tmp $v 3922 } else { 3923 if {$expand} { 3924 foreach f [Expand $file $v] { 3925 if {$unique && [dict exists $have $f]} continue 3926 lappend tmp $f 3927 if {$unique} { dict set have $f . } 3928 if {$uuid} { UUID.extend $file .$type.$f [Cat $f] } 3929 } 3930 } else { 3931 if {$unique && [dict exists $have $v]} continue 3932 lappend tmp $v 3933 if {$unique} { dict set have $v . } 3934 } 3935 } 3936 } 3937 3938 # And save into the system state. 3939 dict update v::code($file) config c { 3940 foreach v $tmp { 3941 dict lappend c $type $v 3942 } 3943 } 3944 } elseif {[dict exists $v::code($file) config $type]} { 3945 return [dict get $v::code($file) config $type] 3946 } 3947} 3948 3949proc ::critcl::Expand {file pattern} { 3950 set base [file dirname $file] 3951 3952 # Note: We cannot use -directory here. The PATTERN may already be 3953 # an absolute path, in which case the join will return the 3954 # unmodified PATTERN to glob on, whereas with -directory the final 3955 # pattern will be BASE/PATTERN which won't find anything, even if 3956 # PATTERN actually exists. 3957 3958 set files {} 3959 foreach vfile [glob [file join $base $pattern]] { 3960 set vfile [file normalize $vfile] 3961 if {![file exists $vfile]} { 3962 error "$vfile: not found" 3963 } 3964 lappend files $vfile 3965 } 3966 return $files 3967} 3968 3969proc ::critcl::InitializeFile {file} { 3970 if {![info exists v::code($file)]} { 3971 set v::code($file) {} 3972 3973 # Initialize the meta data sections (user (meta) and system 3974 # (package)). 3975 3976 dict set v::code($file) config meta {} 3977 3978 dict set v::code($file) config package platform \ 3979 [TeapotPlatform] 3980 dict set v::code($file) config package build::date \ 3981 [list [clock format [clock seconds] -format {%Y-%m-%d}]] 3982 3983 # May not exist, bracket code. 3984 if {![file exists $file]} return 3985 3986 ScanDependencies $file $file provide 3987 return 3988 } 3989 3990 if {![dict exists $v::code($file) config]} { 3991 dict set v::code($file) config {} 3992 } 3993 return 3994} 3995 3996# # ## ### ##### ######## ############# ##################### 3997## Implementation -- Internals - Management of in-memory C source fragment. 3998 3999proc ::critcl::name2c {name} { 4000 # Note: A slightly modified copy (different depth in the call-stack) of this 4001 # is inlined into the internal command "BeginCommand". 4002 4003 # Locate caller, as the data is saved per .tcl file. 4004 set file [This] 4005 4006 if {![string match ::* $name]} { 4007 # Locate caller's namespace. Two up, skipping the 4008 # ccommand/cproc frame. This is where the new Tcl command will 4009 # be defined in. 4010 4011 set ns [uplevel 1 namespace current] 4012 if {$ns ne "::"} { append ns :: } 4013 4014 set name ${ns}$name 4015 } 4016 4017 # First ensure that any namespace qualifiers found in the name 4018 # itself are shifted over to the namespace information. 4019 4020 set ns [namespace qualifiers $name] 4021 set name [namespace tail $name] 4022 4023 # Then ensure that everything is fully qualified, and that the C 4024 # level name doesn't contain bad characters. We have to remove any 4025 # non-alphabetic characters. A serial number is further required 4026 # to distinguish identifiers which would, despite having different 4027 # Tcl names, transform to the same C identifier. 4028 4029 if {$ns ne "::"} { append ns :: } 4030 set cns [string map {:: _} $ns] 4031 4032 regsub -all -- {[^a-zA-Z0-9_]} $name _ cname 4033 regsub -all -- {_+} $cname _ cname 4034 4035 regsub -all -- {[^a-zA-Z0-9_]} $cns _ cns 4036 regsub -all -- {_+} $cns _ cns 4037 4038 set cname $cname[UUID.serial $file] 4039 4040 return [list $ns $cns $name $cname] 4041} 4042 4043proc ::critcl::BeginCommand {visibility name args} { 4044 # Locate caller, as the data is saved per .tcl file. 4045 set file [This] 4046 4047 # Inlined name2c 4048 if {![string match ::* $name]} { 4049 # Locate caller's namespace. Two up, skipping the 4050 # ccommand/cproc frame. This is where the new Tcl command will 4051 # be defined in. 4052 4053 set ns [uplevel 2 namespace current] 4054 if {$ns ne "::"} { append ns :: } 4055 4056 set name ${ns}$name 4057 } 4058 4059 # First ensure that any namespace qualifiers found in the name 4060 # itself are shifted over to the namespace information. 4061 4062 set ns [namespace qualifiers $name] 4063 set name [namespace tail $name] 4064 4065 # Then ensure that everything is fully qualified, and that the C 4066 # level identifiers don't contain bad characters. We have to 4067 # remove any non-alphabetic characters. A serial number is further 4068 # required to distinguish identifiers which would, despite having 4069 # different Tcl names, transform to the same C identifier. 4070 4071 if {$ns ne "::"} { append ns :: } 4072 set cns [string map {:: _} $ns] 4073 4074 regsub -all -- {[^a-zA-Z0-9_]} $name _ cname 4075 regsub -all -- {_+} $cname _ cname 4076 4077 regsub -all -- {[^a-zA-Z0-9_]} $cns _ cns 4078 regsub -all -- {_+} $cns _ cns 4079 4080 set cname $cname[UUID.serial $file] 4081 4082 # Set the defered build-on-demand used by mode 'comile & run' up. 4083 # Note: Removing the leading :: because it trips Tcl's unknown 4084 # command, i.e. the command will not be found when called in a 4085 # script without leading ::. 4086 set ::auto_index([string trimleft $ns$name :]) [list [namespace current]::cbuild $file] 4087 4088 set v::curr [UUID.extend $file .function "$ns $name $args"] 4089 4090 dict update v::code($file) config c { 4091 dict lappend c functions $cns$cname 4092 dict lappend c fragments $v::curr 4093 } 4094 4095 if {$visibility eq "public"} { 4096 Emitln "#define ns_$cns$cname \"$ns$name\"" 4097 } 4098 return [list $ns $cns $name $cname] 4099} 4100 4101proc ::critcl::EndCommand {} { 4102 set file [This] 4103 4104 set v::code($v::curr) $v::block 4105 4106 dict set v::code($file) config block $v::curr $v::block 4107 4108 unset v::curr 4109 unset v::block 4110 return 4111} 4112 4113proc ::critcl::Emit {s} { 4114 append v::block $s 4115 return 4116} 4117 4118proc ::critcl::Emitln {{s ""}} { 4119 Emit $s\n 4120 return 4121} 4122 4123# # ## ### ##### ######## ############# ##################### 4124## At internal processing 4125 4126proc ::critcl::at::Where {leadoffset level file} { 4127 variable where 4128 4129 set line 1 4130 4131 # If the interpreter running critcl has TIP 280 support use it to 4132 # place more exact line number information into the generated C 4133 # file. 4134 4135 #puts "XXX-WHERE-($leadoffset $level $file)" 4136 #set ::errorInfo {} 4137 if {[catch { 4138 #::critcl::msg [SHOWFRAMES $level 0] 4139 array set loc [info frame $level] 4140 #puts XXX-TYPE-$loc(type) 4141 }]} { 4142 #puts XXX-NO-DATA-$::errorInfo 4143 set where {} 4144 return 4145 } 4146 4147 if {$loc(type) eq "source"} { 4148 #parray loc 4149 set file $loc(file) 4150 set fline $loc(line) 4151 4152 # Adjust for removed leading whitespace. 4153 ::incr fline $leadoffset 4154 4155 # Keep the limitations of native compilers in mind and stay 4156 # inside their bounds. 4157 4158 if {$fline > $line} { 4159 set line $fline 4160 } 4161 4162 set where [list [file tail $file] $line] 4163 return 4164 } 4165 4166 if {($loc(type) eq "eval") && 4167 [info exists loc(proc)] && 4168 ($loc(proc) eq "::critcl::source") 4169 } { 4170 # A relative location in critcl::source is absolute in the 4171 # sourced file. I.e. we can provide proper line information. 4172 4173 set fline $loc(line) 4174 # Adjust for removed leading whitespace. 4175 ::incr fline $leadoffset 4176 4177 # Keep the limitations of native compilers in mind and stay 4178 # inside their bounds. 4179 4180 if {$fline > $line} { 4181 set line $fline 4182 } 4183 4184 variable ::critcl::v::source 4185 set where [list [file tail $source] $line] 4186 return 4187 } 4188 4189 #puts XXX-NO-DATA-$loc(type) 4190 set where {} 4191 return 4192} 4193 4194proc ::critcl::at::CPragma {leadoffset level file} { 4195 # internal variant of 'caller!' 4196 ::incr level -1 4197 Where $leadoffset $level $file 4198 return [get] 4199} 4200 4201proc ::critcl::at::Format {loc} { 4202 if {![llength $loc]} { 4203 return "" 4204 } 4205 lassign $loc file line 4206 #::critcl::msg "#line $line \"$file\"\n" 4207 return "#line $line \"$file\"\n" 4208} 4209 4210proc ::critcl::at::SHOWFRAMES {level {all 1}} { 4211 set lines {} 4212 set n [info frame] 4213 set i 0 4214 set id 1 4215 while {$n} { 4216 lappend lines "[expr {$level == $id ? "**" : " "}] frame [format %3d $id]: [info frame $i]" 4217 ::incr i -1 4218 ::incr id -1 4219 ::incr n -1 4220 if {($level > $id) && !$all} break 4221 } 4222 return [join $lines \n] 4223} 4224 4225# # ## ### ##### ######## ############# ##################### 4226 4227proc ::critcl::CollectEmbeddedSources {file destination libfile ininame placestubs} { 4228 set fd [open $destination w] 4229 4230 if {[dict exists $v::code($file) result apiprefix]} { 4231 set api [dict get $v::code($file) result apiprefix] 4232 } else { 4233 set api "" 4234 } 4235 4236 # Boilerplate header. 4237 puts $fd [subst [Cat [Template header.c]]] 4238 # ^=> file, libfile, api 4239 4240 # Make Tk available, if requested 4241 if {[UsingTk $file]} { 4242 puts $fd "\n#include \"tk.h\"" 4243 } 4244 4245 # Write the collected C fragments, in order of collection. 4246 foreach digest [GetParam $file fragments] { 4247 puts $fd "[Separator]\n" 4248 puts $fd [dict get $v::code($file) config block $digest] 4249 } 4250 4251 # Boilerplate trailer. 4252 4253 # Stubs setup, Tcl, and, if requested, Tk as well. 4254 puts $fd [Separator] 4255 set mintcl [MinTclVersion $file] 4256 4257 if {$placestubs} { 4258 # Put full stubs definitions into the code, which can be 4259 # either the bracket generated for a -pkg, or the package 4260 # itself, build in mode "compile & run". 4261 set stubs [TclDecls $file] 4262 set platstubs [TclPlatDecls $file] 4263 puts -nonewline $fd [Deline [subst [Cat [Template stubs.c]]]] 4264 # ^=> mintcl, stubs, platstubs 4265 } else { 4266 # Declarations only, for linking, in the sub-packages. 4267 puts -nonewline $fd [Deline [subst [Cat [Template stubs_e.c]]]] 4268 # ^=> mintcl 4269 } 4270 4271 if {[UsingTk $file]} { 4272 SetupTkStubs $fd $mintcl 4273 } 4274 4275 # Initialization boilerplate. This ends in the middle of the 4276 # FOO_Init() function, leaving it incomplete. 4277 4278 set ext [GetParam $file edecls] 4279 puts $fd [subst [Cat [Template pkginit.c]]] 4280 # ^=> ext, ininame 4281 4282 # From here on we are completing FOO_Init(). 4283 # Tk setup first, if requested. (Tcl is already done). 4284 if {[UsingTk $file]} { 4285 puts $fd [Cat [Template pkginittk.c]] 4286 } 4287 4288 # User specified initialization code. 4289 puts $fd "[GetParam $file initc] " 4290 4291 # Setup of the variables serving up defined constants. 4292 if {[dict exists $v::code($file) config const]} { 4293 BuildDefines $fd $file 4294 } 4295 4296 # Take the names collected earlier and register them as Tcl 4297 # commands. 4298 set names [lsort [GetParam $file functions]] 4299 set max [LengthLongestWord $names] 4300 foreach name $names { 4301 if {[info exists v::clientdata($name)]} { 4302 set cd $v::clientdata($name) 4303 } else { 4304 set cd NULL 4305 } 4306 if {[info exists v::delproc($name)]} { 4307 set dp $v::delproc($name) 4308 } else { 4309 set dp 0 4310 } 4311 puts $fd " Tcl_CreateObjCommand(interp, [PadRight [expr {$max+4}] ns_$name,] [PadRight [expr {$max+5}] tcl_$name,] $cd, $dp);" 4312 } 4313 4314 # Complete the trailer and be done. 4315 puts $fd [Cat [Template pkginitend.c]] 4316 close $fd 4317 return 4318} 4319 4320proc ::critcl::MinTclVersion {file} { 4321 set required [GetParam $file mintcl 8.4] 4322 foreach version $v::hdrsavailable { 4323 if {[package vsatisfies $version $required]} { 4324 return $version 4325 } 4326 } 4327 return $required 4328} 4329 4330proc ::critcl::UsingTk {file} { 4331 return [GetParam $file tk 0] 4332} 4333 4334proc ::critcl::TclIncludes {file} { 4335 # Provide access to the Tcl/Tk headers using a -I flag pointing 4336 # into the critcl package directory hierarchy. No copying of files 4337 # required. This also handles the case of the X11 headers on 4338 # windows, for free. 4339 4340 set hdrs tcl[MinTclVersion $file] 4341 set path [file join $v::hdrdir $hdrs] 4342 4343 if {[file system $path] ne "native"} { 4344 # The critcl package is wrapped. Copy the relevant headers out 4345 # to disk and change the include path appropriately. 4346 4347 Copy $path [cache] 4348 set path [file join [cache] $hdrs] 4349 } 4350 4351 return [list $c::include$path] 4352} 4353 4354proc ::critcl::TclHeader {file {header {}}} { 4355 # Provide access to the Tcl/Tk headers in the critcl package 4356 # directory hierarchy. No copying of files required. 4357 set hdrs tcl[MinTclVersion $file] 4358 return [file join $v::hdrdir $hdrs $header] 4359} 4360 4361proc ::critcl::SystemIncludes {file} { 4362 set includes {} 4363 foreach dir [SystemIncludePaths $file] { 4364 lappend includes $c::include$dir 4365 } 4366 return $includes 4367} 4368 4369proc ::critcl::SystemIncludePaths {file} { 4370 set paths {} 4371 set has {} 4372 4373 # critcl -I options. 4374 foreach dir $v::options(I) { 4375 if {[dict exists $has $dir]} continue 4376 dict set has $dir yes 4377 lappend paths $dir 4378 } 4379 4380 # Result cache. 4381 lappend paths [cache] 4382 4383 # critcl::cheaders 4384 foreach flag [GetParam $file cheaders] { 4385 if {![string match "-*" $flag]} { 4386 # flag = normalized absolute path to a header file. 4387 # Transform into a -I directory reference. 4388 set dir [file dirname $flag] 4389 } else { 4390 # Chop leading -I 4391 set dir [string range $flag 2 end] 4392 } 4393 4394 if {[dict exists $has $dir]} continue 4395 dict set has $dir yes 4396 lappend paths $dir 4397 } 4398 4399 return $paths 4400} 4401 4402proc ::critcl::SystemLibraries {} { 4403 set libincludes {} 4404 foreach dir [SystemLibraryPaths] { 4405 lappend libincludes $c::libinclude$dir 4406 } 4407 return $libincludes 4408} 4409 4410proc ::critcl::SystemLibraryPaths {} { 4411 set paths {} 4412 set has {} 4413 4414 # critcl -L options. 4415 foreach dir $v::options(L) { 4416 if {[dict exists $has $dir]} continue 4417 dict set has $dir yes 4418 lappend paths $dir 4419 } 4420 4421 return $paths 4422} 4423 4424proc ::critcl::Compile {tclfile origin cfile obj} { 4425 StatusAbort? 4426 4427 # tclfile = The .tcl file under whose auspices the C is compiled. 4428 # origin = The origin of the C sources, either tclfile, or cfile. 4429 # cfile = The file holding the C sources to compile. 4430 # 4431 # 'origin == cfile' for the companion C files of a critcl file, 4432 # i.e. the csources. For a .tcl critcl file, the 'origin == 4433 # tclfile', and the cfile is the .c derived from tclfile. 4434 # 4435 # obj = Object file to compile to, to generate. 4436 4437 set cmdline [getconfigvalue compile] 4438 lappendlist cmdline [GetParam $tclfile cflags] 4439 lappendlist cmdline [getconfigvalue threadflags] 4440 if {$v::options(combine) ne "standalone"} { 4441 lappendlist cmdline [getconfigvalue tclstubs] 4442 } 4443 if {$v::options(language) ne "" && [file tail $tclfile] ne "critcl.tcl"} { 4444 # XXX Is this gcc specific ? 4445 # XXX Should this not be configurable via some c::* setting ? 4446 # See also -x none below. 4447 lappend cmdline -x $v::options(language) 4448 } 4449 lappendlist cmdline [TclIncludes $tclfile] 4450 lappendlist cmdline [SystemIncludes $tclfile] 4451 4452 if {[dict exists $v::code($tclfile) result apidefines]} { 4453 lappendlist cmdline [dict get $v::code($tclfile) result apidefines] 4454 } 4455 4456 lappendlist cmdline [CompileResult $obj] 4457 lappend cmdline $cfile 4458 4459 if {$v::options(language) ne ""} { 4460 # Allow the compiler to determine the type of file otherwise 4461 # it will try to compile the libs 4462 # XXX Is this gcc specific ? 4463 # XXX Should this not be configurable via some c::* setting ? 4464 lappend cmdline -x none 4465 } 4466 4467 # Add the Tk stubs to the command line, if requested and not suppressed 4468 if {[UsingTk $tclfile] && ($v::options(combine) ne "standalone")} { 4469 lappendlist cmdline [getconfigvalue tkstubs] 4470 } 4471 4472 if {!$option::debug_symbols} { 4473 lappendlist cmdline [getconfigvalue optimize] 4474 lappendlist cmdline [getconfigvalue noassert] 4475 } 4476 4477 if {[ExecWithLogging $cmdline \ 4478 {$obj: [file size $obj] bytes} \ 4479 {ERROR while compiling code in $origin:}]} { 4480 if {!$v::options(keepsrc) && $cfile ne $origin} { 4481 file delete $cfile 4482 } 4483 } 4484 4485 return $obj 4486} 4487 4488proc ::critcl::MakePreloadLibrary {file} { 4489 StatusAbort? 4490 4491 # compile and link the preload support, if necessary, i.e. not yet 4492 # done. 4493 4494 set shlib [file join [cache] preload[getconfigvalue sharedlibext]] 4495 if {[file exists $shlib]} return 4496 4497 # Operate like TclIncludes. Use the template file directly, if 4498 # possible, or, if we reside in a virtual filesystem, copy it to 4499 # disk. 4500 4501 set src [Template preload.c] 4502 if {[file system $src] ne "native"} { 4503 file mkdir [cache] 4504 file copy -force $src [cache] 4505 set src [file join [cache] preload.c] 4506 } 4507 4508 # Build the object for the helper package, 'preload' ... 4509 4510 set obj [file join [cache] preload.o] 4511 Compile $file $src $src $obj 4512 4513 # ... and link it. 4514 # Custom linker command. XXX Can we bent Link to the task? 4515 set cmdline [getconfigvalue link] 4516 lappend cmdline $obj 4517 lappendlist cmdline [getconfigvalue strip] 4518 lappendlist cmdline [LinkResult $shlib] 4519 4520 ExecWithLogging $cmdline \ 4521 {$shlib: [file size $shlib] bytes} \ 4522 {ERROR while linking $shlib:} 4523 4524 # Now the critcl application can pick up this helper shlib and 4525 # stuff it into the package it is making. 4526 return 4527} 4528 4529proc ::critcl::Link {file} { 4530 StatusAbort? 4531 4532 set shlib [dict get $v::code($file) result shlib] 4533 set preload [dict get $v::code($file) result preload] 4534 4535 # Assemble the link command. 4536 set cmdline [getconfigvalue link] 4537 4538 if {[llength $preload]} { 4539 lappendlist cmdline [getconfigvalue link_preload] 4540 } 4541 4542 if {$option::debug_symbols} { 4543 lappendlist cmdline [getconfigvalue link_debug] 4544 } else { 4545 lappendlist cmdline [getconfigvalue strip] 4546 lappendlist cmdline [getconfigvalue link_release] 4547 } 4548 4549 lappendlist cmdline [LinkResult $shlib] 4550 lappendlist cmdline [GetObjects $file] 4551 lappendlist cmdline [SystemLibraries] 4552 lappendlist cmdline [GetLibraries $file] 4553 lappendlist cmdline [dict get $v::code($file) result ldflags] 4554 # lappend cmdline bufferoverflowU.lib ;# msvc >=1400 && <1500 for amd64 4555 4556 # Run the linker 4557 ExecWithLogging $cmdline \ 4558 {$shlib: [file size $shlib] bytes} \ 4559 {ERROR while linking $shlib:} 4560 4561 # Now, if there is a manifest file around, and the 4562 # 'embed_manifest' command defined we use its command to merge the 4563 # manifest into the shared library. This is pretty much only 4564 # happening on Windows platforms, and with newer dev environments 4565 # actually using manifests. 4566 4567 set em [getconfigvalue embed_manifest] 4568 4569 critcl::Log "Manifest Command: $em" 4570 critcl::Log "Manifest File: [expr {[file exists $shlib.manifest] 4571 ? "$shlib.manifest" 4572 : "<<not present>>, ignored"}]" 4573 4574 if {[llength $em] && [file exists $shlib.manifest]} { 4575 set cmdline [ManifestCommand $em $shlib] 4576 4577 # Run the manifest tool 4578 ExecWithLogging $cmdline \ 4579 {$shlib: [file size $shlib] bytes, with manifest} \ 4580 {ERROR while embedding the manifest into $shlib:} 4581 } 4582 4583 # At last, build the preload support library, if necessary. 4584 if {[llength $preload]} { 4585 MakePreloadLibrary $file 4586 } 4587 return 4588} 4589 4590proc ::critcl::ManifestCommand {em shlib} { 4591 # Variable used by the subst'able config setting. 4592 set outfile $shlib 4593 return [subst $em] 4594} 4595 4596proc ::critcl::CompanionObject {src} { 4597 set tail [file tail $src] 4598 set srcbase [file rootname $tail] 4599 4600 if {[cache] ne [file dirname $src]} { 4601 set srcbase [file tail [file dirname $src]]_$srcbase 4602 } 4603 4604 return [file join [cache] ${srcbase}[getconfigvalue object]] 4605} 4606 4607proc ::critcl::CompileResult {object} { 4608 # Variable used by the subst'able config setting. 4609 set outfile $object 4610 return [subst $c::output] 4611} 4612 4613proc ::critcl::LinkResult {shlib} { 4614 # Variable used by the subst'able config setting. 4615 set outfile $shlib 4616 4617 set ldout [subst $c::ldoutput] 4618 if {$ldout eq ""} { 4619 set ldout [subst $c::output] 4620 } 4621 4622 return $ldout 4623} 4624 4625proc ::critcl::GetObjects {file} { 4626 # On windows using the native MSVC compiler put the companion 4627 # object files into a link file to read, instead of separately on 4628 # the command line. 4629 4630 set objects [dict get $v::code($file) result objects] 4631 4632 if {![string match "win32-*-cl" $v::buildplatform]} { 4633 return $objects 4634 } 4635 4636 set rsp [WriteCache link.fil \"[join $objects \"\n\"]\"] 4637 return [list @$rsp] 4638} 4639 4640proc ::critcl::GetLibraries {file} { 4641 # On windows using the native MSVC compiler, transform all -lFOO 4642 # references into FOO.lib. 4643 4644 return [FixLibraries [dict get $v::code($file) result clibraries]] 4645} 4646 4647proc ::critcl::FixLibraries {libraries} { 4648 if {[string match "win32-*-cl" $v::buildplatform]} { 4649 # On windows using the native MSVC compiler, transform all 4650 # -lFOO references into FOO.lib. 4651 4652 regsub -all -- {-l(\S+)} $libraries {\1.lib} libraries 4653 } else { 4654 # On unix we look for '-l:' references and rewrite them to the 4655 # full path of the library, doing the search on our own. 4656 # 4657 # GNU ld understands this since at least 2.22 (don't know if 4658 # earlier, 2.15 definitely doesn't), and it helps in 4659 # specifying static libraries (Regular -l prefers .so over .a, 4660 # and -l: overrides that). 4661 4662 # Search paths specified via -L, -libdir. 4663 set lpath [SystemLibraryPaths] 4664 4665 set tmp {} 4666 foreach word $libraries { 4667 # Extend search path with -L options from clibraries. 4668 if {[string match -L* $word]} { 4669 lappend lpath [string range $word 2 end] 4670 lappend tmp $word 4671 continue 4672 } 4673 if {![string match -l:* $word]} { 4674 lappend tmp $word 4675 continue 4676 } 4677 # Search named library. 4678 lappend tmp [ResolveColonSpec $lpath [string range $word 3 end]] 4679 } 4680 set libraries $tmp 4681 } 4682 4683 return $libraries 4684} 4685 4686proc ::critcl::ResolveColonSpec {lpath name} { 4687 foreach path $lpath { 4688 set f [file join $lpath $name] 4689 if {![file exists $f]} continue 4690 return $f 4691 } 4692 return -l:$name 4693} 4694 4695proc ::critcl::SetupTkStubs {fd mintcl} { 4696 if {[package vcompare $mintcl 8.6] != 0} { 4697 # Not 8.6. tkStubsPtr and tkIntXlibStubsPtr are not const yet. 4698 set contents [Cat [Template tkstubs_noconst.c]] 4699 } else { 4700 set contents [Cat [Template tkstubs.c]] 4701 } 4702 4703 puts -nonewline $fd $contents 4704 return 4705} 4706 4707proc ::critcl::BuildDefines {fd file} { 4708 # we process the cdefines in three steps 4709 # - get the list of defines by preprocessing the source using the 4710 # cpp -dM directive which causes any #defines to be output 4711 # - extract the list of enums using regular expressions (not perfect, 4712 # but will do for now) 4713 # - generate Tcl_ObjSetVar2 commands to initialise Tcl variables 4714 4715 # Pull the collected ccode blocks together into a transient file 4716 # we then search in. 4717 4718 set def [WriteCache define_[pid].c {}] 4719 foreach digest [dict get $v::code($file) config defs] { 4720 Append $def [dict get $v::code($file) config block $digest] 4721 } 4722 4723 # For the command lines to be constructed we need all the include 4724 # information the regular files will get during their compilation. 4725 4726 set hdrs [SystemIncludes $file] 4727 4728 # The result of the next two steps, a list of triples (namespace + 4729 # label + value) of the defines to export. 4730 4731 set defines {} 4732 4733 # First step - get list of matching defines 4734 set cmd [getconfigvalue preproc_define] 4735 lappendlist cmd $hdrs 4736 lappend cmd $def 4737 4738 set pipe [open "| $cmd" r] 4739 while {[gets $pipe line] >= 0} { 4740 # Check if the line contains a define. 4741 set fields [split [string trim $line]] 4742 if {[lindex $fields 0] ne "#define"} continue 4743 4744 # Yes. Get name and value. The latter is the joining of all 4745 # fields after the name, except for any enclosing parentheses, 4746 # which we strip off. 4747 4748 set var [lindex $fields 1] 4749 set val [string trim [join [lrange $fields 2 end]] {()}] 4750 4751 # We ignore however any and all defines the user is not 4752 # interested in making public. This is, in essence, a set 4753 # intersection on the names of the defines. 4754 4755 if {![TakeDefine $file $var namespace]} continue 4756 4757 # And for those which are kept we integrate the information 4758 # from both sources, i.e. namespace, and definition, under a 4759 # single name. 4760 4761 lappend defines $namespace $var $val 4762 } 4763 close $pipe 4764 4765 # Second step - get list of enums 4766 4767 set cmd [getconfigvalue preproc_enum] 4768 lappendlist cmd $hdrs 4769 lappend cmd $def 4770 4771 set pipe [open "| $cmd" r] 4772 set code [read $pipe] 4773 close $pipe 4774 4775 set matches [regexp -all -inline {enum [^\{\(\)]*{([^\}]*)}} $code] 4776 foreach {match submatch} $matches { 4777 foreach line [split $submatch \n] { 4778 foreach sub [split $line ,] { 4779 set enum [lindex [split [string trim $sub]] 0] 4780 4781 # We ignore however any and all enum values the user 4782 # is not interested in making public. This is, in 4783 # essence, a set intersection on the names of the 4784 # enum values. 4785 4786 if {![TakeDefine $file $enum namespace]} continue 4787 4788 # And for those which are kept we integrate the 4789 # information from both sources, i.e. namespace, and 4790 # definition, under a single name. 4791 4792 lappend defines $namespace $enum $enum 4793 } 4794 } 4795 } 4796 4797 # Third step - generate Tcl_ObjSetVar2 commands exporting the 4798 # defines and their values as Tcl variables. 4799 4800 foreach {namespace constname constvalue} $defines { 4801 if {![info exists created($namespace)]} { 4802 # we need to force the creation of the namespace 4803 # because this code will be run before the user code 4804 puts $fd " Tcl_Eval(ip, \"namespace eval $namespace {}\");" 4805 set created($namespace) 1 4806 } 4807 set var "Tcl_NewStringObj(\"${namespace}::$constname\", -1)" 4808 if {$constname eq $constvalue} { 4809 # enum - assume integer 4810 set constvalue "Tcl_NewIntObj($constvalue)" 4811 } else { 4812 # text or int - force to string 4813 set constvalue "Tcl_NewStringObj(\"$constvalue\", -1)" 4814 } 4815 puts $fd " Tcl_ObjSetVar2(ip, $var, NULL, $constvalue, TCL_GLOBAL_ONLY);" 4816 } 4817 4818 # Cleanup after ourselves, removing the helper file. 4819 4820 if {!$v::options(keepsrc)} { file delete $def } 4821 return 4822} 4823 4824proc ::critcl::TakeDefine {file identifier nsvar} { 4825 upvar 1 $nsvar dst 4826 if 0 {if {[dict exists $v::code($file) config const $identifier]} { 4827 set dst [dict get $v::code($file) config const $identifier] 4828 return 1 4829 }} 4830 foreach {pattern def} [dict get $v::code($file) config const] { 4831 if {[string match $pattern $identifier]} { 4832 set dst $def 4833 return 1 4834 } 4835 } 4836 return 0 4837} 4838 4839proc ::critcl::Load {f} { 4840 set shlib [dict get $v::code($f) result shlib] 4841 set init [dict get $v::code($f) result initname] 4842 set tsrc [dict get $v::code($f) result tsources] 4843 set minv [dict get $v::code($f) result mintcl] 4844 4845 # Using the renamed builtin. While this is a dependency it was 4846 # recorded already. See 'critcl::tcl', and 'critcl::tk'. 4847 #package require Tcl $minv 4848 ::load $shlib $init 4849 4850 # See the critcl application for equivalent code placing the 4851 # companion tcl sources into the generated package. Here, for 4852 # 'compile & run' we now source the companion files directly. 4853 foreach t $tsrc { 4854 Ignore $t 4855 ::source $t 4856 } 4857 return 4858} 4859 4860proc ::critcl::HandleDeclAfterBuild {} { 4861 # Hook default, mode "compile & run". Clear existing build results 4862 # for the file, make way for new declarations. 4863 4864 set fx [This] 4865 if {[info exists v::code($fx)] && 4866 [dict exists $v::code($fx) result]} { 4867 dict unset v::code($fx) result 4868 } 4869 return 4870} 4871 4872# XXX Refactor to avoid duplication of the memoization code. 4873proc ::critcl::DetermineShlibName {file} { 4874 # Return cached information, if present. 4875 if {[info exists v::code($file)] && 4876 [dict exists $v::code($file) result shlib]} { 4877 return [dict get $v::code($file) result shlib] 4878 } 4879 4880 # The name of the shared library we hope to produce (or use) 4881 set shlib [BaseOf $file][getconfigvalue sharedlibext] 4882 4883 dict set v::code($file) result shlib $shlib 4884 return $shlib 4885} 4886 4887proc ::critcl::DetermineObjectName {file} { 4888 # Return cached information, if present. 4889 if {[info exists v::code($file)] && 4890 [dict exists $v::code($file) result object]} { 4891 return [dict get $v::code($file) result object] 4892 } 4893 4894 set object [BaseOf $file] 4895 4896 # The generated object file will be saved for permanent use if the 4897 # outdir option is set (in which case rebuilds will no longer be 4898 # automatic). 4899 if {$v::options(outdir) ne ""} { 4900 set odir [file join [file dirname $file] $v::options(outdir)] 4901 set oroot [file rootname [file tail $file]] 4902 set object [file normalize [file join $odir $oroot]] 4903 file mkdir $odir 4904 } 4905 4906 # Modify the output file name if debugging symbols are requested. 4907 if {$option::debug_symbols} { 4908 append object _g 4909 } 4910 4911 # Choose a distinct suffix so switching between them causes a 4912 # rebuild. 4913 switch -- $v::options(combine) { 4914 "" - 4915 dynamic { append object _pic[getconfigvalue object] } 4916 static { append object _stub[getconfigvalue object] } 4917 standalone { append object [getconfigvalue object] } 4918 } 4919 4920 dict set v::code($file) result object $object 4921 return $object 4922} 4923 4924proc ::critcl::DetermineInitName {file prefix} { 4925 set ininame [PkgInit $file] 4926 4927 # Add in the build prefix, if specified. This is done in mode 4928 # 'generate package', for the pieces, ensuring that the overall 4929 # initialization function cannot be in conflict with the 4930 # initialization functions of these same pieces. 4931 4932 if {$prefix ne ""} { 4933 set ininame "${prefix}_$ininame" 4934 } 4935 4936 dict set v::code($file) result initname $ininame 4937 4938 catch { 4939 dict set v::code($file) result pkgname \ 4940 [dict get $v::code($file) config package name] 4941 } 4942 4943 return $ininame 4944} 4945 4946proc ::critcl::PkgInit {file} { 4947 # The init function name takes a capitalized prefix from the name 4948 # of the input file name (alphanumeric prefix, including 4949 # underscores). This implicitly drops the file extension, as the 4950 # '.' is not an allowed character. 4951 4952 # While related to the package name, it can be different, 4953 # especially if the package name contains :: separators. 4954 4955 if {$file eq {}} { 4956 return Stdin 4957 } else { 4958 set ininame [file rootname [file tail $file]] 4959 regsub -all {[^[:alnum:]_]} $ininame {} ininame 4960 return [string totitle $ininame] 4961 } 4962} 4963 4964# # ## ### ##### ######## ############# ##################### 4965## Implementation -- Internals - Access to the log file 4966 4967proc ::critcl::LogFile {} { 4968 file mkdir [cache] 4969 return [file join [cache] [pid].log] 4970} 4971 4972proc ::critcl::LogFileExec {} { 4973 file mkdir [cache] 4974 return [file join [cache] [pid]_exec.log] 4975} 4976 4977proc ::critcl::LogOpen {file} { 4978 set v::logfile [LogFile] 4979 set v::log [open $v::logfile w] 4980 puts $v::log "\n[clock format [clock seconds]] - $file" 4981 # Create secondary file as well, leave empty, may not be used. 4982 close [open ${v::logfile}_ w] 4983 return 4984} 4985 4986proc ::critcl::LogCmdline {cmdline} { 4987 set w [join [lassign $cmdline cmd] \n\t] 4988 Log \n$cmd\n\t$w\n 4989 return 4990} 4991 4992proc ::critcl::Log {msg} { 4993 puts $v::log $msg 4994 return 4995} 4996 4997proc ::critcl::Log* {msg} { 4998 puts -nonewline $v::log $msg 4999 return 5000} 5001 5002proc ::critcl::LogClose {} { 5003 # Transfer the log messages for the current file over into the 5004 # global critcl log, and cleanup. 5005 5006 close $v::log 5007 set msgs [Cat $v::logfile] 5008 set emsg [Cat ${v::logfile}_] 5009 5010 AppendCache $v::prefix.log $msgs 5011 5012 file delete -force $v::logfile ${v::logfile}_ 5013 unset v::log v::logfile 5014 5015 return [list $msgs $emsg] 5016} 5017 5018# # ## ### ##### ######## ############# ##################### 5019## Implementation -- Internals - UUID management, change detection 5020 5021proc ::critcl::UUID.extend {file key value} { 5022 set digest [md5_hex /$value] 5023 InitializeFile $file 5024 dict update v::code($file) config c { 5025 dict lappend c uuid $key $digest 5026 } 5027 return $digest 5028} 5029 5030proc ::critcl::UUID.serial {file} { 5031 InitializeFile $file 5032 if {[catch { 5033 set len [llength [dict get $v::code($file) config uuid]] 5034 }]} { 5035 set len 0 5036 } 5037 return $len 5038} 5039 5040proc ::critcl::UUID {f} { 5041 return [md5_hex "$f [GetParam $f uuid]"] 5042} 5043 5044proc ::critcl::BaseOf {f} { 5045 # Return cached information, if present. 5046 if {[info exists v::code($f)] && 5047 [dict exists $v::code($f) result base]} { 5048 return [dict get $v::code($f) result base] 5049 } 5050 5051 set base [file normalize \ 5052 [file join [cache] ${v::prefix}_[UUID $f]]] 5053 5054 dict set v::code($f) result base $base 5055 return $base 5056} 5057 5058# # ## ### ##### ######## ############# ##################### 5059## Implementation -- Internals - Miscellanea 5060 5061proc ::critcl::Deline {text} { 5062 if {![config lines]} { 5063 set text [join [GrepV "\#line*" [split $text \n]] \n] 5064 } 5065 return $text 5066} 5067 5068proc ::critcl::Separator {} { 5069 return "/* [string repeat - 70] */" 5070} 5071 5072proc ::critcl::Template {file} { 5073 variable v::hdrdir 5074 return [file join $hdrdir $file] 5075} 5076 5077proc ::critcl::Copy {src dst} { 5078 foreach p [glob -nocomplain $src] { 5079 if {[file isdirectory $p]} { 5080 set stem [file tail $p] 5081 file mkdir $dst/$stem 5082 Copy $p/* $dst/$stem 5083 } else { 5084 file copy -force $p $dst 5085 } 5086 } 5087} 5088 5089proc ::critcl::Cat {path} { 5090 # Easier to write our own copy than requiring fileutil and then 5091 # using fileutil::cat. 5092 5093 set fd [open $path r] 5094 set data [read $fd] 5095 close $fd 5096 return $data 5097} 5098 5099proc ::critcl::WriteCache {name content} { 5100 set dst [file join [cache] $name] 5101 file mkdir [file dirname $dst] ;# just in case 5102 return [Write [file normalize $dst] $content] 5103} 5104 5105proc ::critcl::Write {path content} { 5106 set chan [open $path w] 5107 puts $chan $content 5108 close $chan 5109 return $path 5110} 5111 5112proc ::critcl::AppendCache {name content} { 5113 file mkdir [cache] ;# just in case 5114 return [Append [file normalize [file join [cache] $name]] $content] 5115} 5116 5117proc ::critcl::Append {path content} { 5118 set chan [open $path a] 5119 puts $chan $content 5120 close $chan 5121 return $path 5122} 5123 5124# # ## ### ##### ######## ############# ##################### 5125## Implementation -- Internals - Status Operations, and execution 5126## of external commands. 5127 5128proc ::critcl::StatusReset {} { 5129 set v::failed 0 5130 return 5131} 5132 5133proc ::critcl::StatusAbort? {} { 5134 if {$v::failed} { return -code return } 5135 return 5136} 5137 5138proc ::critcl::StatusSave {file} { 5139 # XXX FUTURE Use '$(file) result failed' later 5140 set result $v::failed 5141 set v::code($file,failed) $v::failed 5142 set v::failed 0 5143 return $result 5144} 5145 5146proc ::critcl::CheckForWarnings {text} { 5147 set warnings [dict create] 5148 foreach line [split $text \n] { 5149 # Ignore everything not a warning. 5150 if {![string match -nocase *warning* $line]} continue 5151 # Ignore duplicates (which is why we store the lines as dict 5152 # keys for now). 5153 if {[dict exists $warnings $line]} continue 5154 dict set warnings $line . 5155 } 5156 return [dict keys $warnings] 5157} 5158 5159proc ::critcl::Exec {cmdline} { 5160 variable run 5161 5162 set v::failed [catch { 5163 interp eval $run [linsert $cmdline 0 exec] 5164 } v::err] 5165 5166 return [expr {!$v::failed}] 5167} 5168 5169proc ::critcl::ExecWithLogging {cmdline okmsg errmsg} { 5170 variable run 5171 5172 LogCmdline $cmdline 5173 5174 # Extend the command, redirect all of its output (stdout and 5175 # stderr) into a temp log. 5176 set elogfile [LogFileExec] 5177 set elog [open $elogfile w] 5178 5179 lappend cmdline >&@ $elog 5180 interp transfer {} $elog $run 5181 5182 set ok [Exec $cmdline] 5183 5184 interp transfer $run $elog {} 5185 close $elog 5186 5187 # Put the command output into the main log ... 5188 set msgs [Cat $elogfile] 5189 Log $msgs 5190 5191 # ... as well as into a separate execution log. 5192 Append ${v::logfile}_ $msgs 5193 5194 file delete -force $elogfile 5195 5196 if {$ok} { 5197 Log [uplevel 1 [list subst $okmsg]] 5198 } else { 5199 Log [uplevel 1 [list subst $errmsg]] 5200 Log $v::err 5201 } 5202 5203 return $ok 5204} 5205 5206proc ::critcl::BuildPlatform {} { 5207 set platform [::platform::generic] 5208 5209 # Behave like an autoconf generated configure 5210 # - $CC (user's choice first) 5211 # - gcc, if available. 5212 # - cc/cl otherwise (without further check for availability) 5213 5214 if {[info exists ::env(CC)]} { 5215 # The compiler may be a gcc, despite being named .../cc. 5216 5217 set cc $::env(CC) 5218 if {[IsGCC $cc]} { 5219 set cc gcc 5220 } 5221 } elseif {[llength [auto_execok gcc]]} { 5222 set cc gcc 5223 } else { 5224 if {[string match "win32-*" $platform]} { 5225 set cc cl 5226 } else { 5227 set cc cc 5228 } 5229 } 5230 5231 # The cc may be specified with a full path, through the CC 5232 # environment variable, which cannot be used as is in the platform 5233 # code. Use only the last element of the path, without extensions 5234 # (.exe). And it may be followed by options too, so look for and 5235 # strip these off as well. This last part assumes that the path of 5236 # the compiler itself doesn't contain spaces. 5237 5238 regsub {( .*)$} [file tail $cc] {} cc 5239 append platform -[file rootname $cc] 5240 5241 # Memoize 5242 proc ::critcl::BuildPlatform {} [list return $platform] 5243 return $platform 5244} 5245 5246proc ::critcl::IsGCC {path} { 5247 if {[catch { 5248 set lines [exec $path -v |& grep gcc] 5249 }] || ($lines eq {})} { return 0 } 5250 return 1 5251} 5252 5253proc ::critcl::This {} { 5254 variable v::this 5255 # For management of v::this see critcl::{source,collect*} 5256 # If present, an output redirection is active. 5257 if {[info exists this] && [llength $this]} { 5258 return [lindex $this end] 5259 } 5260 return [file normalize [info script]] 5261} 5262 5263proc ::critcl::Here {} { 5264 return [file dirname [This]] 5265} 5266 5267proc ::critcl::TclDecls {file} { 5268 return [TclDef $file tclDecls.h tclStubsPtr {tclStubsPtr }] 5269} 5270 5271proc ::critcl::TclPlatDecls {file} { 5272 return [TclDef $file tclPlatDecls.h tclPlatStubsPtr tclPlatStubsPtr] 5273} 5274 5275proc ::critcl::TclDef {file hdr var varlabel} { 5276 #puts F|$file 5277 set hdr [TclHeader $file $hdr] 5278 5279 if {![file exists $hdr]} { error "Header file not found: $hdr" } 5280 if {![file isfile $hdr]} { error "Header not a file: $hdr" } 5281 if {![file readable $hdr]} { error "Header not readable: $hdr (no permission)" } 5282 5283 #puts H|$hdr 5284 if {[catch { 5285 set hdrcontent [split [Cat $hdr] \n] 5286 } msg]} { 5287 error "Header not readable: $hdr ($msg)" 5288 } 5289 5290 # Note, Danger: The code below is able to use declarations which 5291 # are commented out in various ways (#if 0, /* ... */, and // 5292 # ...), because it is performing a simple line-oriented search 5293 # without context, and not matching against comment syntax either. 5294 5295 set ext [Grep *extern* $hdrcontent] 5296 if {![llength $ext]} { 5297 error "No extern declarations found in $hdr" 5298 } 5299 5300 set vardecl [Grep *${var}* $ext] 5301 if {![llength $vardecl]} { 5302 error "No declarations for $var found in $hdr" 5303 } 5304 5305 set def [string map {extern {}} [lindex $vardecl 0]] 5306 msg " ($varlabel => $def)" 5307 return $def 5308} 5309 5310proc ::critcl::Grep {pattern lines} { 5311 set r {} 5312 foreach line $lines { 5313 if {![string match $pattern $line]} continue 5314 lappend r $line 5315 } 5316 return $r 5317} 5318 5319proc ::critcl::GrepV {pattern lines} { 5320 set r {} 5321 foreach line $lines { 5322 if {[string match $pattern $line]} continue 5323 lappend r $line 5324 } 5325 return $r 5326} 5327 5328proc ::critcl::PadRight {len w} { 5329 # <=> Left justified 5330 format %-${len}s $w 5331} 5332 5333proc ::critcl::LengthLongestWord {words} { 5334 set max 0 5335 foreach w $words { 5336 set n [string length $w] 5337 if {$n <= $max} continue 5338 set max $n 5339 } 5340 return $max 5341} 5342 5343# # ## ### ##### ######## ############# ##################### 5344## Initialization 5345 5346proc ::critcl::Initialize {} { 5347 variable mydir [Here] ; # Path of the critcl package directory. 5348 5349 variable run [interp create] 5350 variable v::buildplatform [BuildPlatform] 5351 variable v::hdrdir [file join $mydir critcl_c] 5352 variable v::hdrsavailable 5353 variable v::storageclass [Cat [file join $hdrdir storageclass.c]] 5354 5355 # Scan the directory holding the C fragments and our copies of the 5356 # Tcl header and determine for which versions of Tcl we actually 5357 # have headers. This allows distributions to modify the directory, 5358 # i.e. drop our copies and refer to the system headers instead, as 5359 # much as are installed, and critcl adapts. The tcl versions are 5360 # recorded in ascending order, making upcoming searches easier, 5361 # the first satisfying version is also always the smallest. 5362 5363 foreach d [lsort -dict [glob -types {d r} -directory $hdrdir -tails tcl*]] { 5364 lappend hdrsavailable [regsub {^tcl} $d {}] 5365 } 5366 5367 # The prefix is based on the package's version. This allows 5368 # multiple versions of the package to use the same cache without 5369 # interfering with each. Note that we cannot use 'pid' and similar 5370 # information, because this would circumvent the goal of the 5371 # cache, the reuse of binaries whose sources did not change. 5372 5373 variable v::prefix "v[package require critcl]" 5374 5375 regsub -all {\.} $prefix {} prefix 5376 5377 # keep config options in a namespace 5378 foreach var $v::configvars { 5379 set c::$var {} 5380 } 5381 5382 # read default configuration. This also chooses and sets the 5383 # target platform. 5384 readconfig [file join $mydir Config] 5385 5386 # Declare the standard argument types for cproc. 5387 5388 argtype int { 5389 if (Tcl_GetIntFromObj(interp, @@, &@A) != TCL_OK) return TCL_ERROR; 5390 } 5391 argtype boolean { 5392 if (Tcl_GetBooleanFromObj(interp, @@, &@A) != TCL_OK) return TCL_ERROR; 5393 } int int 5394 argtype bool = boolean 5395 5396 argtype long { 5397 if (Tcl_GetLongFromObj(interp, @@, &@A) != TCL_OK) return TCL_ERROR; 5398 } 5399 5400 argtype wideint { 5401 if (Tcl_GetWideIntFromObj(interp, @@, &@A) != TCL_OK) return TCL_ERROR; 5402 } Tcl_WideInt Tcl_WideInt 5403 5404 argtype double { 5405 if (Tcl_GetDoubleFromObj(interp, @@, &@A) != TCL_OK) return TCL_ERROR; 5406 } 5407 argtype float { 5408 double t; 5409 if (Tcl_GetDoubleFromObj(interp, @@, &t) != TCL_OK) return TCL_ERROR; 5410 @A = (float) t; 5411 } 5412 5413 # Premade scalar type derivations for common range restrictions. 5414 # Look to marker XXXA for the places where auto-creation would 5415 # need fitting in (future). 5416 foreach type { 5417 int long wideint double float 5418 } { 5419 set ctype [ArgumentCType $type] 5420 set code [ArgumentConversion $type] 5421 foreach restriction { 5422 {> 0} {>= 0} {> 1} {>= 1} 5423 {< 0} {<= 0} {< 1} {<= 1} 5424 } { 5425 set ntype "$type $restriction" 5426 set head "expected $ntype, but got \\\"" 5427 set tail "\\\"" 5428 set msg "\"$head\", Tcl_GetString (@@), \"$tail\"" 5429 set new $code 5430 append new "\n/* Range check, assert (x $restriction) */" 5431 append new "\nif (!(@A $restriction)) \{" \ 5432 "\n Tcl_AppendResult (interp, $msg, NULL);" \ 5433 "\n return TCL_ERROR;" \ 5434 "\n\}" 5435 5436 argtype $ntype $new $ctype $ctype 5437 } 5438 } 5439 5440 argtype char* { 5441 @A = Tcl_GetString(@@); 5442 } {const char*} {const char*} 5443 5444 argtype pstring { 5445 @A.s = Tcl_GetStringFromObj(@@, &(@A.len)); 5446 @A.o = @@; 5447 } critcl_pstring critcl_pstring 5448 5449 argtypesupport pstring { 5450 typedef struct critcl_pstring { 5451 Tcl_Obj* o; 5452 const char* s; 5453 int len; 5454 } critcl_pstring; 5455 } 5456 5457 argtype list { 5458 if (Tcl_ListObjGetElements (interp, @@, &(@A.c), (Tcl_Obj***) &(@A.v)) != TCL_OK) return TCL_ERROR; 5459 @A.o = @@; 5460 } critcl_list critcl_list 5461 5462 argtypesupport list { 5463 typedef struct critcl_list { 5464 Tcl_Obj* o; 5465 Tcl_Obj* const* v; 5466 int c; 5467 } critcl_list; 5468 } 5469 5470 argtype Tcl_Obj* { 5471 @A = @@; 5472 } 5473 argtype object = Tcl_Obj* 5474 5475 # Predefined variadic type for the special Tcl_Obj*. 5476 # - No actual conversion, nor allocation, copying, release needed. 5477 # - Just point into and reuse the incoming ov[] array. 5478 # This shortcuts the operation of 'MakeVariadicTypeFor'. 5479 5480 argtype variadic_object { 5481 @A.c = @C; 5482 @A.v = &ov[@I]; 5483 } critcl_variadic_object critcl_variadic_object 5484 5485 argtypesupport variadic_object { 5486 typedef struct critcl_variadic_object { 5487 int c; 5488 Tcl_Obj* const* v; 5489 } critcl_variadic_object; 5490 } 5491 5492 argtype variadic_Tcl_Obj* = variadic_object 5493 5494 ## The next set of argument types looks to be very broken. We are 5495 ## keeping them for now, but declare them as DEPRECATED. Their 5496 ## documentation will be removed in version 3.2, and their 5497 ## implementation in 3.3 as well, fully exterminating them. 5498 5499 argtype int* { 5500 /* Raw pointer in binary Tcl value */ 5501 @A = (int*) Tcl_GetByteArrayFromObj(@@, NULL); 5502 Tcl_InvalidateStringRep(@@); 5503 } 5504 argtype float* { 5505 /* Raw pointer in binary Tcl value */ 5506 @A = (float*) Tcl_GetByteArrayFromObj(@@, NULL); 5507 } 5508 argtype double* { 5509 /* Raw pointer in binary Tcl value */ 5510 @A = (double*) Tcl_GetByteArrayFromObj(@@, NULL); 5511 } 5512 5513 # OLD Raw binary string. Length information is _NOT_ propagated. 5514 # Declaring it and its aliases as DEPRECATED. Their documentation 5515 # will be removed in version 3.2, and their implementation in 3.3 5516 # as well, fully exterminating them. 5517 argtype bytearray { 5518 /* Raw binary string. Length information is _NOT_ propagated */ 5519 @A = (char*) Tcl_GetByteArrayFromObj(@@, NULL); 5520 } char* char* 5521 argtype rawchar = bytearray 5522 argtype rawchar* = bytearray 5523 5524 # NEW Raw binary string _with_ length information. 5525 5526 argtype bytes { 5527 /* Raw binary string _with_ length information */ 5528 @A.s = Tcl_GetByteArrayFromObj(@@, &(@A.len)); 5529 @A.o = @@; 5530 } critcl_bytes critcl_bytes 5531 5532 argtypesupport bytes { 5533 typedef struct critcl_bytes { 5534 Tcl_Obj* o; 5535 const unsigned char* s; 5536 int len; 5537 } critcl_bytes; 5538 } 5539 5540 argtype channel { 5541 int mode; 5542 @A = Tcl_GetChannel(interp, Tcl_GetString (@@), &mode); 5543 if (@A == NULL) return TCL_ERROR; 5544 } Tcl_Channel Tcl_Channel 5545 5546 argtype unshared-channel { 5547 int mode; 5548 @A = Tcl_GetChannel(interp, Tcl_GetString (@@), &mode); 5549 if (@A == NULL) return TCL_ERROR; 5550 if (Tcl_IsChannelShared (@A)) { 5551 Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", -1)); 5552 return TCL_ERROR; 5553 } 5554 } Tcl_Channel Tcl_Channel 5555 5556 # Note, the complementary resulttype is `return-channel`. 5557 argtype take-channel { 5558 int mode; 5559 @A = Tcl_GetChannel(interp, Tcl_GetString (@@), &mode); 5560 if (@A == NULL) return TCL_ERROR; 5561 if (Tcl_IsChannelShared (@A)) { 5562 Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", -1)); 5563 return TCL_ERROR; 5564 } 5565 { 5566 /* Disable event processing for the channel, both by 5567 * removing any registered handler, and forcing interest 5568 * to none. This also disables the processing of pending 5569 * events which are ready to fire for the given 5570 * channel. If we do not do this, events will hit the 5571 * detached channel and potentially wreck havoc on our 5572 * memory and eventually badly hurt us... 5573 */ 5574 Tcl_DriverWatchProc *watchProc; 5575 Tcl_ClearChannelHandlers(@A); 5576 watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(@A)); 5577 if (watchProc) { 5578 (*watchProc)(Tcl_GetChannelInstanceData(@A), 0); 5579 } 5580 /* Next some fiddling with the reference count to prevent 5581 * the unregistration from killing it. We basically record 5582 * it as globally known before removing it from the 5583 * current interpreter 5584 */ 5585 Tcl_RegisterChannel((Tcl_Interp *) NULL, @A); 5586 Tcl_UnregisterChannel(interp, @A); 5587 } 5588 } Tcl_Channel Tcl_Channel 5589 5590 resulttype void { 5591 return TCL_OK; 5592 } 5593 5594 resulttype ok { 5595 return rv; 5596 } int 5597 5598 resulttype int { 5599 Tcl_SetObjResult(interp, Tcl_NewIntObj(rv)); 5600 return TCL_OK; 5601 } 5602 resulttype boolean = int 5603 resulttype bool = int 5604 5605 resulttype long { 5606 Tcl_SetObjResult(interp, Tcl_NewLongObj(rv)); 5607 return TCL_OK; 5608 } 5609 5610 resulttype wideint { 5611 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(rv)); 5612 return TCL_OK; 5613 } Tcl_WideInt 5614 5615 resulttype double { 5616 Tcl_SetObjResult(interp, Tcl_NewDoubleObj(rv)); 5617 return TCL_OK; 5618 } 5619 resulttype float { 5620 Tcl_SetObjResult(interp, Tcl_NewDoubleObj(rv)); 5621 return TCL_OK; 5622 } 5623 5624 # Static and volatile strings. Duplicate. 5625 resulttype char* { 5626 Tcl_SetObjResult(interp, Tcl_NewStringObj(rv,-1)); 5627 return TCL_OK; 5628 } 5629 resulttype {const char*} { 5630 Tcl_SetObjResult(interp, Tcl_NewStringObj(rv,-1)); 5631 return TCL_OK; 5632 } 5633 resulttype vstring = char* 5634 5635 # Dynamic strings, allocated via Tcl_Alloc. 5636 # 5637 # We are avoiding the Tcl_Obj* API here, as its use requires an 5638 # additional duplicate of the string, churning memory and 5639 # requiring more copying. 5640 # Tcl_SetObjResult(interp, Tcl_NewStringObj(rv,-1)); 5641 # Tcl_Free (rv); 5642 resulttype string { 5643 Tcl_SetResult (interp, rv, TCL_DYNAMIC); 5644 return TCL_OK; 5645 } char* 5646 resulttype dstring = string 5647 5648 resulttype Tcl_Obj* { 5649 if (rv == NULL) { return TCL_ERROR; } 5650 Tcl_SetObjResult(interp, rv); 5651 Tcl_DecrRefCount(rv); 5652 return TCL_OK; 5653 } 5654 resulttype object = Tcl_Obj* 5655 5656 critcl::resulttype Tcl_Obj*0 { 5657 if (rv == NULL) { return TCL_ERROR; } 5658 Tcl_SetObjResult(interp, rv); 5659 /* No refcount adjustment */ 5660 return TCL_OK; 5661 } Tcl_Obj* 5662 resulttype object0 = Tcl_Obj*0 5663 5664 resulttype new-channel { 5665 if (rv == NULL) { return TCL_ERROR; } 5666 Tcl_RegisterChannel (interp, rv); 5667 Tcl_SetObjResult (interp, Tcl_NewStringObj (Tcl_GetChannelName (rv), -1)); 5668 return TCL_OK; 5669 } Tcl_Channel 5670 5671 resulttype known-channel { 5672 if (rv == NULL) { return TCL_ERROR; } 5673 Tcl_SetObjResult (interp, Tcl_NewStringObj (Tcl_GetChannelName (rv), -1)); 5674 return TCL_OK; 5675 } Tcl_Channel 5676 5677 # Note, this is complementary to argtype `take-channel`. 5678 resulttype return-channel { 5679 if (rv == NULL) { return TCL_ERROR; } 5680 Tcl_RegisterChannel (interp, rv); 5681 Tcl_UnregisterChannel(NULL, rv); 5682 Tcl_SetObjResult (interp, Tcl_NewStringObj (Tcl_GetChannelName (rv), -1)); 5683 return TCL_OK; 5684 } Tcl_Channel 5685 5686 rename ::critcl::Initialize {} 5687 return 5688} 5689 5690# # ## ### ##### ######## ############# ##################### 5691## State 5692 5693namespace eval ::critcl { 5694 variable mydir ;# Path of the critcl package directory. 5695 variable run ;# interpreter to run commands, eval when, etc 5696 5697 # XXX configfile - See the *config commands, path of last config file run through 'readconfig'. 5698 5699 # namespace to flag when options set 5700 namespace eval option { 5701 variable debug_symbols 0 5702 } 5703 5704 # keep all variables in a sub-namespace for easy access 5705 namespace eval v { 5706 variable cache ;# Path. Cache directory. Platform-dependent 5707 # (target platform). 5708 5709 # ---------------------------------------------------------------- 5710 5711 # (XX) To understand the set of variables below and their 5712 # differences some terminology is required. 5713 # 5714 # First we have to distinguish between "target identifiers" 5715 # and "platform identifiers". The first is the name for a 5716 # particular set of configuration settings specifying commands 5717 # and command line arguments to use. The second is the name of 5718 # a machine configuration, identifying both operating system, 5719 # and cpu architecture. 5720 # 5721 # The problem critcl has is that in 99% of the cases found in 5722 # a critcl config file the "target identifier" is also a valid 5723 # "platform identifier". Example: "linux-ix86". That does not 5724 # make them semantically interchangable however. 5725 # 5726 # Especially when we add cross-compilation to the mix, where 5727 # we have to further distinguish between the platform critcl 5728 # itself is running on (build), and the platform for which 5729 # critcl is generating code (target), and the last one sounds 5730 # similar to "target identifier". 5731 5732 variable targetconfig ;# Target identifier. The chosen configuration. 5733 variable targetplatform ;# Platform identifier. Type of generated binaries. 5734 variable buildplatform ;# Platform identifier. We run here. 5735 5736 variable knowntargets {} ;# List of all target identifiers found 5737 # in the configuration file last processed by "readconfig". 5738 5739 variable xtargets ;# Cross-compile targets. This array maps from 5740 array set xtargets {} ;# the target identifier to the actual platform 5741 # identifier of the target platform in question. If a target identifier 5742 # has no entry here, it is assumed to be the platform identifier itself. 5743 # See "critcl::actualtarget". 5744 5745 # ---------------------------------------------------------------- 5746 5747 variable version "" ;# String. Min version number on platform 5748 variable hdrdir ;# Path. Directory containing the helper 5749 # files of the package. A sub- 5750 # directory of 'mydir', see above. 5751 variable hdrsavailable ;# List. Of Tcl versions for which we have 5752 # Tcl header files available. For details 5753 # see procedure 'Initialize' above. 5754 variable prefix ;# String. The string to start all file names 5755 # generated by the package with. See 5756 # 'Initialize' for our choice and 5757 # explanation of it. 5758 variable options ;# An array containing options 5759 # controlling the code generator. 5760 # For more details see below. 5761 set options(outdir) "" ;# - Path. If set the place where the generated 5762 # shared library is saved for permanent use. 5763 set options(keepsrc) 0 ;# - Boolean. If set all generated .c files are 5764 # kept after compilation. Helps with debugging 5765 # the critcl package. 5766 set options(combine) "" ;# - XXX standalone/dynamic/static 5767 # XXX Meaning of combine? 5768 set options(force) 0 ;# - Boolean. If set (re)compilation is 5769 # forced, regardless of the state of 5770 # the cache. 5771 set options(I) "" ;# - List. Additional include 5772 # directories, globally specified by 5773 # the user for mode 'generate 5774 # package', for all components put 5775 # into the package's library. 5776 set options(L) "" ;# - List. Additional library search 5777 # directories, globally specified by 5778 # the user for mode 'generate 5779 # package'. 5780 set options(language) "" ;# - String. XXX 5781 set options(lines) 1 ;# - Boolean. If set the generator will 5782 # emit #line-directives to help locating 5783 # C code in the .tcl in case of compile 5784 # warnings and errors. 5785 set options(trace) 0 ;# - Boolean. If set the generator will 5786 # emit code tracing command entry 5787 # and return, for all cprocs and 5788 # ccommands. The latter is done by 5789 # creating a shim function. For 5790 # cprocs their regular shim 5791 # function is used and modified. 5792 # The functionality is based on 5793 # 'critcl::cutil's 'tracer' 5794 # command and C code. 5795 5796 # XXX clientdata() per-command (See ccommand). per-file+ccommand better? 5797 # XXX delproc() per-command (See ccommand). s.a 5798 5799 # XXX toolchain() <platform>,<configvarname> -> data 5800 # XXX Used only in {read,set,show}config. 5801 # XXX Seems to be a database holding the total contents of the 5802 # XXX config file. 5803 5804 # knowntargets - See the *config commands, list of all platforms we can compile for. 5805 5806 # I suspect that this came later 5807 5808 # Conversion maps, Tcl types for procedure arguments and 5809 # results to C types and code fragments for the conversion 5810 # between the realms. Used by the helper commands 5811 # "ArgumentCType", "ArgumentConversion", and 5812 # "ResultConversion". These commands also supply the default 5813 # values for unknown types. 5814 5815 variable actype 5816 array set actype {} 5817 5818 variable actypeb 5819 array set actypeb {} 5820 5821 # In the code fragments below we have the following environment (placeholders, variables): 5822 # ip - C variable, Tcl_Interp* of the interpreter providing the arguments. 5823 # @@ - Tcl_Obj* valued expression returning the Tcl argument value. 5824 # @A - Name of the C-level argument variable. 5825 # 5826 variable aconv 5827 array set aconv {} 5828 5829 # Mapping from cproc result to C result type of the function. 5830 # This is also the C type of the helper variable holding the result. 5831 # NOTE: 'void' is special, as it has no result, nor result variable. 5832 variable rctype 5833 array set rctype {} 5834 5835 # In the code fragments for result conversion: 5836 # 'rv' == variable capturing the return value of the C function. 5837 # 'ip' == variable containing pointer to the interp to set the result into. 5838 variable rconv 5839 array set rconv {} 5840 5841 variable storageclass {} ;# See Initialize for setup. 5842 5843 variable code ;# This array collects all code snippets and 5844 # data about them. 5845 5846 # Keys for 'code' (above) and their contents: 5847 # 5848 # <file> -> Per-file information, nested dictionary. Sub keys: 5849 # 5850 # result - Results needed for 'generate package'. 5851 # initname - String. Foo in Foo_Init(). 5852 # tsources - List. The companion tcl sources for <file>. 5853 # object - String. Name of the object file backing <file>. 5854 # objects - List. All object files, main and companions. 5855 # shlib - String. Name of the shared library backing <file>. 5856 # base - String. Common prefix (file root) of 'object' and 'shlib'. 5857 # clibraries - List. See config. Copy for global linkage. 5858 # ldflags - List. See config. Copy for global linkage. 5859 # mintcl - String. Minimum version of Tcl required by the package. 5860 # preload - List. Names of all libraries to load before the package library. 5861 # license - String. License text. 5862 # <= "critcl::cresults" 5863 # 5864 # config - Collected code and configuration (ccode, etc.). 5865 # tsources - List. The companion tcl sources for <file>. 5866 # => "critcl::tsources". 5867 # cheaders - List. => "critcl::cheaders" 5868 # csources - List. => "critcl::csources" 5869 # clibraries - List. => "critcl::clibraries" 5870 # cflags - List. => "critcl::cflags", "critcl::framework", 5871 # "critcl::debug", "critcl::include" 5872 # ldflags - List. => "critcl::ldflags", "critcl::framework" 5873 # initc - String. Initialization code for Foo_Init(), "critcl::cinit" 5874 # edecls - String. Declarations of externals needed by Foo_Init(), "critcl::cinit" 5875 # functions - List. Collected function names. 5876 # fragments - List. Hashes of the collected C source bodies (functions, and unnamed code). 5877 # block - Dictionary. Maps the hashes to their C sources for fragments. 5878 # defs - List. Hashes of the collected C source bodies (only unnamed code), for extraction of defines. 5879 # const - Dictionary. Maps the names of defines to the namespace their variables will be in. 5880 # uuid - List. Strings used to generate the file's uuid/hash. 5881 # mintcl - String. Minimum version of Tcl required by the package. 5882 # preload - List. Names of all libraries to load 5883 # before the package library. This 5884 # information is used only by mode 5885 # 'generate package'. This means that 5886 # packages with preload can't be used 5887 # in mode 'compile & run'. 5888 # license - String. License text. 5889 # api_self - String. Name of our API. Defaults to package name. 5890 # api_hdrs - List. Exported public headers of the API. 5891 # api_ehdrs - List. Exported external public headers of the API. 5892 # api_fun - List. Exported functions (signatures of result type, name, and arguments (C syntax)) 5893 # meta - Dictionary. Arbitrary keys to values, the user meta-data for the package. 5894 # package - Dictionary. Keys, see below. System meta data for the package. Values are lists. 5895 # name - Name of current package 5896 # version - Version of same. 5897 # description - Long description. 5898 # summary - Short description (one line). 5899 # subject - Keywords and -phrases. 5900 # as::build::date - Date-stamp for the build. 5901 # 5902 # --------------------------------------------------------------------- 5903 # 5904 # <file>,failed -> Per-file information: Boolean. Build status. Failed or not. 5905 # 5906 # 'ccode' -> Accumulated in-memory storage of code-fragments. 5907 # Extended by 'ccode', used by 'BuildDefines', 5908 # called by 'cbuild'. Apparently tries to extract defines 5909 # and enums, and their values, for comparison with 'cdefine'd 5910 # values. 5911 # 5912 # NOTE: <file> are normalized absolute path names for exact 5913 # identification of the relevant .tcl file. 5914 5915 # _____________________________________________________________________ 5916 # State used by "cbuild" ______________________________________________ 5917 5918 variable log "" ;# Log channel, opened to logfile. 5919 variable logfile "" ;# Path of logfile. Accessed by 5920 # "Log*" and "ExecWithLogging". 5921 variable failed 0 ;# Build status. Used by "Status*" 5922 variable err "" ;# and "Exec*". Build error text. 5923 5924 variable uuidcounter 0 ;# Counter for uuid generation in package mode. 5925 ;# md5 is bypassed when used. 5926 5927 variable buildforpackage 0 ;# Boolean flag controlling 5928 # cbuild's behaviour. Named after 5929 # the mode 'generate package'. 5930 # Auto-resets to OFF after each 5931 # call of "cbuild". Can be activated 5932 # by "buildforpackage". 5933 5934 # _____________________________________________________________________ 5935 # State used by "BeginCommand", "EndCommand", "Emit*" _________________ 5936 5937 variable curr ;# Hash of the last BeginCommand. 5938 variable block ;# C code assembled by Emit* calls 5939 # between Begin- and EndCommand. 5940 5941 # _____________________________________________________________________ 5942 5943 variable compiling 0 ;# Boolean. Indicates that a C compiler 5944 # (gcc, native, cl) is available. 5945 5946 # _____________________________________________________________________ 5947 # config variables 5948 variable configvars { 5949 compile 5950 debug_memory 5951 debug_symbols 5952 include 5953 libinclude 5954 ldoutput 5955 embed_manifest 5956 link 5957 link_debug 5958 link_preload 5959 link_release 5960 noassert 5961 object 5962 optimize 5963 output 5964 platform 5965 preproc_define 5966 preproc_enum 5967 sharedlibext 5968 strip 5969 tclstubs 5970 threadflags 5971 tkstubs 5972 version 5973 } 5974 } 5975 5976 # namespace holding the compiler configuration (commands and 5977 # options for the various tasks, i.e. compilation, linking, etc.). 5978 namespace eval c { 5979 # See sibling file 'Config' for the detailed and full 5980 # information about the variables in use. configvars above, and 5981 # the code below list only the variables relevant to C. Keep this 5982 # information in sync with the contents of 'Config'. 5983 5984 # compile Command to compile a C source file to an object file 5985 # debug_memory Compiler flags to enable memory debugging 5986 # debug_symbols Compiler flags to add symbols to resulting library 5987 # include Compiler flag to add an include directory 5988 # libinclude Linker flag to add a library directory 5989 # ldoutput - ? See 'Config' 5990 # link Command to link one or more object files and create a shared library 5991 # embed_manifest Command to embed a manifest into a DLL. (Win-specific) 5992 # link_debug - ? See 'Config' 5993 # link_preload Linker flags to use when dependent libraries are pre-loaded. 5994 # link_release - ? See 'Config' 5995 # noassert Compiler flag to turn off assertions in Tcl code 5996 # object File extension for object files 5997 # optimize Compiler flag to specify optimization level 5998 # output Compiler flag to set output file, with argument $object => Use via [subst]. 5999 # platform Platform identification string (defaults to platform::generic) 6000 # preproc_define Command to preprocess C source file (for critcl::cdefines) 6001 # preproc_enum ditto 6002 # sharedlibext The platform's file extension used for shared library files. 6003 # strip Compiler flag to tell the linker to strip symbols 6004 # target Presence of this key indicates that this is a cross-compile target 6005 # tclstubs Compiler flag to set USE_TCL_STUBS 6006 # threadflags Compiler flags to enable threaded build 6007 # tkstubs Compiler flag to set USE_TK_STUBS 6008 # version Command to print the compiler version number 6009 } 6010} 6011 6012# # ## ### ##### ######## ############# ##################### 6013## Export API 6014 6015namespace eval ::critcl { 6016 namespace export \ 6017 at cache ccode ccommand cdata cdefines cflags cheaders \ 6018 check cinit clibraries compiled compiling config cproc \ 6019 csources debug done failed framework ldflags platform \ 6020 tk tsources preload license load tcl api userconfig meta \ 6021 source include make 6022 # This is exported for critcl::app to pick up when generating the 6023 # dummy commands in the runtime support of a generated package. 6024 namespace export Ignore 6025 catch { namespace ensemble create } 6026} 6027 6028# # ## ### ##### ######## ############# ##################### 6029## Ready 6030 6031::critcl::Initialize 6032return 6033