Merge branch 'dev' of feistymeow.org:feisty_meow into testing
[feisty_meow.git] / infobase / examples / legacy / template.pl
1 #!/usr/bin/perl
2
3 ###############################################################################
4 #                                                                             #
5 #  Name   : template                                                          #
6 #  Author : Chris Koeritz                                                     #
7 #  Rights : Copyright (C) 1996-$now by Author                                 #
8 #                                                                             #
9 #  Purpose:                                                                   #
10 #                                                                             #
11 #    Attempts to pre-instantiate C++ templates to work-around C++ compilers   #
12 #  that don't support templates (a rare breed, these days).                   #
13 #                                                                             #
14 ###############################################################################
15 #  This program is free software; you can redistribute it and/or modify it    #
16 #  under the terms of the GNU General Public License as published by the Free #
17 #  Software Foundation; either version 2 of the License or (at your option)   #
18 #  any later version.  See: "http://www.gruntose.com/Info/GNU/GPL.html" for a #
19 #  version of the License.  Please send any updates to "fred@gruntose.com".   #
20 ###############################################################################
21
22 # this was a majestic abortive attempt to create a template instantiator for
23 # compilers that do not possess templates, but which do support some subset
24 # of C++.  This was necessary at the time, due to our firmware compiler's
25 # limitations.  This processor never totally worked, although it did produce
26 # some interesting compilable code.  Might be useful as a demo or maybe just
27 # as a warning to avoid brain-damaged C++ compilers.
28
29 # to do:
30 #   maintain statistics about placement in file for error resolution.
31
32 # limitations so far:
33 #
34 # the word "template" must be the first word on the line.
35 #
36 # the type to instantiate must be one word (like charstar, not char *).
37 #
38 # templates must follow the form templateName<templateType> without
39 #   any spaces between the angle brackets.
40
41 # flag to enable debugging print outs.
42 $DEBUG_TEMPLATIZER = 1;
43 #$DEBUG_TEMPLATIZER = 0;
44
45 # array to store instance types to convert to
46 @instance_type_buffer = ();
47 # flag for checking read from file option
48 $f_option = 0;
49 $d_option = 0;
50
51 if ($#ARGV < 1) {
52   die("
53     The template instantiater supports an optional directory path as the first
54     parameter (preceded by a -d with no spaces in between the d and the
55     directory name) in which to store the generated templates, and then 
56     requires the instantiation type as the next argument (or a file
57     specification preceded by -f), and a list of files as the last
58     arguments.
59     The files will be scanned for templates and those templates will be
60     instantiated in the type(s) specified.
61     Examples:
62        perl template.pl char istring.h torpedo.h
63        perl template.pl -f instance.txt matrix.h
64        perl template.pl -d. -f instance.txt function.h data_src.h
65        perl template.pl -dfirm_src\library\basis -f instance.txt amorph.h\n");
66 }
67
68 # Check directory option
69 if (grep(/^\s*-d/, @ARGV)) {
70    $d_option = 1;
71    $d_dir = @ARGV[0];
72 #   print $d_dir, "\n";
73    shift;
74 }
75
76
77 # Check to see if user used a file to specify instantiation types
78 if (grep(/^\s*-f/, @ARGV)) {
79    $f_option = 1;
80    shift;
81    $types_file = @ARGV[0];
82
83 # Open instantiation type file to read from
84    open(TYPES_FILE, "<$types_file")
85      || die("couldn't open file $types_file for reading");
86
87 # Read in all the different types to instantiate
88 # Create instance_type list
89    @tp = <TYPES_FILE>;
90    while (@tp) {
91       local($line) = @tp;
92       chop $line;
93       push(@instance_type_buffer, $line);
94       shift @tp;
95    }
96    shift @ARGV;
97    &instantiate_templates(@ARGV);
98    exit;
99 }
100
101 &instantiate_templates(@ARGV);
102 exit;
103
104 #
105 # driver of the instantiation process.
106 #
107 sub instantiate_templates {
108   if (!$f_option) {
109   # grab the user's desired instance type.
110   $instance_type = @_[0];
111   push(@instance_type_buffer, $instance_type);
112   print "Instantiation type is \"$instance_type\".\n";
113   # jump over the instance type to look at the filenames.
114   shift;
115   }
116
117   local($i) = 0;
118   foreach $filename (@_) {
119     open(INPUT_FILE, "<$filename")
120       || die("couldn't open file $filename for reading");
121     # create an output name for the instance.
122     $out_filename = &make_output_name($filename);
123     if ($DEBUG_TEMPLATIZER) {
124 #      print "out file is ", $out_filename, "\n";      
125     }
126     local($index) = $i + 1;
127     print "Instantiating file[$index] as $out_filename.\n";
128     # now try opening our output file.
129     open(OUTPUT_FILE, ">$out_filename")
130       || die("couldn't open file $filename for writing");
131     # grab the current file into an array.
132
133     @file_array = <INPUT_FILE>;
134     @start_template = @file_array;
135     @stop_template = @file_array;
136     # process the file's contents as a manipulable array.
137     while (@file_array) {
138       local($line) = shift @file_array;
139       if (grep(/^\s*template/, $line)) {
140         @start_template = @file_array;
141
142         # iterate through all the instance types for each template
143         foreach $instance_type (@instance_type_buffer) {
144            @file_array = @start_template;
145            &snag_place_holder($line);
146            &snag_object_name;
147            &absorb_until_matched_block;
148            &replace_place_holder;
149            &dump_the_buffer;
150            print OUTPUT_FILE "\n";
151         }
152       } elsif (grep(/\w+<\w+>/, $line)) {
153         local(@pieces) = split(/\s/, $line);
154         foreach $piece (@pieces) {
155           local($prefix) = "";
156           # special case for separating function name from templated first
157           # parameter to it.
158           if (grep(/\(\w+</, $piece)) {
159             local(@chop_paren) = split(/\(/, $piece, 2);
160             $prefix = $chop_paren[0].'(';
161             $piece = $chop_paren[1];
162           }
163           if (grep(/\w+<\w+>/, $piece)) { $piece = &special_mangle($piece); }
164           print OUTPUT_FILE "$prefix$piece ";
165         }
166         print OUTPUT_FILE "\n";
167       } else {
168           print OUTPUT_FILE $line;
169       }
170     }
171     $i++;
172   }
173 }
174
175 #
176 # generates an output name from the filename to be translated.
177 #
178 sub make_output_name {
179   local($out_filename) = @_[0];
180   local($d_dir_temp) = $d_dir;
181 #  print "OUTFILE NAME: ",$out_filename,"\n";
182   # break down the filename at the slashes.
183   local(@split_filename) = split(/[\\\/]/, $out_filename);
184   # take the basename of the list of names.
185   $out_filename = $split_filename[$#split_filename];
186   local($hold_filename) = $out_filename;
187   if (grep(!/\.cpp$/i, $out_filename) && grep(!/\.h$/i, $out_filename)
188       && grep(!/\.c$/i, $out_filename) && grep(!/\.h$/i, $out_filename) ) {
189     die("filename @_[0] not recognized as a C++ code file.");
190   }
191   # makes an instance of the file in a directory named after the instance type
192   # that is located under the current directory.
193
194   $d_dir_temp = join('/',$d_dir, $hold_filename);
195   if ($d_option) {
196      $d_dir_temp =~ s/-d//i;
197      @split_filename = split(/[\\\/]/, $d_dir_temp);
198 #     exit;
199   }
200
201 # try to create dir using the deepest dir given in filename input
202
203     local($y) = 0;
204     foreach (@split_filename) { $y++; }
205
206     local($x) = 0;
207     local($ret) = 0;
208     local($dirs) = 0;
209
210     if ($y >= 2) {
211       foreach (@split_filename) {
212        if ((($x > 0) && ($x < $y-1)) || (($d_option) && ($x < $y-1))) {
213          if (!$dirs) { $dirs = @split_filename[$x]; }
214          else { $dirs = $dirs."/".@split_filename[$x]; }
215 #         print "Creating... ",$dirs,"\n";
216          $ret = mkdir($dirs, 0777);
217          if (!ret) { die("a directory named $instance_dir could not be made."); }
218        }
219        $x++;
220       }
221       $out_filename = $dirs."/".$hold_filename;
222     }
223     else { $out_filename = "template/".$hold_filename;
224          local($instance_dir) = "template";
225          $ret = mkdir($instance_dir, 0777);
226          if (!ret) { die("a directory named $instance_dir could not be made."); }
227     }
228 #   print $out_filename, "\n";
229
230 #  local($instance_dir) = @split_filename[$x-2];
231 #  creates the directory.
232 #  local($ret) = mkdir($instance_dir, 0777);
233 #  if (!ret) { die("a directory named $instance_dir could not be made."); }
234
235   $out_filename;  # return the new name.
236 }
237
238 #
239 # grabs the name of the placeholder type that will be replaced by
240 # the template instantiation type.
241 #
242 sub snag_place_holder {
243   $place_holder = @_[0];
244   chop $place_holder;
245
246   local(@pieces) = split(/>\s*/, $place_holder, 2);
247
248   # send back the parts not involved in the template statement.
249   if (length($pieces[1])) {
250      unshift(@file_array, $pieces[1]."\n");
251   }
252   $place_holder = $pieces[0];
253   $place_holder =~ s/\s*template\s+<class\s+(\w+)$/\1/;
254   if ($DEBUG_TEMPLATIZER) {
255 #    print "Replacing place holder \"$place_holder\" with \"$instance_type\".\n";
256   }
257 }
258
259 #
260 # grabs the name of the object itself that will become an instantiated
261 # object in the type specified.  the global variable "object_name" is
262 # set by the subfunctions used here.
263 #
264 sub snag_object_name {
265   local($next_line) = shift(@file_array);
266   chop $next_line;
267   &match_class_declaration($next_line)
268     || &match_class_member_definition($next_line)
269       || &match_function_definition($next_line);
270 }
271
272 #
273 # creates a mangled form of the name that includes the instantiation
274 # type.  the global variable "mangled_name" is set by this function.
275 #
276 sub mangle_name {
277   local($to_grind) = @_[0];
278   local($mangled_name) = "template__".$to_grind."__".$instance_type;
279   if ($DEBUG_TEMPLATIZER) {
280 #    print "Replacing name \"$to_grind\" with \"$mangled_name\".\n";
281   }
282   $mangled_name;
283 }
284
285 #
286 # processes "#include" preprocessor directives to make sure if the filename
287 # is in there to include a C++ file (for the template code), then it gets
288 # converted to the new file name.
289 #
290
291 # this is a pretty bogus thing; it should not be used.
292
293 sub convert_inclusion {
294   local($line) = @_[0];
295   chop $line;
296   local($temp) = $line;
297   # extract out the name parts of the include declaration.
298   $temp =~ s/\s*#include\s*([<"])([\w.]+)([>"])/\1 \2 \3/;
299   local(@broken_up) = split(/ /, $temp);
300   # strip off the punctuation from the name.
301   local($incl_prefix) = @broken_up[1];
302   $incl_prefix =~ s/["<](.*)[">]/\1/;
303   $incl_prefix =~ s/\s//g;
304   # return if it's not a code file being included.
305   if (!grep(/.cpp/i, $incl_prefix)) { print OUTPUT_FILE $line, "\n"; return; }
306   # strip to just the name without the ending.
307   $incl_prefix =~ s/\.cpp$//i;
308   # now get the name of the file we're processing.
309   local($file_prefix) = $filename;
310   # return if it's not a header file being examined.
311   if (!grep(/.h/i, $file_prefix)) { print OUTPUT_FILE $line, "\n"; return; }
312   # strip off the extension.
313   $file_prefix =~ s/\.h$//i;
314   # return if the names aren't equivalent--this means the include doesn't
315   # refer to our new templated form of the code file.
316   if ($incl_prefix ne $file_prefix) { print OUTPUT_FILE $line, "\n"; return FALSE; }
317   # dump out a message about the removal.
318   $line =~ s/^\s*//;
319   print OUTPUT_FILE "/* removed unneeded template inclusion: $line */\n";
320 }
321
322 #
323 # extracts lines from the file until the curly brackets are matched up
324 # at level 0.
325 #
326 sub absorb_until_matched_block {
327   $bracket_level = 0;
328   $end_absorb = 0;
329   @template_buffer = ();
330   $hit_one=0;
331   while (@file_array) {
332     local($line) = shift @file_array;
333     &look_for_curlies($line);
334     if (($hit_one && ($bracket_level == 0)) || $end_absorb) { return; }
335   }
336 }
337
338 #
339 # examines the parameters passed in for curly brackets and changes the
340 # counter if they are found.
341 #
342 sub look_for_curlies {
343 #  $hit_one = 0;  # records whether a bracket was found or not.
344   local($line) = @_[0];
345   @word = ();
346   foreach $char (split(//, $line)) {
347     if ($char eq '{') {
348       $hit_one = 1;
349       $bracket_level++;
350     } elsif ($char eq '}') {
351       $hit_one = 1;
352       $bracket_level--;
353     } elsif (($char eq ';') && ($hit_one==0)) {
354       $end_absorb = 1;
355     }
356
357
358     if ($DEBUG_TEMPLATIZER) {
359 #      print "~$char~ ";
360     }
361     push(@word, $char);
362     if (grep(!/\w/, $char)) {
363       # don't split yet if it's a possible template char.
364       if (grep(!/[<>]/, $char)) {
365         local($real_word) = join("", @word);
366         if ($DEBUG_TEMPLATIZER) {
367 #          print "adding a word $real_word\n";
368         }
369         push(@template_buffer, "$real_word");
370         @word = ();
371       }
372     }
373   }
374 }
375
376 #
377 # this goes through the buffer and replaces all occurrences of the name to
378 # replace with the instance name.
379 #
380 sub replace_place_holder {
381   @new_template_buffer = @template_buffer;
382   @template_buffer = ();
383
384   foreach $i (0 .. $#new_template_buffer) {
385     $word = $new_template_buffer[$i];
386 #    if ($DEBUG_TEMPLATIZER) {
387 #      print "<$i $word> ";
388 #      $old = $word;
389 #    }
390
391     # replace a templated combination with the mangled version.
392     $word =~ s/^${object_name}<${instance_type}>/${mangled_name}/;
393
394 #    if ($DEBUG_TEMPLATIZER) {
395 #      if ($old ne $word) {print "1 ... changed to $word.\n"; $old = $word; }
396 #    }
397
398     if (grep(/^\w+<\w+>/, $word)) {
399       # replace some other template with our stuff if we can.
400       $word = &special_mangle($word);
401     }
402
403 #    if ($DEBUG_TEMPLATIZER) {
404 #      if ($old ne $word) {print "2 ... changed to $word.\n"; $old = $word; }
405 #    }
406
407     # replace the object's name with its mangled form.
408     $word =~ s/^${object_name}/${mangled_name}/;
409
410 #    if ($DEBUG_TEMPLATIZER) {
411 #      if ($old ne $word) {print "3... changed to $word.\n"; $old = $word; }
412 #    }
413
414     # replace the place holder with the instantiation type.
415     $word =~ s/^${place_holder}/${instance_type}/;
416
417 #    if ($DEBUG_TEMPLATIZER) {
418 #      if ($old ne $word) {print "4... changed to $word.\n"; $old = $word; }
419 #    }
420
421     push(@template_buffer, $word);
422   }
423 }
424
425 #
426 # processes a general template usage, in the form X<Y>, where either
427 # X or Y are not ones that we think we need to replace.  it is assumed
428 # that it's safe to use the mangled form of the template.
429 #
430 sub special_mangle {
431   local($word) = @_[0];
432   # split the template form into pieces.
433   local(@pieces) = split(/[<>]/, $word, 2);
434
435   $pieces[1] =~ s/${place_holder}/${instance_type}/;
436   $pieces[1] =~ s/>//;
437   # hold onto the real instance type.
438   local($hold_instance) = $instance_type;
439   $instance_type = $pieces[1];
440   # mangle the name in the template usage line.
441   local($hold_mangled) = &mangle_name($pieces[0]);
442   # restore the original instance type.
443   $instance_type = $hold_instance;
444   # returns the new mangled form.
445   $hold_mangled;
446 }
447
448 #
449 # prints out the buffer we've accumulated to the output file.
450 #
451 sub dump_the_buffer {
452   print OUTPUT_FILE @template_buffer;
453 }
454
455 #
456 # processes a class declaration and sets the object name for future use.
457 #
458 sub match_class_declaration {
459   local($next_line) = @_[0];
460 # too strict!
461 #  if (grep(!/class\s.*\w+$/, $next_line)
462 #      && grep(!/class\s.*\w+\s*\{/, $next_line)
463 #      && grep(!/struct\s.*\w+$/, $next_line)
464 #      && grep(!/struct\s.*\w+\s*\{/, $next_line)) {
465 #    return 0;
466 #  }
467
468   if (grep(!/class\s+\w+/, $next_line) && grep(!/struct\s+\w+/, $next_line) ) {
469     return 0;
470   }
471
472   if ($DEBUG_TEMPLATIZER) {
473 #    print "matched class decl in $next_line\n";
474   }
475
476   if (grep(/class\s+\w+.*:/, $next_line)
477       || grep(/struct\s+\w+.*:/, $next_line)) {
478     # parses an inheriting class decl.
479     if ($DEBUG_TEMPLATIZER) {
480 #      print "in inheritance case on $next_line\n";
481     }
482     local(@pieces) = split(/:/, $next_line, 2);
483     # push the rest of the line back into the input array.
484     if ($DEBUG_TEMPLATIZER) {
485 #      print "going to unshift $pieces[1]...\n";
486     }
487     unshift(@file_array, ": ".$pieces[1]." ");
488     $next_line = $pieces[0];
489   } elsif (grep(/class\s.*\w+\s*\{/, $next_line)
490       || grep(/struct\s.*\w+\s*\{/, $next_line)) {
491     # parses a non-inheriting declaration with bracket on same line.
492     if ($DEBUG_TEMPLATIZER) {
493 #      print "in special case on $next_line\n";
494     }
495     # special case for continued stuff on same line.
496     local(@pieces) = split(/{/, $next_line, 2);
497     # push the rest of the line back into the input array.
498     unshift(@file_array, " { ".$pieces[1]." ");
499     $next_line = $pieces[0];
500   }
501   if ($DEBUG_TEMPLATIZER) {
502 #    print "matched class declaration... $next_line\n";
503   }
504   local(@pieces) = split(/\s/, $next_line);
505   $object_name = $pieces[$#pieces];
506   $mangled_name = &mangle_name($object_name);
507   foreach $posn (0 .. $#pieces - 1) { print OUTPUT_FILE "$pieces[$posn] "; }
508   print OUTPUT_FILE "$mangled_name\n";
509   1;
510 }
511
512 #
513 # processes the implementation of a class member and sets the object
514 # name for future use.
515 #
516 sub match_class_member_definition {
517   local($next_line) = @_[0];
518   local($junk);
519   if (grep(!/\w+<\w+>::/, $next_line)) {
520     return 0;
521   }
522   if ($DEBUG_TEMPLATIZER) {
523 #    print "matched class member definition... $next_line\n";
524   }
525   local(@pieces) = split(/>::/, $next_line, 2);
526   # checks for spaces in the first part of the split.  if there is one,
527   # it means we don't have a simple object thing.
528   if (grep(/\s/, $pieces[0])) {
529     if ($DEBUG_TEMPLATIZER) {
530 #      print "matched a space in the first part of supposed object name... $pieces[0]\n";
531     }
532     if (grep(/^\w+<\w+>/, $pieces[0])) {
533       if ($DEBUG_TEMPLATIZER) {
534 #        print "matched a template usage in first part of name...";
535       }
536       # replace some other template with our stuff if we can.
537       $pieces[0] = &special_mangle($pieces[0]);
538     }
539     if ($DEBUG_TEMPLATIZER) {
540 #      print "now our first bit is: $pieces[0]\n";
541     }
542     local(@new_pieces) = split(/ /, $pieces[0]);
543     $pieces[0] = $new_pieces[$#new_pieces];
544     foreach $posn (0 .. $#new_pieces - 1) {
545       $new_pieces[$posn] =~ s/${place_holder}/${instance_type}/g;
546       print OUTPUT_FILE "$new_pieces[$posn] ";
547     }
548   }
549   unshift(@file_array, "::\n".$pieces[1]."\n");
550   $object_name = $pieces[0];
551   $object_name =~ s/(\W*)(\w+)<(\w+)/\2/;
552   if (length($1)) { print OUTPUT_FILE "$1"; }
553   if ($3 ne $place_holder) {
554     die("The placeholder does not match on this line: $next_line");
555   }
556   $mangled_name = &mangle_name($object_name);
557   print OUTPUT_FILE "$mangled_name\n";
558   1;  # return success.
559 }
560
561 #
562 # processes a function template by making sure it fits the format and
563 # then setting up the variables for the replacement.  since function templates
564 # are so simple, the object name is not changed; only the place_holder is
565 # changed to the instance type.
566 #
567 sub match_function_definition {
568   local($next_line) = @_[0];
569
570   if (grep(!/^\s*\w+\s+.*/, $next_line) ) {
571     if ($DEBUG_TEMPLATIZER) {
572       print "failed on funcdef for ", $next_line, "!\n";
573     }
574     return 0;
575   }
576
577 # old broken code:...
578 #  if (grep(!/^\s*\w+\s+.*\(.*\)\s*/, $next_line) ) {
579 #print "failed on funcdef for ", $next_line, "!\n";
580 #    return 0;
581 #  }
582
583 #  if ($DEBUG_TEMPLATIZER) {
584 #    print "matched function definition on $next_line\n";
585 #  }
586
587 #  if ($DEBUG_TEMPLATIZER) {
588 #   print "stuffing back into the file array $next_line.\n";
589 #  }
590   # put the line back because it's nearly right for being instantiated.
591   unshift(@file_array, "inline ".$next_line."\n");
592   # come up with a very rare name that will not be matched in the text.
593   $object_name = "hogga_wogga_nunky_budget_weeny_teeny_kahini_beany";
594   $mangled_name = &mangle_name($object_name);
595   1;  # return a success.
596 }