89 saw 1.1
90 FILE *input, *output, *error;
91 char input_filename[BUFFER_LEN];
92 char output_filename[BUFFER_LEN];
93 char error_filename[BUFFER_LEN] = {""};
94 char subroutine_name[BUFFER_LEN] = {""};
95 char command_line[BUFFER_LEN];
96 int current_calltype, current_line;
97
98 void eprint (char string[]);
99 void eprintn (char string[], int length);
100 void eprint_newline ();
101 void eprint_line (int line_num);
102 void memory_error ();
103 char *parse_array_size (char string[]);
104 void create (struct node *ptr, int vartype, char string[], char title[]);
105 int max (int a, int b);
106 int min (int a, int b);
107 void free_node (struct node *ptr);
108 void clear_list (struct node *ptr);
109 void copy (char dest[], char source[], int length);
110 saw 1.1 int strncmp_i (char str1[], char str2[], int length);
111 struct node *find_node (struct node *start, char string[]);
112 void mark_node (struct node *start, char string[], int new_action);
113 int determine_type (char string[]);
114 char *skip_blanks (char string[]);
115 char *skip_nonblanks (char string[]);
116 char *find_char (char string[], char character);
117 int extract_text (char string[]);
118 void shift_left (char string[]);
119 void parse (char string[]);
120 void compare_lists ();
121 void write_fortran_header ();
122 void write_fortran_code ();
123 void set_call_type (char string[]);
124
125 /***************************************************************************
126 * Linked list functions
127 ***************************************************************************/
128
129 /* Print a character string to "error" */
130 void eprint (char string[]) {
131 saw 1.1 fprintf (error, "%s", string);
132 fprintf (output, "%s", string);
133 }
134
135 /* Print "length" characters of a character string to "error" */
136 void eprintn (char string[], int length) {
137 char output_buffer[BUFFER_LEN];
138
139 copy (output_buffer, string, length);
140 fprintf (error, "%s", output_buffer);
141 fprintf (output, "%s", output_buffer);
142 }
143
144 /* Print a newline character to "error" */
145 void eprint_newline () {
146 fprintf (error, "\n");
147 fprintf (output, "\n* ");
148 }
149
150 /* Print a line number to "error" */
151 void eprint_line (int line_num) {
152 saw 1.1 fprintf (error, "Line %d: ", line_num);
153 fprintf (output, "Line %d: ", line_num);
154 }
155
156 /* memory_error is called if malloc returns a NULL pointer */
157 void memory_error () {
158 printf ("Memory allocation error\n");
159 fclose (input);
160 fclose (output);
161 fclose (error);
162 exit (0);
163 }
164
165 /* Return a pointer to a string containing the array size */
166 char *parse_array_size (char string[]) {
167 char output_buffer[BUFFER_LEN];
168 int length;
169 char *size_string, *ptr = string;
170
171 memset (output_buffer, '\0', BUFFER_LEN);
172 ptr = find_char (ptr, '(');
173 saw 1.1 while (ptr < find_char(string,')')) {
174 if (strlen(output_buffer) != 0) strcat (output_buffer, "*");
175 length = min (find_char(ptr,',')-ptr, find_char(ptr,')')-ptr) - 1;
176 strcat (output_buffer, "(");
177 if (find_char(ptr,':')-ptr < length) {
178 strcat (output_buffer, "1-");
179 strncat (output_buffer, ptr, find_char(ptr,':')-ptr-1);
180 strcat (output_buffer, "+");
181 ptr = find_char (ptr, ':');
182 length = min (find_char(ptr,',')-ptr, find_char(ptr,')')-ptr) - 1;
183 }
184 strncat (output_buffer, ptr, length);
185 strcat (output_buffer, ")");
186 ptr = skip_blanks (find_char (ptr, ','));
187 }
188 size_string = malloc (strlen(output_buffer)+1);
189 if (size_string == NULL) memory_error ();
190 strcpy (size_string, output_buffer);
191 return (size_string);
192 }
193
194 saw 1.1 /* Add a variable to a linked list */
195 void create (struct node *start, int vartype, char string[], char comment[]) {
196 struct node *end = start, *temp;
197
198 if (find_node (start, string) == NULL) {
199 /* Create a new node and add it to the end of the linked list */
200 while (end->next != NULL) end = end->next;
201 end->next = malloc (sizeof(struct node));
202 if (end->next == NULL) memory_error ();
203 end = end->next;
204 end->vartype = vartype;
205 end->action = NOP;
206 end->calltype = current_calltype;
207 end->line_number = current_line;
208 end->name = calloc (extract_text(string)+1, sizeof(char));
209 if (end->name == NULL) memory_error ();
210 copy (end->name, string, extract_text(string));
211 if ((find_char (string, '(') < find_char (string, ',')) &&
212 (find_char (string, '(') < find_char (string, '!'))) {
213 /* Variable is an array */
214 if (start == common_start) {
215 saw 1.1 /* Array is defined in a common block, so print a warning */
216 eprint_newline ();
217 eprint ("Warning - Array size defined in common block:");
218 eprint_newline ();
219 eprint_line (current_line);
220 eprintn (string, find_char(string, ')') - string);
221 eprint_newline ();
222 temp = find_node (register_start, string);
223 if (temp != NULL) {
224 if (temp->vartype > 0) array_flags[temp->calltype][temp->vartype]=1;
225 free (temp->size);
226 temp->size = parse_array_size (string);
227 end->size = NULL;
228 }
229 }
230 else end->size = parse_array_size (string);
231 }
232 else (end->size = NULL);
233 if (comment != NULL) {
234 end->title = calloc (strlen(comment), sizeof(char));
235 if (end->title == NULL) memory_error ();
236 saw 1.1 copy (end->title, comment, strlen(comment)-1);
237 }
238 else end->title = NULL;
239 end->next = NULL;
240 }
241 }
242
243 /* Return the maximum of a and b */
244 int max (int a, int b) {
245 return ((a < b) ? b : a);
246 }
247
248 /* Return the minimum of a and b */
249 int min (int a, int b) {
250 return ((a < b) ? a : b);
251 }
252
253 /* Release the memory used by a node */
254 void free_node (struct node *ptr) {
255 free (ptr->name);
256 if (ptr->size != NULL) free (ptr->size);
257 saw 1.1 if (ptr->title != NULL) free (ptr->title);
258 free (ptr);
259 }
260
261 /* Release the memory used by each node in a linked list */
262 void clear_list (struct node* start) {
263 struct node *ptr = start->next, *old_ptr;
264
265 while (ptr != NULL) {
266 old_ptr = ptr;
267 ptr = ptr->next;
268 free_node (old_ptr);
269 }
270 start->next = NULL;
271 }
272
273 /* Copy length chars from "dest" to "source", terminate "dest" with a \0 */
274 void copy (char dest[], char source[], int length) {
275 memcpy (dest, source, length);
276 dest[length] = '\0';
277 }
278 saw 1.1
279 /* Case insensitive string compare */
280 int strncmp_i (char str1[], char str2[], int length) {
281 int i;
282
283 for (i=0; i<length;i++) if (toupper(str1[i]) != toupper(str2[i])) return (1);
284 return (0);
285 }
286
287 /* Return a pointer to the node which has "string" as it's name field */
288 struct node *find_node (struct node *start, char string[]) {
289 int length, flag=1;
290 struct node *ptr = start;
291
292 do {
293 ptr = ptr->next;
294 if (ptr != NULL) {
295 length = max (extract_text(string), strlen(ptr->name));
296 flag = strncmp_i (ptr->name, string, length);
297 }
298 } while ((flag != 0) && (ptr != NULL));
299 saw 1.1 return (ptr);
300 }
301
302 /* Set the action of the node which has "string" as it's name field */
303 void mark_node (struct node *start, char string[], int new_action) {
304 struct node *node_ptr;
305
306 node_ptr = find_node (start, string);
307 if (node_ptr != NULL) node_ptr->action = new_action;
308 }
309
310 /***************************************************************************
311 * Parse functions
312 ***************************************************************************/
313
314 int determine_type (char string[]) {
315 int i, length;
316
317 for (i=0; i<NUM_TYPES; i++) {
318 length = max (strlen(types[i]), skip_nonblanks(string)-string);
319 if (strncmp_i(string, types[i], length) == 0) return (i/2);
320 saw 1.1 }
321 if (strncmp_i(string, "character", 9) == 0) return (4);
322 if (strncmp_i(string, "integer*2", 9) == 0) {
323 eprint_newline ();
324 eprint ("Warning - Type integer*2:");
325 eprint_newline ();
326 eprint_line (current_line);
327 eprintn (string, strlen(string) - 1);
328 eprint_newline ();
329 return (NOP);
330 }
331 for (i=0; i<3; i++) {
332 length = max (strlen(keywords[i]), extract_text(string));
333 if (strncmp_i(string, keywords[i], length) == 0) return (-i-1);
334 }
335 return (NOP);
336 }
337
338 /* Return a ptr to the first nonblank character in the string */
339 char *skip_blanks (char string[]) {
340 while (isspace (*string)) string++;
341 saw 1.1 return (string);
342 }
343
344 /* Return a ptr to the first blank character in the string */
345 char *skip_nonblanks (char string[]) {
346 while ((! isspace (*string)) && (*string != '\0')) string++;
347 return (string);
348 }
349
350 /* Return a ptr to the character after the first occurrence of "character" */
351 char *find_char (char string[], char character) {
352 while ((*string != character) && (*string != '\0')) string++;
353 if (*string == character) string++;
354 return (string);
355 }
356
357 /* Return the number of contiguous text characters in a string */
358 int extract_text (char string[]) {
359 int i=0;
360
361 while ((isalnum (string[i])) || (string[i] == '_')) i++;
362 saw 1.1 return (i);
363 }
364
365 /* Shift a character string one character to the right */
366 void shift_left (char string[]) {
367 char *ptr = string;
368
369 while (*ptr != '\0') ptr++;
370 *(ptr+1) = '\0';
371 while (ptr != string) *ptr = *(--ptr);
372 }
373
374 /* Parse one line of text */
375 void parse (char string[]) {
|
377 saw 1.1 static int vartype = NOP, state = NOP;
378 char *ptr = string, *title_ptr, *temp;
379
380 if (((string[0] == ' ') && (strlen(string) > 6)) ||
381 ((string[0] == '\t') && (strlen(string) > 2))) {
382 /* The current line is not a comment */
383 if (string[0] == '\t') ptr++;
384 else ptr += 5;
385 if ((isspace (*ptr)) || ((state != COMMON_CONTINUE) && (state != REGISTER_CONTINUE))) {
386 ptr = skip_blanks (ptr);
387 vartype = determine_type (ptr);
388 state = vartype;
389 if (strncmp_i("double precision", ptr, 16) == 0)
390 ptr = skip_blanks (skip_nonblanks (ptr));
391 }
392 if ((vartype != NOP) && (vartype != PARAMETER) && (vartype != EQUIV)) {
393 /* The current line is a list of variables */
394 if (state == COMMON_CONTINUE) {
395 /* The current line is the continuation of a common block */
396 list_ptr = common_start;
397 ptr++;
398 saw 1.1 }
399 else if (state == COMMON) {
400 /* The current line is a common block */
401 list_ptr = common_start;
402 ptr = find_char (find_char (ptr, '/'), '/');
403 state = COMMON_CONTINUE;
404 }
405 else if (state == REGISTER_CONTINUE) {
406 /* The current line is the continuation of a register statement */
407 list_ptr = register_start;
408 ptr++;
409 }
410 else {
411 /* The current line contains variables to be registered */
412 list_ptr = register_start;
413 ptr = skip_nonblanks (ptr);
414 state = REGISTER_CONTINUE;
415 }
416 ptr = skip_blanks (ptr);
417
418 /* Obtain the title string */
419 saw 1.1 title_ptr = string;
420 if (find_char (ptr, ',') > find_char (ptr, '!')) {
421 while (*title_ptr != '!') title_ptr++;
422 title_ptr = skip_blanks (title_ptr+1);
423 if (*title_ptr == '\0') title_ptr = NULL;
424 }
425 else title_ptr = NULL;
426 /* Convert ' to '' in title string */
427 if (title_ptr != NULL) {
428 temp = title_ptr;
429 while (*temp != '\0') {
430 if (*temp == '\'') shift_left (temp++);
431 temp++;
432 }
433 }
434
435 /* Add each variable to the linked list */
436 while ((ptr < find_char (string, '!')) && (*ptr != '!')) {
437 if ((find_char (ptr, '(') < find_char (ptr, ',')) &&
438 (find_char (ptr, '(') < find_char (ptr, '!'))) {
439 /* The variable is an array */
440 saw 1.1 create (list_ptr, vartype, ptr, title_ptr);
441 if (vartype >= 0) array_flags[current_calltype][vartype] = 1;
442 ptr = skip_blanks (find_char (find_char (ptr, ')'), ','));
443 }
444 else {
445 /* The variable is not an array */
446 create (list_ptr, vartype, ptr, title_ptr);
447 if (vartype >=0) variable_flags[current_calltype][vartype] = 1;
448 ptr = skip_blanks (find_char (ptr, ','));
449 }
450 }
451 }
452 if (vartype == PARAMETER)
453 /* If the line is a parameter statement, then ignore the variable */
454 mark_node (register_start, skip_blanks(find_char (ptr, '(')), IGNORE);
455 if (vartype == EQUIV) {
456 /* If the line is an equivalence statement, then skip the variables */
457 ptr = skip_blanks (find_char (ptr, '('));
458 mark_node (register_start, ptr, SKIP);
459 if (find_char(ptr,'(') < find_char(ptr,',')) ptr = find_char(ptr,')');
460 ptr = skip_blanks (find_char (ptr, ','));
461 saw 1.1 mark_node (register_start, ptr, SKIP);
462 }
463 }
464 }
465
466 /* Compare the common list with the register list */
467 void compare_lists () {
468 struct node *ptr, *common_node;
469
470 eprint_newline ();
471 eprint ("Registered, but did not occur in a common block:");
472 eprint_newline ();
473 ptr = register_start->next;
474 while (ptr != NULL) {
475 common_node = find_node (common_start, ptr->name);
476 if (common_node != NULL) {
477 common_node->action = MARK;
478 if ((common_node->title != NULL) && (ptr->title == NULL)) {
479 ptr->title = malloc (strlen(common_node->title)+1);
480 if (ptr->title == NULL) memory_error ();
481 strcpy (ptr->title, common_node->title);
482 saw 1.1 }
483 }
484 else if ((ptr->action != IGNORE) && (ptr->action != SKIP)) {
485 eprint_line (ptr->line_number);
486 eprint (ptr->name);
487 eprint_newline ();
488 }
489 ptr = ptr->next;
490 }
491
492 eprint_newline ();
493 eprint ("Occurred in a common block, but were not registered:");
494 ptr = common_start->next;
495 while (ptr != NULL) {
496 if (ptr->action != MARK) {
497 eprint_newline ();
498 eprint_line (ptr->line_number);
499 eprint (ptr->name);
500 }
501 ptr = ptr->next;
502 }
503 saw 1.1 eprint ("\n\n");
504 }
505
506 /* Write a header to the output file */
507 void write_fortran_header () {
508 time_t current_time = time (NULL);
509
510 fprintf (output, "******************************************************");
511 fprintf (output, "*************************\n");
512 fprintf (output, "* This file (%s) was generated ", output_filename);
513 fprintf (output, "from %s by makereg %s\n", input_filename, VERSION);
514 fprintf (output, "* This file was created on ");
515 fprintf (output, "%s", asctime (localtime (¤t_time)));
516 fprintf (output, "*\n");
517 fprintf (output, "* The command used to create this file was:\n");
518 fprintf (output, "* %s\n", command_line);
519 fprintf (output, "*\n");
520 fprintf (output, "* Do not edit this file.\n");
521 fprintf (output, "******************************************************");
522 fprintf (output, "*************************\n\n");
523 fprintf (output, " subroutine %s\n\n", subroutine_name);
524 saw 1.1 fprintf (output, " implicit none\n\n");
525 }
526
527 /* Write the fortran code to an output file */
528 void write_fortran_code () {
529 struct node *ptr = register_start->next;
530 int i, j;
531
532 for (j=0; j<3; j++) {
533 if (variable_flags[j][0] == 1) variable_flags[j][1] = 1;
534 if (array_flags[j][0] == 1) array_flags[j][1] = 1;
535 }
536
537 fprintf (output, " include '%s'\n\n", input_filename);
538 for (j=0; j<3; j++) {
539 for (i=1; i<5; i++) {
540 if (variable_flags[j][i] == 1) {
541 fprintf (output, "c integer ");
542 fprintf (output, "reg%s%s\n", call_names[j], type_names[i]);
543 fprintf (output, "c external ");
544 fprintf (output, "reg%s%s\n", call_names[j], type_names[i]);
545 saw 1.1 }
546 if (array_flags[j][i] == 1) {
547 fprintf (output, "c integer ");
548 fprintf (output, "reg%s%sarray\n", call_names[j], type_names[i]);
549 fprintf (output, "c external ");
550 fprintf (output, "reg%s%sarray\n", call_names[j], type_names[i]);
551 }
552 }
553 }
554 fprintf (output, "\n");
555
556 /* Loop to output the reg calls */
557 while (ptr != NULL) {
558 if (ptr->action != IGNORE) {
559 fprintf (output, " call reg%s", call_names[ptr->calltype]);
560 fprintf (output, "%s", type_names[ptr->vartype]);
561 if (ptr->size == NULL)
562 fprintf (output, "('%s',%s,", ptr->name, ptr->name);
563 else
564 fprintf (output, "array('%s',%s,%s,", ptr->name, ptr->name, ptr->size);
565 if (ptr->title == NULL) fprintf (output, "0)\n");
566 saw 1.1 else {
567 fprintf (output, "\n & ");
568 fprintf (output, "'%s')\n", ptr->title);
569 }
570 }
571 ptr = ptr->next;
572 }
573
574 fprintf (output, "\n");
575 fprintf (output, " return\n");
576 fprintf (output, " end\n");
577 }
578
579 /* Set the call type to "test", "parm", or "event" */
580 void set_call_type (char string[]) {
581 int i;
582 char *ptr;
583
584 if (strlen (string) != 0) {
585 ptr = skip_blanks (string+1);
586 if (strncmp_i(ptr, "CTPTYPE", 7) == 0) {
587 saw 1.1 while (isalpha(*ptr) && (*ptr != '\0')) ptr++;
588 while ((! isalpha(*ptr)) && (*ptr != '\0')) ptr++;
589 if (*ptr != '\0')
590 for (i=0; i<4; i++)
591 if (strncmp_i(ptr, call_names[i], 3) == 0) current_calltype = i;
592 }
593 }
594 }
595
596 void print_usage () {
597 printf ("Usage: makereg infile [-o outfile] [-e errorfile] ");
598 printf ("[-s subroutine name]\n");
599 printf (" [-c test | parm | event]\n");
600 exit (0);
601 }
602
603 int main (int argc, char *argv[]) {
604 char buffer[BUFFER_LEN];
605 struct node first_register_node, first_common_node;
606 int i, j;
607
608 saw 1.1 first_register_node.next = NULL;
609 first_common_node.next = NULL;
610 register_start = &first_register_node;
611 common_start = &first_common_node;
612
613 for (i=0; i<argc; i++) {
614 strcat (command_line, argv[i]);
615 strcat (command_line, " ");
616 }
617
618 current_calltype = CTPTEST;
619 error = stderr;
620 if (argc < 2) print_usage ();
621 strcpy (input_filename, argv[1]);
622 strcpy (output_filename, input_filename);
623 if ((strcmp (strrchr(output_filename, '.'), ".cmn")) == 0)
624 strcpy (strrchr(output_filename, '.'), ".f");
625 else strcat (output_filename, ".f");
626 i = 2;
627 while (i < argc) {
628 if (strcmp(argv[i], "-o") == 0) {
629 saw 1.1 if (argc > i+1) strcpy (output_filename, argv[i+1]);
630 else print_usage ();
631 }
632 else if (strcmp(argv[i], "-e") == 0) {
633 if (argc > i+1) strcpy (error_filename, argv[i+1]);
634 else print_usage ();
635 }
636 else if (strcmp(argv[i], "-c") == 0) {
637 if (argc > i+1) {
638 for (j=0; j<3; j++)
639 if (strcmp(argv[i+1], call_names[j]) == 0) current_calltype = j;
640 }
641 else print_usage ();
642 }
643 else if (strcmp(argv[i], "-s") == 0) {
644 if (argc > i+1) strcpy (subroutine_name, argv[i+1]);
645 else print_usage ();
646 }
647 i += 2;
648 }
649 input = fopen (input_filename, "r");
650 saw 1.1 if (input == NULL) {
651 printf ("Invalid filename: %s\n", input_filename);
652 print_usage ();
653 }
654 output = fopen (output_filename, "w");
655 if (output == NULL) {
656 printf ("Invalid filename: %s\n", output_filename);
657 print_usage ();
658 }
659 if (strlen(error_filename) != 0) {
660 error = fopen (error_filename, "w");
661 if (error == NULL) {
662 printf ("Invalid filename: %s\n", error_filename);
663 print_usage ();
664 }
665 }
666 if (strlen(subroutine_name) == 0) {
667 strcpy (subroutine_name, output_filename);
668 if (strrchr(subroutine_name, '.') != NULL)
669 *strrchr(subroutine_name, '.') = '\0';
670 }
671 saw 1.1
672 write_fortran_header ();
673 current_line = 1;
674 while (fgets (buffer, BUFFER_LEN, input) != NULL) {
675 set_call_type (buffer);
676 if (strncmp(buffer, "*%%", 3) == 0)
677 fprintf (output, " %s", skip_blanks(skip_nonblanks(buffer)));
678 else if (current_calltype != CTPOFF) parse (buffer);
679 current_line++;
680 }
681 compare_lists ();
682 write_fortran_code ();
683 clear_list (register_start);
684 clear_list (common_start);
685 fclose (input);
686 fclose (output);
687 fclose (error);
688 return 0;
689 }
|
Return to
makereg.c
CVS log
Up to [HallC] / Analyzer / CTP