- switched to automake build environment
[ginac.git] / ginac / structure.pl
1 #!/usr/bin/perl -w
2
3 $input_structure='';
4 $original_input_structure='';
5 while (<>) {
6     $input_structure .= '// '.$_;
7     $original_input_structure .= $_;
8 }
9
10 $original_input_structure =~ tr/ \t\n\r\f/     /;
11 $original_input_structure =~ tr/ //s;
12
13 if ($original_input_structure =~ /^struct (\w+) ?\{ ?(.*)\}\;? ?$/) {
14     $STRUCTURE=$1;
15     $decl=$2;
16 } else {
17     die "illegal struct, must match 'struct name { type var; /*comment*/ ...};': $original_input_structure";
18 }
19
20 # split off a part 'type var[,var...];' with a possible C-comment '/* ... */'
21 while ($decl =~ /^ ?(\w+) ([\w \,]+)\; ?((\/\*.*?\*\/)?)(.*)$/) {
22     $type=$1;
23     $member=$2;
24     $comment=$3;
25     $decl=$5;
26     while ($member =~ /^(\w+) ?\, ?(.*)$/) {
27         push @TYPES,$type;
28         push @MEMBERS,$1;
29         push @COMMENTS,$comment;
30         if ($comment ne '') {
31             $comment='/* see above */';
32         }
33         $member=$2;
34     }
35     if ($member !~ /^\w$/) {
36         die "illegal struct, must match 'struct name { type var; /*comment*/ ...};': $input_structure";
37     }
38     push @TYPES,$type;
39     push @MEMBERS,$member;
40     push @COMMENTS,$comment;
41 }
42
43 if ($decl !~ /^ ?$/) {
44     die "illegal struct, must match 'struct name { type var; /*comment*/ ...};': $input_structure";
45 }
46
47 #$STRUCTURE='teststruct';
48 $STRUCTURE_UC=uc(${STRUCTURE});
49 #@TYPES=('ex','ex','ex');
50 #@MEMBERS=('q10','q20','q21');
51
52 sub generate {
53     my ($template,$conj)=@_;
54     my ($res,$N);
55
56     $res='';
57     for ($N=1; $N<=$#MEMBERS+1; $N++) {
58         $TYPE=$TYPES[$N-1];
59         $MEMBER=$MEMBERS[$N-1];
60         $COMMENT=$COMMENTS[$N-1];
61         $res .= eval('"' . $template . '"');
62         $TYPE=''; # to avoid main::TYPE used only once warning
63         $MEMBER=''; # same as above
64         $COMMENT=''; # same as above
65         if ($N!=$#MEMBERS+1) {
66             $res .= $conj;
67         }
68     }
69     return $res;
70 }
71
72 $number_of_members=$#MEMBERS+1;
73 $constructor_arglist=generate('ex tmp_${MEMBER}',', ');
74 $member_access_functions=generate('    ex const & ${MEMBER}(void) { return m_${MEMBER}; }',"\n");
75 $op_access_indices_decl=generate('    static unsigned op_${MEMBER};',"\n");
76 $op_access_indices_def=generate('unsigned ${STRUCTURE}::op_${MEMBER}=${N}-1;',"\n");
77 $members=generate('    ex m_${MEMBER}; ${COMMENT}',"\n");
78 $copy_statements=generate('    m_${MEMBER}=other.m_${MEMBER};',"\n");
79 $constructor_statements=generate('m_${MEMBER}(tmp_${MEMBER})',', ');
80 $let_op_statements=generate(
81 '    case ${N}-1:'."\n".
82 '        return m_${MEMBER};'."\n".
83 '        break;',
84 "\n");
85 $temporary_arglist=generate('tmp_${MEMBER}',', ');
86 $expand_statements=generate('    ex tmp_${MEMBER}=m_${MEMBER}.expand(options);',"\n");
87 $has_statements=generate('    if (m_${MEMBER}.has(other)) return true;',"\n");
88 $eval_statements=generate(
89 '    ex tmp_${MEMBER}=m_${MEMBER}.eval(level-1);'."\n".
90 '    all_are_trivially_equal = all_are_trivially_equal &&'."\n".
91 '                              are_ex_trivially_equal(tmp_${MEMBER},m_${MEMBER});',
92 "\n");
93 $evalf_statements=generate(
94 '    ex tmp_${MEMBER}=m_${MEMBER}.evalf(level-1);'."\n".
95 '    all_are_trivially_equal = all_are_trivially_equal &&'."\n".
96 '                              are_ex_trivially_equal(tmp_${MEMBER},m_${MEMBER});',
97 "\n");
98 $normal_statements=generate(
99 '    ex tmp_${MEMBER}=m_${MEMBER}.normal(level-1);'."\n".
100 '    all_are_trivially_equal = all_are_trivially_equal &&'."\n".
101 '                              are_ex_trivially_equal(tmp_${MEMBER},m_${MEMBER});',
102 "\n");
103 $diff_statements=generate('    ex tmp_${MEMBER}=m_${MEMBER}.diff(s);',"\n");
104 $subs_statements=generate(
105 '    ex tmp_${MEMBER}=m_${MEMBER}.subs(ls,lr);'."\n".
106 '    all_are_trivially_equal = all_are_trivially_equal &&'."\n".
107 '                              are_ex_trivially_equal(tmp_${MEMBER},m_${MEMBER});',
108 "\n");
109 $compare_statements=generate(
110 '    cmpval=m_${MEMBER}.compare(o.m_${MEMBER});'."\n".
111 '    if (cmpval!=0) return cmpval;',
112 "\n");
113 $is_equal_statements=generate('    if (!m_${MEMBER}.is_equal(o.m_${MEMBER})) return false;',"\n");
114 $types_ok_statements=generate(
115 '#ifndef SKIP_TYPE_CHECK_FOR_${TYPE}'."\n".
116 '    if (!is_ex_exactly_of_type(m_${MEMBER},${TYPE})) return false;'."\n".
117 '#endif // ndef SKIP_TYPE_CHECK_FOR_${TYPE}',"\n");
118
119 $interface=<<END_OF_INTERFACE;
120 /** \@file ${STRUCTURE}.h
121  *
122  *  Definition of GiNaC's user defined structure ${STRUCTURE}. 
123  *  This file was generated automatically by structure.pl.
124  *  Please do not modify it directly, edit the perl script instead!
125  */
126
127 // structure.pl input:
128 ${input_structure}
129
130 #ifndef _${STRUCTURE_UC}_H_
131 #define _${STRUCTURE_UC}_H_
132
133 #include <ginac/ginac.h>
134
135 class ${STRUCTURE} : public structure
136 {
137 // member functions
138
139     // default constructor, destructor, copy constructor assignment operator and helpers
140 public:
141     ${STRUCTURE}();
142     ~${STRUCTURE}();
143     ${STRUCTURE}(${STRUCTURE} const & other);
144     ${STRUCTURE} const & operator=(${STRUCTURE} const & other);
145 protected:
146     void copy(${STRUCTURE} const & other);
147     void destroy(bool call_parent);
148
149     // other constructors
150 public:
151     ${STRUCTURE}(${constructor_arglist});
152
153     // functions overriding virtual functions from bases classes
154 public:
155     basic * duplicate() const;
156     void printraw(ostream & os) const;
157     void print(ostream & os, unsigned upper_precedence=0) const;
158     void printtree(ostream & os, unsigned indent) const;
159     int nops() const;
160     ex & let_op(int const i);
161     ex expand(unsigned options=0) const;
162     bool has(ex const & other) const;
163     ex eval(int level=0) const;
164     ex evalf(int level=0) const;
165     ex normal(lst &sym_lst, lst &repl_lst, int level=0) const;
166     ex diff(symbol const & s) const;
167     ex subs(lst const & ls, lst const & lr) const;
168 protected:
169     int compare_same_type(basic const & other) const;
170     bool is_equal_same_type(basic const & other) const;
171     unsigned return_type(void) const;
172
173     // new virtual functions which can be overridden by derived classes
174     // none
175
176     // non-virtual functions in this class
177 public:
178 ${member_access_functions}
179     bool types_ok(void) const;
180     
181 // member variables
182 protected:
183 ${members}
184 public:
185 ${op_access_indices_decl}
186 };
187
188 // global constants
189
190 extern const ${STRUCTURE} some_${STRUCTURE};
191 extern type_info const & typeid_${STRUCTURE};
192 extern const unsigned tinfo_${STRUCTURE};
193
194 // macros
195
196 #define ex_to_${STRUCTURE}(X) (static_cast<${STRUCTURE} const &>(*(X).bp))
197
198 #endif // ndef _${STRUCTURE_UC}_H_
199
200 END_OF_INTERFACE
201
202 $implementation=<<END_OF_IMPLEMENTATION;
203 /** \@file ${STRUCTURE}.cpp
204  *
205  *  Implementation of GiNaC's user defined structure ${STRUCTURE}. 
206  *  This file was generated automatically by STRUCTURE.pl.
207  *  Please do not modify it directly, edit the perl script instead!
208  */
209
210 // structure.pl input:
211 ${input_structure}
212
213 #include <iostream>
214
215 #include "ginac.h"
216
217 //////////
218 // default constructor, destructor, copy constructor assignment operator and helpers
219 //////////
220
221 // public
222
223 ${STRUCTURE}::${STRUCTURE}()
224 {
225     debugmsg("${STRUCTURE} default constructor",LOGLEVEL_CONSTRUCT);
226     tinfo_key=tinfo_${STRUCTURE};
227 }
228
229 ${STRUCTURE}::~${STRUCTURE}()
230 {
231     debugmsg("${STRUCTURE} destructor",LOGLEVEL_DESTRUCT);
232     destroy(0);
233 }
234
235 ${STRUCTURE}::${STRUCTURE}(${STRUCTURE} const & other)
236 {
237     debugmsg("${STRUCTURE} copy constructor",LOGLEVEL_CONSTRUCT);
238     copy(other);
239 }
240
241 ${STRUCTURE} const & ${STRUCTURE}::operator=(${STRUCTURE} const & other)
242 {
243     debugmsg("${STRUCTURE} operator=",LOGLEVEL_ASSIGNMENT);
244     if (this != &other) {
245         destroy(1);
246         copy(other);
247     }
248     return *this;
249 }
250
251 // protected
252
253 void ${STRUCTURE}::copy(${STRUCTURE} const & other)
254 {
255     structure::copy(other);
256 ${copy_statements}
257 }
258
259 void ${STRUCTURE}::destroy(bool call_parent)
260 {
261     if (call_parent) structure::destroy(call_parent);
262 }
263
264 //////////
265 // other constructors
266 //////////
267
268 // public
269
270 ${STRUCTURE}::${STRUCTURE}(${constructor_arglist}) 
271     : ${constructor_statements}
272 {
273     debugmsg("${STRUCTURE} constructor from children",
274              LOGLEVEL_CONSTRUCT);
275     tinfo_key=tinfo_${STRUCTURE};
276 }
277
278 //////////
279 // functions overriding virtual functions from bases classes
280 //////////
281
282 // public
283
284 basic * ${STRUCTURE}::duplicate() const
285 {
286     debugmsg("${STRUCTURE} duplicate",LOGLEVEL_DUPLICATE);
287     return new ${STRUCTURE}(*this);
288 }
289
290 void ${STRUCTURE}::printraw(ostream & os) const
291 {
292     debugmsg("${STRUCTURE} printraw",LOGLEVEL_PRINT);
293     os << "${STRUCTURE}()";
294 }
295
296 void ${STRUCTURE}::print(ostream & os, unsigned upper_precedence) const
297 {
298     debugmsg("${STRUCTURE} print",LOGLEVEL_PRINT);
299     os << "${STRUCTURE}()";
300 }
301
302 void ${STRUCTURE}::printtree(ostream & os, unsigned indent) const
303 {
304     debugmsg("${STRUCTURE} printtree",LOGLEVEL_PRINT);
305     os << "${STRUCTURE}()";
306 }
307
308 int ${STRUCTURE}::nops() const
309 {
310     return ${number_of_members};
311 }
312
313 ex & ${STRUCTURE}::let_op(int const i)
314 {
315     ASSERT(i>=0);
316     ASSERT(i<nops());
317
318     switch (i) {
319 ${let_op_statements}
320     }
321     errormsg("${STRUCTURE}::let_op(): should not reach this point");
322     return *new ex(fail());
323 }
324
325 ex ${STRUCTURE}::expand(unsigned options) const
326 {
327     bool all_are_trivially_equal=true;
328 ${expand_statements}
329     if (all_are_trivially_equal) {
330         return *this;
331     }
332     return ${STRUCTURE}(${temporary_arglist});
333 }
334
335 // a ${STRUCTURE} 'has' an expression if it is this expression itself or a child 'has' it
336
337 bool ${STRUCTURE}::has(ex const & other) const
338 {
339     ASSERT(other.bp!=0);
340     if (is_equal(*other.bp)) return true;
341 ${has_statements}
342     return false;
343 }
344
345 ex ${STRUCTURE}::eval(int level) const
346 {
347     if (level==1) {
348         return this->hold();
349     }
350     bool all_are_trivially_equal=true;
351 ${eval_statements}
352     if (all_are_trivially_equal) {
353         return this->hold();
354     }
355     return ${STRUCTURE}(${temporary_arglist});
356 }
357
358 ex ${STRUCTURE}::evalf(int level) const
359 {
360     if (level==1) {
361         return *this;
362     }
363     bool all_are_trivially_equal=true;
364 ${evalf_statements}
365     if (all_are_trivially_equal) {
366         return *this;
367     }
368     return ${STRUCTURE}(${temporary_arglist});
369 }
370
371 /** Implementation of ex::normal() for ${STRUCTURE}s. It normalizes the arguments
372  *  and replaces the ${STRUCTURE} by a temporary symbol.
373  *  \@see ex::normal */
374 ex ${STRUCTURE}::normal(lst &sym_lst, lst &repl_lst, int level) const
375 {
376     if (level==1) {
377         return basic::normal(sym_lst,repl_lst,level);
378     }
379     bool all_are_trivially_equal=true;
380 ${normal_statements}
381     if (all_are_trivially_equal) {
382         return basic::normal(sym_lst,repl_lst,level);
383     }
384     ex n=${STRUCTURE}(${temporary_arglist});
385     return n.bp->basic::normal(sym_lst,repl_lst,level);
386 }
387
388 /** ${STRUCTURE}::diff() differentiates the children.
389     there is no need to check for triavially equal, since diff usually
390     does not return itself unevaluated. */
391 ex ${STRUCTURE}::diff(symbol const & s) const
392 {
393 ${diff_statements}
394     return ${STRUCTURE}(${temporary_arglist});
395 }
396
397 ex ${STRUCTURE}::subs(lst const & ls, lst const & lr) const
398 {
399     bool all_are_trivially_equal=true;
400 ${subs_statements}
401     if (all_are_trivially_equal) {
402         return *this;
403     }
404     return ${STRUCTURE}(${temporary_arglist});
405 }
406
407 // protected
408
409 int ${STRUCTURE}::compare_same_type(basic const & other) const
410 {
411     ASSERT(is_of_type(other,${STRUCTURE}));
412     ${STRUCTURE} const & o=static_cast<${STRUCTURE} const &>
413                                     (const_cast<basic &>(other));
414     int cmpval;
415 ${compare_statements}
416     return 0;
417 }
418
419 bool ${STRUCTURE}::is_equal_same_type(basic const & other) const
420 {
421     ASSERT(is_of_type(other,${STRUCTURE}));
422     ${STRUCTURE} const & o=static_cast<${STRUCTURE} const &>
423                                     (const_cast<basic &>(other));
424 ${is_equal_statements}
425     return true;
426 }
427
428 unsigned ${STRUCTURE}::return_type(void) const
429 {
430     return return_types::noncommutative_composite;
431 }
432
433 //////////
434 // new virtual functions which can be overridden by derived classes
435 //////////
436
437 // none
438
439 //////////
440 // non-virtual functions in this class
441 //////////
442
443 // public
444
445 #define SKIP_TYPE_CHECK_FOR_ex
446 // this is a hack since there is no meaningful
447 // is_ex_exactly_of_type(...,ex) macro definition
448
449 bool ${STRUCTURE}::types_ok(void) const
450 {
451 ${types_ok_statements}
452     return true;
453 }
454
455 //////////
456 // static member variables
457 //////////
458
459 ${op_access_indices_def}
460
461 //////////
462 // global constants
463 //////////
464
465 const ${STRUCTURE} some_${STRUCTURE};
466 type_info const & typeid_${STRUCTURE}=typeid(some_${STRUCTURE});
467 const unsigned tinfo_${STRUCTURE}=structure::register_new("${STRUCTURE}");
468
469 END_OF_IMPLEMENTATION
470
471 print "Creating interface file ${STRUCTURE}.h...";
472 open OUT,">${STRUCTURE}.h" or die "cannot open ${STRUCTURE}.h";
473 print OUT $interface;
474 close OUT;
475 print "ok.\n";
476
477 print "Creating implementation file ${STRUCTURE}.cpp...";
478 open OUT,">${STRUCTURE}.cpp" or die "cannot open ${STRUCTURE}.cpp";
479 print OUT $implementation;
480 close OUT;
481 print "ok.\n";
482
483 print "done.\n";