1# -*- tcl -*- 2# 3# Copyright (c) 2016-2018 by Stefan Sobernig <stefan.sobernig@wu.ac.at> 4 5# # ## ### ##### ######## ############# ##################### 6## Package description 7 8## An NX implementation of the PackRat Machine (PARAM), a virtual 9## machine on top of which parsers for Parsing Expression Grammars 10## (PEGs) can be realized. This implementation is tied to the PARAM's 11## TclOO implementation and it is automatically derived from the 12## corresponding TclOO class (pt::rde::oo) upon loading the package. 13 14# # ## ### ##### ######## ############# ##################### 15## Requisites 16 17package require pt::rde::oo 18package req nx 19 20namespace eval ::pt::rde { 21 22 ## 23 ## Helper: An NX metaclass and class generator, which allows for 24 ## deriving an NX class from the ::pt::rde::oo class. 25 ## 26 27 nx::Class create ClassFactory -superclass nx::Class { 28 :property prototype:required 29 30 :method mkMethod {name vars params body tmpl} { 31 set objVars [list] 32 set debugObjVars [list] 33 foreach v $vars { 34 if {[string first $v $body] > -1} { 35 lappend objVars :$v $v 36 } else { 37 lappend debugObjVars :$v $v 38 } 39 } 40 41 if {[llength $objVars]} { 42 set objVars [list upvar 0 {*}$objVars] 43 } 44 45 if {[llength $debugObjVars]} { 46 set debugObjVars [list debug.pt/rdengine \ 47 "\[[list upvar 0 {*}$debugObjVars]\]"] 48 } 49 50 set mappings [list @body@ $body @objVars@ $objVars \ 51 @debugObjVars@ $debugObjVars @params@ $params] 52 53 set finalBody [string map $mappings $tmpl] 54 55 :method $name $params $finalBody 56 57 }; # mkMethod 58 59 :method init {args} { 60 61 namespace eval [namespace qualifier [self]] { 62 namespace import ::nsf::my 63 } 64 65 :method debugPrep {cls} { 66 :object method TraceInitialization [list [list cls $cls]] { 67 set mh [$cls info methods -callprotection all TraceInitialization] 68 if {$mh ne ""} { 69 set script [$cls info method body $mh] 70 apply [list {} $script [self]] 71 } 72 } 73 return 74 } 75 76 :method debugOn {} { 77 interp alias {} [namespace current]::Instruction {} [self]::Instruction 78 interp alias {} [namespace current]::InstReturn {} [self]::InstReturn 79 interp alias {} [namespace current]::State {} [self]::State 80 interp alias {} [namespace current]::TraceSetupStacks {} [self]::TraceSetupStacks 81 return 82 } 83 84 :method debugOff {} { 85 interp alias {} [namespace current]::Instruction {} 86 interp alias {} [namespace current]::InstReturn {} 87 interp alias {} [namespace current]::State {} 88 interp alias {} [namespace current]::TraceSetupStacks {} 89 return 90 } 91 92 set vars [info class variables ${:prototype}] 93 94 ## clone constructor 95 lassign [info class constructor ${:prototype}] ctorParams ctorBody 96 97 :mkMethod init $vars $ctorParams $ctorBody { 98 debug.pt/rdengine {[:debugPrep [current class]][self] TraceInitialization indirection} 99 :require namespace; 100 apply [list {} { 101 namespace import ::nsf::my 102 @objVars@ 103 @body@ 104 } [self]] 105 106 debug.pt/rdengine {[:debugOn][self] DebugCmd indirection on} 107 } 108 109 :public method destroy {args} { 110 debug.pt/rdengine {[:debugOff][self] DebugCmd indirection off} 111 next 112 } 113 114 ## clone all methods 115 foreach m [info class methods ${:prototype} -private] { 116 lassign [info class definition ${:prototype} $m] params body 117 118 :mkMethod $m $vars $params $body { 119 @objVars@ 120 @debugObjVars@ 121 @body@ 122 } 123 } 124 125 return 126 }; # init 127 }; # ClassFactory 128 129 ## 130 ## ::pt::rde::nx: 131 ## 132 ## The NX derivative of ::pt::rde::oo, to be inherited 133 ## by the generated grammar class. 134 ## 135 136 ClassFactory create nx -prototype ::pt::rde::oo 137 138 namespace export nx 139} 140 141package provide pt::rde::nx [package req pt::rde::oo].1.1 142 143# Local variables: 144# mode: tcl 145# tcl-indent-level: 2 146# indent-tabs-mode: nil 147# End: 148 149