1## -*- tcl -*- 2# # ## ### ##### ######## ############# ##################### 3# Pragmas for MetaData Scanner. 4# @mdgen OWNER: class.h 5 6# CriTcl Utility Commands. Specification of a command representing a 7# class made easy, with code for object command and method dispatch 8# generated. 9 10package provide critcl::class 1.1.1 11 12# # ## ### ##### ######## ############# ##################### 13## Requirements. 14 15package require Tcl 8.4 ; # Min supported version. 16package require critcl 3.1.17 ; # Need 'meta?' to get the package name. 17 # Need 'name2c' returning 4 values. 18 # Need 'Deline' helper. 19 # Need cproc -tracename 20package require critcl::util ; # Use the package's Get/Put commands. 21 22namespace eval ::critcl::class {} 23 24# # ## ### ##### ######## ############# ##################### 25## API: Generate the declaration and implementation files for the class. 26 27proc ::critcl::class::define {classname script} { 28 variable state 29 30 # Structure of the specification database 31 # 32 # TODO: Separate the spec::Process results from the template placeholders. 33 # TODO: Explain the various keys 34 # 35 # NOTE: All toplevel keys go into the map 36 # used to configure the template file (class.h). 37 # See `GenerateCode` and `MakeMap`. 38 # 39 # The various `Process*` procedures are responsible 40 # for converting the base specification delivered by 41 # `spec::Process` into the placeholders expected by 42 # template 43 ## 44 # state = dict << 45 # tcl-api -> bool 46 # c-api -> bool 47 # capiprefix -> string 48 # buildflags -> string 49 # classmgrstruct -> string 50 # classmgrsetup -> string 51 # classmgrnin -> string 52 # classcommand -> string 53 # tclconscmd -> string 54 # package -> string 55 # class -> string 56 # stem -> string 57 # classtype -> string (C type class structure) 58 # (class)method -> dict << 59 # names -> list (string) 60 # def -> (name) -> << 61 # enum 62 # case 63 # code 64 # syntax 65 # >> 66 # typedef -> ^instancetype 67 # menum -> 68 # typekey -> 69 # prefix -> ''|'class_' (see *1*) 70 # startn -> 71 # starte -> 72 # >> 73 # (class)variable -> dict << 74 # names -> list (string) 75 # def -> (name) -> << 76 # ctype -> 77 # loc -> 78 # comment -> 79 # >> 80 # >> 81 # stop -> bool|presence 82 # includes -> string (C code fragment) 83 # include -> 84 # instancetype -> 85 # ivardecl -> string (C code fragment) 86 # ivarrelease -> string (C code fragment) 87 # ivarerror -> string (C code fragment) 88 # itypedecl -> string (C code fragment, instance type) 89 # ctypedecl -> string (C code fragment, class type) 90 # *1*, (class_)method.prefix use 91 # (class_)method_names 92 # (class_)method_enumeration 93 # (class_)method_dispatch 94 # (class_)method_implementations 95 # >> 96 97 catch { unset state } 98 99 # Arguments: 100 # - name of the Tcl command representing the class. 101 # May contain namespace qualifiers. Represented by a ccommand. 102 # - script specifying the state structure and methods. 103 104 #puts "=== |$classname|" 105 #puts "--- $script" 106 107 # Pull the package we are working on out of the system. 108 109 set package [critcl::meta? name] 110 set qpackage [expr {[string match ::* $package] 111 ? "$package" 112 : "::$package"}] 113 lassign [uplevel 1 [list ::critcl::name2c $classname]] ns cns classname cclassname 114 lassign [uplevel 1 [list ::critcl::name2c $qpackage]] pns pcns package cpackage 115 116 #puts "%%% pNS |$pns|" 117 #puts "%%% Pkg |$package|" 118 #puts "%%% pCNS |$pcns|" 119 #puts "%%% cPkg |$cpackage|" 120 121 #puts "%%% NS |$ns|" 122 #puts "%%% CName |$classname|" 123 #puts "%%% CNS |$cns|" 124 #puts "%%% CCName|$cclassname|" 125 126 set stem ${pcns}${cpackage}_$cns$cclassname 127 128 dict set state tcl-api 1 129 dict set state c-api 0 130 dict set state capiprefix $cns$cclassname 131 dict set state package $pns$package 132 dict set state class $ns$classname 133 dict set state stem $stem 134 dict set state classtype ${stem}_CLASS 135 dict set state method names {} 136 dict set state classmethod names {} 137 138 # Check if the 'info frame' information for 'script' passes through properly. 139 spec::Process $script 140 141 #puts "@@@ <<$state>>" 142 143 ProcessFlags 144 ProcessIncludes 145 ProcessExternalType 146 ProcessInstanceVariables 147 ProcessClassVariables 148 149 ProcessMethods method 150 ProcessMethods classmethod 151 152 ProcessFragment classconstructor "\{\n" " " "\}" 153 ProcessFragment classdestructor "\{\n" " " "\}" 154 ProcessFragment constructor "\{\n" " " "\}" 155 ProcessFragment postconstructor "\{\n" " " "\}" 156 ProcessFragment destructor "\{\n" " " "\}" 157 ProcessFragment support "" \n "" 158 159 GenerateCode 160 161 unset state 162 return 163} 164 165proc ::critcl::class::ProcessFlags {} { 166 variable state 167 set flags {} 168 foreach key {tcl-api c-api} { 169 if {![dict get $state $key]} continue 170 lappend flags $key 171 } 172 if {![llength $flags]} { 173 return -code error "No APIs to generate found. Please activate at least one API." 174 } 175 176 dict set state buildflags [join $flags {, }] 177 critcl::msg "\n\tClass flags: $flags" 178 return 179} 180 181proc ::critcl::class::ProcessIncludes {} { 182 variable state 183 if {[dict exists $state include]} { 184 ProcessFragment include "#include <" "\n" ">" 185 dict set state includes [dict get $state include] 186 dict unset state include 187 } else { 188 dict set state includes {/* No inclusions */} 189 } 190 return 191} 192 193proc ::critcl::class::ProcessExternalType {} { 194 variable state 195 if {![dict exists $state instancetype]} return 196 197 # Handle external C type for instances. 198 set itype [dict get $state instancetype] 199 dict set state ivardecl " $itype instance" 200 dict set state ivarrelease "" 201 dict set state ivarerror "error:\n return NULL;" 202 dict set state itypedecl "/* External type for instance state: $itype */" 203 204 # For ProcessMethods 205 dict set state method typedef $itype 206 return 207} 208 209proc ::critcl::class::ProcessInstanceVariables {} { 210 variable state 211 212 if {![dict exists $state variable]} { 213 if {![dict exists $state instancetype]} { 214 # We have neither external type, nor instance variables. 215 # Fake ourselves out, recurse. 216 dict set state variable names {} 217 ProcessInstanceVariables itype 218 return 219 } 220 221 # For ProcessMethods 222 dict set state method menum M_EMPTY 223 dict set state method typekey @instancetype@ 224 dict set state method prefix {} 225 dict set state method startn {} 226 dict set state method starte {} 227 return 228 } 229 230 # Convert the set of instance variables (which can be empty) into 231 # a C instance structure type declaration, plus variable name. 232 233 set itype [dict get $state stem]_INSTANCE 234 235 set decl {} 236 lappend decl "typedef struct ${itype}__ \{" 237 238 foreach fname [dict get $state variable names] { 239 set ctype [dict get $state variable def $fname ctype] 240 set vloc [dict get $state variable def $fname loc] 241 set comment [dict get $state variable def $fname comment] 242 243 set field "$vloc $ctype $fname;" 244 if {$comment ne {}} { 245 append field " /* $comment */" 246 } 247 lappend decl $field 248 } 249 250 lappend decl "\} ${itype}__;" 251 lappend decl "typedef struct ${itype}__* $itype;" 252 253 dict set state instancetype $itype 254 dict set state ivardecl " $itype instance = ($itype) ckalloc (sizeof (${itype}__))" 255 dict set state ivarerror "error:\n ckfree ((char*) instance);\n return NULL;" 256 dict set state ivarrelease " ckfree ((char*) instance)" 257 dict set state itypedecl [join $decl \n] 258 259 # For ProcessMethods 260 dict set state method typedef $itype 261 dict set state method menum M_EMPTY 262 dict set state method typekey @instancetype@ 263 dict set state method prefix {} 264 dict set state method startn {} 265 dict set state method starte {} 266 return 267} 268 269proc ::critcl::class::ProcessClassVariables {} { 270 variable state 271 272 # For ProcessMethods 273 dict set state classmethod typedef [dict get $state classtype] 274 dict set state classmethod menum {} 275 dict set state classmethod typekey @classtype@ 276 dict set state classmethod prefix class_ 277 dict set state classmethod startn "\n" 278 dict set state classmethod starte ",\n" 279 dict set state ctypedecl {} 280 281 dict set state capiclassvaraccess {} 282 283 if {![dict exists $state classvariable]} { 284 # Some compilers are unable to handle a structure without 285 # members (notably ANSI C89 Solaris, AIX). Taking the easy way 286 # out here, adding a dummy element. A more complex solution 287 # would be to ifdef the empty structure out of the system. 288 289 dict set state ctypedecl {int __dummy__;} 290 return 291 } 292 293 # Convert class variables into class type field declarations. 294 295 set decl {} 296 lappend decl "/* # # ## ### ##### ######## User: Class variables */" 297 298 if {[dict get $state c-api]} { 299 lappend acc "/* # # ## ### ##### ######## User: C-API :: Class variable accessors */\n" 300 } 301 302 foreach fname [dict get $state classvariable names] { 303 set ctype [dict get $state classvariable def $fname ctype] 304 set vloc [dict get $state classvariable def $fname loc] 305 set comment [dict get $state classvariable def $fname comment] 306 307 set field "$vloc$ctype $fname;" 308 if {$comment ne {}} { 309 append field " /* $comment */" 310 } 311 lappend decl $field 312 313 # If needed, generate accessor functions for all class variables, 314 # i.e setters and getters. 315 316 if {[dict get $state c-api]} { 317 lappend acc "$ctype @capiprefix@_${fname}_get (Tcl_Interp* interp) \{" 318 lappend acc " return @stem@_Class (interp)->user.$fname;" 319 lappend acc "\}" 320 lappend acc "" 321 lappend acc "void @capiprefix@_${fname}_set (Tcl_Interp* interp, $ctype v) \{" 322 lappend acc " @stem@_Class (interp)->user.$fname = v;" 323 lappend acc "\}" 324 } 325 } 326 327 lappend decl "/* # # ## ### ##### ######## */" 328 329 dict set state ctypedecl " [join $decl "\n "]\n" 330 331 if {[dict get $state c-api]} { 332 dict set state capiclassvaraccess [join $acc \n] 333 } 334 return 335} 336 337proc ::critcl::class::Max {v s} { 338 upvar 1 $v max 339 set l [string length $s] 340 if {$l < $max} return 341 set max $l 342 return 343} 344 345proc ::critcl::class::ProcessMethods {key} { 346 variable state 347 # Process method declarations. Ensure that the names are listed in 348 # alphabetical order, to be nice. 349 350 # From Process(Instance|Class)Variables 351 set pfx [dict get $state $key prefix] 352 set stn [dict get $state $key startn] 353 set ste [dict get $state $key starte] 354 355 if {[dict exists $state $key names] && 356 [llength [dict get $state $key names]]} { 357 set map [list @stem@ [dict get $state stem] \ 358 [dict get $state $key typekey] \ 359 [dict get $state $key typedef]] 360 361 set maxe 0 362 set maxn 0 363 foreach name [lsort -dict [dict get $state $key names]] { 364 Max maxn $name 365 Max maxe [dict get $state $key def $name enum] 366 } 367 incr maxn 3 368 369 foreach name [lsort -dict [dict get $state $key names]] { 370 set enum [string map $map [dict get $state $key def $name enum]] 371 set case [string map $map [dict get $state $key def $name case]] 372 set code [string map $map [dict get $state $key def $name code]] 373 set syntax [string map $map [dict get $state $key def $name syntax]] 374 375 lappend names "[format %-${maxn}s \"$name\",] $syntax" 376 lappend enums "[format %-${maxe}s $enum] $syntax" 377 regexp {(:.*)$} $case tail 378 set case "case [format %-${maxe}s $enum]$tail" 379 lappend cases $case 380 lappend codes $code 381 } 382 383 dict set state ${pfx}method_names "${stn} [join $names "\n "]" 384 dict set state ${pfx}method_enumeration "${ste} [join $enums ",\n "]" 385 dict set state ${pfx}method_dispatch "${stn}\t[join $cases \n\t]" 386 dict set state ${pfx}method_implementations [join $codes \n\n] 387 } else { 388 set enums [dict get $state $key menum] 389 if {[llength $enums]} { 390 set enums "${ste} [join $enums ",\n "]" 391 } 392 393 dict set state ${pfx}method_names {} 394 dict set state ${pfx}method_enumeration $enums 395 dict set state ${pfx}method_dispatch {} 396 dict set state ${pfx}method_implementations {} 397 } 398 399 400 dict unset state $key 401 return 402} 403 404proc ::critcl::class::ProcessFragment {key prefix sep suffix} { 405 # Process code fragments into a single block, if any. 406 # Ensure it exists, even if empty. Required by template. 407 # Optional in specification. 408 409 variable state 410 if {![dict exists $state $key]} { 411 set new {} 412 } else { 413 set new ${prefix}[join [dict get $state $key] $suffix$sep$prefix]$suffix 414 } 415 dict set state $key $new 416 return 417} 418 419proc ::critcl::class::GenerateCode {} { 420 variable state 421 422 set stem [dict get $state stem] 423 set class [dict get $state class] 424 set hdr ${stem}_class.h 425 set header [file join [critcl::cache] $hdr] 426 427 file mkdir [critcl::cache] 428 set template [critcl::Deline [Template class.h]] 429 #puts T=[string length $template] 430 431 # Note, the template file is many files/parts, separated by ^Z 432 lassign [split $template \x1a] \ 433 template mgrstruct mgrsetup newinsname classcmd tclconscmd \ 434 cconscmd 435 436 # Configure the flag-dependent parts of the template 437 438 if {[dict get $state tcl-api]} { 439 dict set state classmgrstruct $mgrstruct 440 dict set state classmgrsetup $mgrsetup 441 dict set state classmgrnin $newinsname 442 dict set state classcommand $classcmd 443 dict set state tclconscmd $tclconscmd 444 } else { 445 dict set state classmgrstruct {} 446 dict set state classmgrsetup {} 447 dict set state classmgrnin {} 448 dict set state classcommand {} 449 dict set state tclconscmd {} 450 } 451 452 if {[dict get $state c-api]} { 453 dict set state cconscmd $cconscmd 454 } else { 455 dict set state cconscmd {} 456 } 457 458 critcl::util::Put $header [string map [MakeMap] $template] 459 460 critcl::ccode "#include <$hdr>" 461 if {[dict get $state tcl-api]} { 462 uplevel 2 [list critcl::ccommand $class ${stem}_ClassCommand] 463 } 464 return 465} 466 467proc ::critcl::class::MakeMap {} { 468 variable state 469 470 # First set of substitutions. 471 set premap {} 472 dict for {k v} $state { 473 lappend premap @${k}@ $v 474 } 475 476 # Resolve the substitutions used in the fragments of code to 477 # generate the final map. 478 set map {} 479 foreach {k v} $premap { 480 lappend map $k [string map $premap $v] 481 } 482 483 return $map 484} 485 486proc ::critcl::class::Template {path} { 487 variable selfdir 488 set path $selfdir/$path 489 critcl::msg "\tClass templates: $path" 490 return [Get $path] 491} 492 493proc ::critcl::class::Get {path} { 494 if {[catch { 495 set c [open $path r] 496 fconfigure $c -eofchar {} 497 set d [read $c] 498 close $c 499 }]} { 500 set d {} 501 } 502 return $d 503} 504 505proc ::critcl::class::Dedent {pfx text} { 506 set result {} 507 foreach l [split $text \n] { 508 lappend result [regsub ^$pfx $l {}] 509 } 510 join $result \n 511} 512 513# # ## ### ##### ######## ############# ##################### 514## 515# Internal: All the helper commands providing access to the system 516# state to the specification commands (see next section) 517## 518# # ## ### ##### ######## ############# ##################### 519 520proc ::critcl::class::CAPIPrefix {name} { 521 variable state 522 dict set state capiprefix $name 523 return 524} 525 526proc ::critcl::class::Flag {key flag} { 527 critcl::msg " ($key = $flag)" 528 variable state 529 dict set state $key $flag 530 return 531} 532 533proc ::critcl::class::Include {header} { 534 # Name of an API to include in the generated code. 535 variable state 536 dict lappend state include $header 537 return 538} 539 540proc ::critcl::class::ExternalType {name} { 541 # Declaration of the C type to use for the object state. This 542 # type is expected to be declared externally. It allows us to use 543 # a 3rd party structure directly. Cannot be specified if instance 544 # and/or class variables for our own structures have been declared 545 # already. 546 547 variable state 548 549 if {[dict exists $state variable]} { 550 return -code error "Invalid external instance type. Instance variables already declared." 551 } 552 if {[dict exists $state classvariable]} { 553 return -code error "Invalid external instance type. Class variables already declared." 554 } 555 556 dict set state instancetype $name 557 return 558} 559 560proc ::critcl::class::Variable {ctype name comment vloc} { 561 # Declaration of an instance variable. In other words, a field in 562 # the C structure for instances. Cannot be specified if an 563 # external "type" has been specified already. 564 565 variable state 566 567 if {[dict exists $state instancetype]} { 568 return -code error \ 569 "Invalid instance variable. External instance type already declared." 570 } 571 572 if {[dict exists $state variable def $name]} { 573 return -code error "Duplicate definition of instance variable \"$name\"" 574 } 575 576 # Create the automatic instance variable to hold the instance 577 # command token. 578 579 if {![dict exists $state stop] && 580 (![dict exists $state variable] || 581 ![llength [dict get $state variable names]]) 582 } { 583 # To make it easier on us we reuse the existing definition 584 # commands to set everything up. To avoid infinite recursion 585 # we set a flag stopping us from re-entering this block. 586 587 dict set state stop 1 588 critcl::at::here ; Variable Tcl_Command cmd { 589 Automatically generated. Holds the token for the instance command, 590 for use by the automatically created destroy method. 591 } [critcl::at::get] 592 dict unset state stop 593 594 PostConstructor "[critcl::at::here!]\tinstance->cmd = cmd;\n" 595 596 # And the destroy method using the above instance variable. 597 critcl::at::here ; MethodExplicit destroy proc {} void { 598 Tcl_DeleteCommandFromToken(interp, instance->cmd); 599 } 600 } 601 602 dict update state variable f { 603 dict lappend f names $name 604 } 605 dict set state variable def $name ctype $ctype 606 dict set state variable def $name loc $vloc 607 dict set state variable def $name comment [string trim $comment] 608 return 609} 610 611proc ::critcl::class::ClassVariable {ctype name comment vloc} { 612 # Declaration of a class variable. In other words, a field in the 613 # C structure for the class. Cannot be specified if a an external 614 # "type" has been specified already. 615 616 variable state 617 618 if {[dict exists $state instancetype]} { 619 return -code error \ 620 "Invalid class variable. External instance type already declared." 621 } 622 623 if {[dict exists $state classvariable def $name]} { 624 return -code error "Duplicate definition of class variable \"$name\"" 625 } 626 627 dict update state classvariable c { 628 dict lappend c names $name 629 } 630 dict set state classvariable def $name ctype $ctype 631 dict set state classvariable def $name loc $vloc 632 dict set state classvariable def $name comment [string trim $comment] 633 634 if {[llength [dict get $state classvariable names]] == 1} { 635 # On declaration of the first class variable we declare an 636 # instance variable which provides the instances with a 637 # reference to their class (structure). 638 critcl::at::here ; Variable @classtype@ class { 639 Automatically generated. Reference to the class (variables) 640 from the instance. 641 } [critcl::at::get] 642 Constructor "[critcl::at::here!]\tinstance->class = class;\n" 643 } 644 return 645} 646 647proc ::critcl::class::Constructor {code} { 648 CodeFragment constructor $code 649 return 650} 651 652proc ::critcl::class::PostConstructor {code} { 653 CodeFragment postconstructor $code 654 return 655} 656 657proc ::critcl::class::Destructor {code} { 658 CodeFragment destructor $code 659 return 660} 661 662proc ::critcl::class::ClassConstructor {code} { 663 CodeFragment classconstructor $code 664 return 665} 666 667proc ::critcl::class::ClassDestructor {code} { 668 CodeFragment classdestructor $code 669 return 670 } 671 672proc ::critcl::class::Support {code} { 673 CodeFragment support $code 674 return 675} 676 677proc ::critcl::class::MethodExternal {name function details} { 678 MethodCheck method instance $name 679 680 set map {} 681 if {[llength $details]} { 682 set details [join $details {, }] 683 lappend map objv "objv, $details" 684 set details " ($details)" 685 } 686 687 MethodDef method instance $name [MethodEnum method $name] {} $function $map \ 688 "/* $name : External function @function@$details */" 689 return 690} 691 692proc ::critcl::class::MethodExplicit {name mtype arguments args} { 693 # mtype in {proc, command} 694 MethodCheck method instance $name 695 variable state 696 697 set bloc [critcl::at::get] 698 set enum [MethodEnum method $name] 699 set function ${enum}_Cmd 700 set cdimport "[critcl::at::here!] @instancetype@ instance = (@instancetype@) clientdata;" 701 set tname "[dict get $state class] M $name" 702 703 if {$mtype eq "proc"} { 704 # Method is cproc. 705 # |args| == 2, args => rtype, body 706 # arguments is (argtype argname...) 707 # (See critcl::cproc for full details) 708 709 # Force availability of the interp in methods. 710 if {[lindex $arguments 0] ne "Tcl_Interp*"} { 711 set arguments [linsert $arguments 0 Tcl_Interp* interp] 712 } 713 714 lassign $args rtype body 715 716 set body $bloc[string trimright $body] 717 set cargs [critcl::argnames $arguments] 718 if {[llength $cargs]} { set cargs " $cargs" } 719 set syntax "/* Syntax: <instance> $name$cargs */" 720 set body "\n $syntax\n$cdimport\n $body" 721 722 set code [critcl::collect { 723 critcl::cproc $function $arguments $rtype $body \ 724 -cname 1 -pass-cdata 1 -arg-offset 1 -tracename $tname 725 }] 726 727 } else { 728 # Method is ccommand. 729 # |args| == 1, args => body 730 lassign $args body 731 732 if {$arguments ne {}} {set arguments " cmd<<$arguments>>"} 733 set body $bloc[string trimright $body] 734 set syntax "/* Syntax: <instance> $name$arguments */" 735 set body "\n $syntax\n$cdimport\n $body" 736 737 set code [critcl::collect { 738 critcl::ccommand $function {} $body \ 739 -cname 1 -tracename $tname 740 }] 741 } 742 743 MethodDef method instance $name $enum $syntax $function {} $code 744 return 745} 746 747proc ::critcl::class::ClassMethodExternal {name function details} { 748 MethodCheck classmethod class $name 749 750 set map {} 751 if {[llength $details]} { 752 lappend map objv "objv, [join $details {, }]" 753 } 754 755 MethodDef classmethod "&classmgr->user" $name [MethodEnum classmethod $name] {} $function $map \ 756 "/* $name : External function @function@ */" 757 return 758} 759 760proc ::critcl::class::ClassMethodExplicit {name mtype arguments args} { 761 # mtype in {proc, command} 762 MethodCheck classmethod class $name 763 variable state 764 765 set bloc [critcl::at::get] 766 set enum [MethodEnum classmethod $name] 767 set function ${enum}_Cmd 768 set cdimport "[critcl::at::here!] @classtype@ class = (@classtype@) clientdata;" 769 set tname "[dict get $state class] CM $name" 770 771 if {$mtype eq "proc"} { 772 # Method is cproc. 773 # |args| == 2, args => rtype, body 774 # arguments is (argtype argname...) 775 # (See critcl::cproc for full details) 776 777 # Force availability of the interp in methods. 778 if {[lindex $arguments 0] ne "Tcl_Interp*"} { 779 set arguments [linsert $arguments 0 Tcl_Interp* interp] 780 } 781 782 lassign $args rtype body 783 784 set body $bloc[string trimright $body] 785 set cargs [critcl::argnames $arguments] 786 if {[llength $cargs]} { set cargs " $cargs" } 787 set syntax "/* Syntax: <class> $name$cargs */" 788 set body "\n $syntax\n$cdimport\n $body" 789 790 set code [critcl::collect { 791 critcl::cproc $function $arguments $rtype $body \ 792 -cname 1 -pass-cdata 1 -arg-offset 1 \ 793 -tracename $tname 794 }] 795 796 } else { 797 # Method is ccommand. 798 # |args| == 1, args => body 799 lassign $args body 800 801 if {$arguments ne {}} {set arguments " cmd<<$arguments>>"} 802 set body $bloc[string trimright $body] 803 set syntax "/* Syntax: <class> $name$arguments */" 804 set body "\n $syntax\n$cdimport\n $body" 805 806 set code [critcl::collect { 807 critcl::ccommand $function {} $body \ 808 -cname 1 -tracename $tname 809 }] 810 } 811 812 MethodDef classmethod class $name $enum $syntax $function {} $code 813 return 814} 815 816proc ::critcl::class::MethodCheck {section label name} { 817 variable state 818 if {[dict exists $state $section def $name]} { 819 return -code error "Duplicate definition of $label method \"$name\"" 820 } 821 return 822} 823 824proc ::critcl::class::MethodEnum {section name} { 825 variable state 826 # Compute a C enum identifier from the (class) method name. 827 828 # To avoid trouble we have to remove any non-alphabetic 829 # characters. A serial number is required to distinguish methods 830 # which would, despite having different names, transform to the 831 # same C enum identifier. 832 833 regsub -all -- {[^a-zA-Z0-9_]} $name _ name 834 regsub -all -- {_+} $name _ name 835 836 set serial [llength [dict get $state $section names]] 837 set M [expr {$section eq "method" ? "M" : "CM"}] 838 839 return @stem@_${M}_${serial}_[string toupper $name] 840} 841 842proc ::critcl::class::MethodDef {section var name enum syntax function xmap code} { 843 variable state 844 845 set case "case $enum: return @function@ ($var, interp, objc, objv); break;" 846 set case [string map $xmap $case] 847 848 set map [list @function@ $function] 849 850 dict update state $section m { 851 dict lappend m names $name 852 } 853 dict set state $section def $name enum $enum 854 dict set state $section def $name case [string map $map $case] 855 dict set state $section def $name code [string map $map $code] 856 dict set state $section def $name syntax [string map $map $syntax] 857 return 858} 859 860proc ::critcl::class::CodeFragment {section code} { 861 variable state 862 set code [string trim $code \n] 863 if {$code ne {}} { 864 dict lappend state $section $code 865 } 866 return 867} 868 869# # ## ### ##### ######## ############# ##################### 870## 871# Internal: Namespace holding the class specification commands. The 872# associated state resides in the outer namespace, as do all the 873# procedures actually accessing that state (see above). Treat it like 874# a sub-package, with a proper API. 875## 876# # ## ### ##### ######## ############# ##################### 877 878namespace eval ::critcl::class::spec {} 879 880proc ::critcl::class::spec::Process {script} { 881 # Note how this script is evaluated within the 'spec' namespace, 882 # providing it with access to the specification methods. 883 884 # Point the global namespace resolution into the spec namespace, 885 # to ensure that the commands are properly found even if the 886 # script moved through helper commands and other namespaces. 887 888 # Note that even this will not override the builtin 'variable' 889 # command with ours, which is why ours is now called 890 # 'insvariable'. 891 892 namespace eval :: [list namespace path [list [namespace current] ::]] 893 894 eval $script 895 896 namespace eval :: {namespace path {}} 897 return 898} 899 900proc ::critcl::class::spec::tcl-api {flag} { 901 ::critcl::class::Flag tcl-api $flag 902} 903 904proc ::critcl::class::spec::c-api {flag {name {}}} { 905 ::critcl::class::Flag c-api $flag 906 if {$name eq {}} return 907 ::critcl::class::CAPIPrefix $name 908} 909 910proc ::critcl::class::spec::include {header} { 911 ::critcl::class::Include $header 912} 913 914proc ::critcl::class::spec::type {name} { 915 ::critcl::class::ExternalType $name 916} 917 918proc ::critcl::class::spec::insvariable {ctype name {comment {}} {constructor {}} {destructor {}}} { 919 ::critcl::at::caller 920 set vloc [critcl::at::get*] 921 ::critcl::at::incrt $comment ; set cloc [::critcl::at::get*] 922 ::critcl::at::incrt $constructor ; set dloc [::critcl::at::get] 923 924 925 ::critcl::class::Variable $ctype $name $comment $vloc 926 927 if {$constructor ne {}} { 928 ::critcl::class::Constructor $cloc$constructor 929 } 930 if {$destructor ne {}} { 931 ::critcl::class::Destructor $dloc$destructor 932 } 933 934 return 935} 936 937proc ::critcl::class::spec::constructor {code {postcode {}}} { 938 ::critcl::at::caller ; set cloc [::critcl::at::get*] 939 ::critcl::at::incrt $code ; set ploc [::critcl::at::get] 940 941 if {$code ne {}} { 942 ::critcl::class::Constructor $cloc$code 943 } 944 if {$postcode ne {}} { 945 ::critcl::class::PostConstructor $ploc$postcode 946 } 947 return 948} 949 950proc ::critcl::class::spec::destructor {code} { 951 ::critcl::class::Destructor [::critcl::at::caller!]$code 952 return 953} 954 955proc ::critcl::class::spec::method {name op detail args} { 956 # Syntax 957 # (1) method <name> as <function> ... 958 # (2) method <name> proc <arguments> <rtype> <body> 959 # (3) method <name> command <arguments> <body> 960 # name op detail args__________ 961 962 # op = as|proc|cmd|command 963 964 # op == proc 965 # detail = argument list, syntax as per cproc. 966 # args[0] = r(esult)type 967 # args[1] = body 968 969 # op == command 970 # detail = argument syntax. not used in code, purely descriptive. 971 # args[0] = body 972 973 switch -exact -- $op { 974 as { 975 # The instance method is an external C function matching 976 # an ObjCmd in signature, possibly with additional 977 # parameters at the end. 978 # 979 # detail = name of that function 980 # args = values for the additional parameters, if any. 981 982 ::critcl::class::MethodExternal $name $detail $args 983 return 984 } 985 proc { 986 if {[llength $args] != 2} { 987 return -code error "wrong#args" 988 } 989 } 990 cmd - command { 991 set op command 992 if {[llength $args] != 1} { 993 return -code error "wrong#args" 994 } 995 } 996 default { 997 return -code error "Illegal method type \"$op\", expected one of cmd, command, or proc" 998 } 999 } 1000 1001 ::critcl::at::caller 1002 ::critcl::at::incrt $detail 1003 1004 eval [linsert $args 0 ::critcl::class::MethodExplicit $name $op [string trim $detail]] 1005 #::critcl::class::MethodExplicit $name $op [string trim $detail] {*}$args 1006 return 1007} 1008 1009proc ::critcl::class::spec::classvariable {ctype name {comment {}} {constructor {}} {destructor {}}} { 1010 ::critcl::at::caller 1011 set vloc [critcl::at::get*] 1012 ::critcl::at::incrt $comment ; set cloc [::critcl::at::get*] 1013 ::critcl::at::incrt $constructor ; set dloc [::critcl::at::get] 1014 1015 ::critcl::class::ClassVariable $ctype $name $comment $vloc 1016 1017 if {$constructor ne {}} { 1018 ::critcl::class::ClassConstructor $cloc$constructor 1019 } 1020 if {$destructor ne {}} { 1021 ::critcl::class::ClassDestructor $dloc$destructor 1022 } 1023 return 1024} 1025 1026proc ::critcl::class::spec::classconstructor {code} { 1027 ::critcl::class::ClassConstructor [::critcl::at::caller!]$code 1028 return 1029} 1030 1031proc ::critcl::class::spec::classdestructor {code} { 1032 ::critcl::class::ClassDestructor [::critcl::at::caller!]$code 1033 return 1034} 1035 1036proc ::critcl::class::spec::classmethod {name op detail args} { 1037 # Syntax 1038 # (1) classmethod <name> as <function> ... 1039 # (2) classmethod <name> proc <arguments> <rtype> <body> 1040 # (3) classmethod <name> command <arguments> <body> 1041 # name op detail args__________ 1042 1043 # op = as|proc|cmd|command 1044 1045 # op == proc 1046 # detail = argument syntax per cproc. 1047 # args[0] = r(esult)type 1048 # args[1] = body 1049 1050 # op == command 1051 # detail = argument syntax. not used in code, purely descriptive. 1052 # args[0] = body 1053 1054 switch -exact -- $op { 1055 as { 1056 # The class method is an external C function matching an 1057 # ObjCmd in signature, possibly with additional parameters 1058 # at the end. 1059 # 1060 # detail = name of that function 1061 # args = values for the additional parameters, if any. 1062 1063 ::critcl::class::ClassMethodExternal $name $detail $args 1064 return 1065 } 1066 proc { 1067 if {[llength $args] != 2} { 1068 return -code error "wrong#args" 1069 } 1070 } 1071 cmd - command { 1072 set op command 1073 if {[llength $args] != 1} { 1074 return -code error "wrong#args" 1075 } 1076 } 1077 default { 1078 return -code error "Illegal method type \"$op\", expected one of cmd, command, or proc" 1079 } 1080 } 1081 1082 ::critcl::at::caller 1083 ::critcl::at::incrt $detail 1084 eval [linsert $args 0 ::critcl::class::ClassMethodExplicit $name $op [string trim $detail]] 1085 # ::critcl::class::ClassMethodExplicit $name $op [string trim $detail] {*}$args 1086 return 1087} 1088 1089proc ::critcl::class::spec::support {code} { 1090 ::critcl::class::Support [::critcl::at::caller!]$code 1091 return 1092} 1093 1094proc ::critcl::class::spec::method_introspection {} { 1095 ::critcl::class::spec::classvariable Tcl_Obj* methods { 1096 Cache for the list of method names. 1097 } { 1098 class->methods = ComputeMethodList (@stem@_methodnames); 1099 Tcl_IncrRefCount (class->methods); 1100 } { 1101 Tcl_DecrRefCount (class->methods); 1102 class->methods = NULL; 1103 } 1104 1105 # The ifdef/define/endif block below ensures that the supporting 1106 # code will be defined only once, even if multiple classes 1107 # activate method-introspection. Note that what we cannot prevent 1108 # is the appearance of multiple copies of the code below in the 1109 # generated output, only that it is compiled multiple times. 1110 1111 ::critcl::class::spec::support { 1112#ifndef CRITCL_CLASS__HAVE_COMPUTE_METHOD_LIST 1113#define CRITCL_CLASS__HAVE_COMPUTE_METHOD_LIST 1114static Tcl_Obj* 1115ComputeMethodList (CONST char** table) 1116{ 1117 int n, i; 1118 char** item; 1119 Tcl_Obj** lv; 1120 Tcl_Obj* result; 1121 1122 item = (char**) table; 1123 n = 0; 1124 while (*item) { 1125 n ++; 1126 item ++; 1127 } 1128 1129 lv = (Tcl_Obj**) ckalloc (n * sizeof (Tcl_Obj*)); 1130 i = 0; 1131 while (table [i]) { 1132 lv [i] = Tcl_NewStringObj (table [i], -1); 1133 i ++; 1134 } 1135 1136 result = Tcl_NewListObj (n, lv); 1137 ckfree ((char*) lv); 1138 1139 return result; 1140} 1141#endif /* CRITCL_CLASS__HAVE_COMPUTE_METHOD_LIST */ 1142 } 1143 1144 ::critcl::class::spec::method methods proc {} void { 1145 Tcl_SetObjResult (interp, instance->class->methods); 1146 } 1147 1148 ::critcl::class::spec::classmethod methods proc {} void { 1149 Tcl_SetObjResult (interp, class->methods); 1150 } 1151 return 1152} 1153 1154# # ## ### ##### ######## ############# ##################### 1155## State 1156 1157namespace eval ::critcl::class { 1158 variable selfdir [file dirname [file normalize [info script]]] 1159} 1160 1161# # ## ### ##### ######## ############# ##################### 1162## Export API 1163 1164namespace eval ::critcl::class { 1165 namespace export define 1166 catch { namespace ensemble create } ; # 8.5+ 1167} 1168 1169# # ## ### ##### ######## ############# ##################### 1170## Ready 1171return 1172