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