utilities/scwmdoc.in

   1 #!@PERL@ -w
   2 # $Id: scwmdoc.in,v 1.1 2000-05-19 06:51:06 sgt Exp $ -*- perl -*-
   3 # scwmdoc
   4 # Copyright (C) 1998-1999 Greg J. Badros
   5 #
   6 # scwmdoc pulls out the SCWM_PROC declarations and comments
   7 # from a SCWM .c source file and processes them to create
   8 # documentation
   9 #
  10 # Usage: perl scwmdoc <filenames-to-extract-from>
  11 #
  12 # e.g.,
  13 #
  14 # perl scwmdoc *.c
  15 #
  16 # Purpose:
  17 # Extract documentation from comments in C source files
  18 # and generate a plaintext listing of the procedures, and
  19 # DocBook SGML output to create parts of the Scwm manual.
  20 #
  21 # Note that this script does lots of important error checking, and
  22 # produces error and warning messages that look like grep, so emacs'
  23 # compile-mode (and probably grep-mode) can be used to find problems
  24 # with the documentation using M-x compile (C-x c) scwmdoc *.c >
  25 # /dev/null then M-x next-error (C-x `)
  26 #
  27 # Usage:
  28 #  from ~lgjb/scwm
  29 # ./utilities/dev/scwmdoc -o doc/scwm scwm/*.c > doc/scwm-procedures.txt
  30 # or from Emacs, for warnings only
  31 # ./utilities/dev/scwmdoc scwm/*.c > /dev/null
  32 #
  33 # See also extract.scm, an implementation in guile-scheme instead of perl
  34 # written by Harvey Stein
  35 # Main differences:  that code is ~7x slower
  36 #                    perhaps not as well tested
  37 #                    more and better abstractions in the scheme version
  38 #                    It uses guile (easier acceptance by guile-devs, perhaps)
  39 #                    and it's pretty out of date now --03/24/99 gjb
  40 #
  41 # TODO: make concept section id-s use a prefix (e.g., shadow-factor user-option
  42 # variable's doc id conflicts with the shadow-factor getter primitive)
  43
  44 require 5.004;  # uses "for my $var"
  45 use strict;
  46 use constant TRUE => (1==1);
  47 use constant FALSE => (1==0);
  48 use File::Basename;
  49
  50 my $getopts_option_letters = 'hqQDo:sCd:V:O:H:N:nP:SF';
  51 use vars qw($opt_h $opt_q $opt_Q $opt_D $opt_o $opt_s $opt_C $opt_F
  52             $opt_d $opt_V $opt_O $opt_H $opt_N $opt_n $opt_P $opt_S);
  53
  54 my $scwm_version = "pre-1.0";
  55
  56 sub script_usage ( ) {
  57   print "@_\nUsage: $0 [-$getopts_option_letters]
  58 -q       Be reasonably quiet-- do not warn about spacing or purpose strings
  59 -Q       Be completely QUIET-- no warnings (still prints errors)
  60 -D       Debugging output on
  61 -V file  Output user-options scheme module to file [obsoleted] -- skip if not given
  62 -O file  Output user-options documentation to file -- skip if not given
  63 -H file  Output user hooks documentation to file -- skip if not given
  64 -N file  Output concepts documentation to file -- skip if not given
  65 -o file  Send sgml output to file -- no sgml output unless this is given
  66 -s       Run ispell on the comments and reports warnings for its responses
  67 -C       Only output concepts chapters
  68 -n       No warning for problems with comments
  69 -d URL  Set scwmdir source code base to path (e.g., file:///usr/local/src/scwm)
  70 -P prefix Set package prefix (e.g., -PCL to use CL_* instead of SCWM_*)
  71 -S       Skip the procedures chapters-- makes it much faster to convert to HTML
  72 -F       Skip all procedures except those starting with \"F\" for fast check on output
  73 ";
  74   exit 0;
  75 }
  76
  77
  78 my $prefix = "SCWM";
  79 my $pkg_name = basename($ENV{PWD});
  80 my $fDebug = FALSE;
  81 my $fQuiet = FALSE;
  82 my $fReallyQuiet = FALSE;
  83 my $fWarnIfNoComment = TRUE;
  84
  85 # Text from sgml files making up the book
  86 my $ref_header_sgml;
  87 my $ref_concepts_intro_sgml;
  88 my $ref_hooks_intro_sgml;
  89 my $ref_vars_intro_sgml;
  90 my $ref_proc_bygroup_intro_sgml;
  91
  92 my $fAddedStyleHeader = FALSE;
  93
  94 use Getopt::Std;
  95 getopts($getopts_option_letters);
  96
  97 script_usage() if ($opt_h);
  98
  99 #print STDERR "opt_D = $opt_D, ", TRUE, "\n";
 100
 101 $fDebug = TRUE if $opt_D;
 102 $fQuiet = TRUE if $opt_q || $opt_Q;
 103 $fReallyQuiet = TRUE if $opt_Q;
 104 $fWarnIfNoComment = FALSE if $opt_n;
 105 $prefix = $opt_P if $opt_P;
 106
 107 # link directly to the cvsweb checkout of the file;
 108 # I could even make this go to the version that the docs were generated
 109 # from, but I think it's better to look at the latest version for now
 110 # (at least until 1.0)
 111 my $scwmdir = $opt_d || "http://scwm.mit.edu/cgi-bin/cvsweb.new/~checkout~";
 112
 113 # maps from a procedure name to a hash
 114 # containing "usage", "purpose", "comment",  "markup", "file", "line"
 115 my %procedure = ();
 116
 117 # maps from a filename to a list reference containing the names of
 118 # primitives defined in that file
 119 my %file_funcs = ();
 120
 121 # Maps from concepts/hooks/vars to a hash containing
 122 # "comment", "markup", "file", "line"
 123 my %concepts = ();
 124 my %hooks = ();
 125 my %vars = ();
 126
 127 # list of the argument names in the current C function
 128 my @argnames = ();
 129
 130 # Current scheme environment
 131 # i.e., the last define-module seen, reset at new files
 132 my $current_module = "";
 133
 134 # The last public scheme variable definition
 135 # Useful for ";;;**VAR"  w/o explicit name in .scm files
 136 my $last_public_scheme_definition = "";
 137
 138 use FileHandle;
 139 use IPC::Open2;
 140
 141 # dictionary of scwm-specific words, in the same directory as this script
 142 (my $dictionary = $0)=~s#[^/]*$#dictionary#;
 143
 144 my $pid = open2( \*ISPELL_RESPONSE,
 145                  \*ISPELL, "ispell -a -p $dictionary") or die "Could not open \'ispell -a\' pipe: $!";
 146 ISPELL->autoflush();
 147
 148 MAINLOOP:
 149 while (<>) {
 150   if (eof) {
 151     close(ARGV);
 152     $current_module = "";
 153     next;
 154   }
 155   my $fScheme = ($ARGV =~ /.scm$/);
 156   if (m/^${prefix}_[IW]?PROC/o) {
 157     my $header = $_;
 158     my $filename = $ARGV;
 159     my $line = $.;
 160     while (defined($_ = <>) && $_ !~ m/^\s*\{/) {
 161       if (eof) {
 162         close(ARGV);
 163         $current_module = "";
 164         redo MAINLOOP;
 165       }
 166       $header .= $_;
 167     }
 168     $header .= $_;
 169     ProcessHeader($filename, $line, $header);
 170   } elsif (m%/\*\*?\s*SCWM[_-]?VALIDATE\s*:\s*(.*)\s*\*/%) {
 171     my $argslist = $1;
 172     $argslist =~ s/\n/ /g;
 173     $argslist =~ s/[ \t]+//g;
 174     @argnames = split(/,/, $argslist);  # this array is for comparison w/ C code
 175   } elsif (m/^\s*scm_wrong_type_arg\s*\(\s*FUNC_NAME\s*,\s*(\d+)\s*,\s*(\w+)\s*\)/) {
 176     my $argnum = $1; # 1-based
 177     my $argname = $2;
 178     check_arg_name_number_match("scm_wrong_type_arg",$1,$2,\@argnames);
 179   } elsif (m/^\s*SCWM_WRONG_TYPE_ARG\s*\(\s*(\d+)\s*,\s*(\w+)\s*\)/) {
 180     my $argnum = $1; # 1-based
 181     my $argname = $2;
 182     check_arg_name_number_match("SCWM_WRONG_TYPE_ARG",$1,$2,\@argnames);
 183   } elsif (m/^\s*(VALIDATE_[^\(]*)\s*\(\s*(\d+)\s*,\s*(\w+)\s*/) {
 184     my $validate_fn = $1;
 185     my $argnum = $2; # 1-based
 186     my $argname = $3;
 187     check_arg_name_number_match($1,$2,$3,\@argnames);
 188 #  } elsif (m/${prefix}_HOOK\s*\(\s*([^,]+)\s*,\s*\"([^\"]+)\"\s*,\s*(\d+)\s*,\s*(\".*?[^\\]\")\s*\)\s*;/o) {
 189   } elsif (m/${prefix}_HOOK\s*\(\s*([^,]+)\s*,\s*\"([^\"]+)\"\s*,\s*(\d+)\s*,\s*$/o) {
 190     my $c_hookname = $1;
 191     my $scheme_hookname = $2;
 192     my $num_args = $3;
 193     my $filename = $ARGV;
 194     my $line = $.;
 195     my $body = <>;
 196 #    print STDERR "Got hook body = $body\n";
 197     if (!CNameMatchesSchemeName($c_hookname,$scheme_hookname) &&
 198         ($c_hookname !~ m/^x_\S+_hook/ ||
 199          !CNameMatchesSchemeNameIgnoreCase($c_hookname,$scheme_hookname))) {
 200       # We permit the X-foo-hook's to mismatch as long as only the case is different
 201       print STDERR "$ARGV:$.:**** Scheme hook name `$scheme_hookname' does not match `$c_hookname'\n";
 202     }
 203     if ($body !~ m%^\s*\"(.*)$%) {
 204       $_ = $body;
 205       print STDERR "$ARGV:$.:**** Hook $scheme_hookname is missing docstring\n";
 206       redo MAINLOOP;
 207     }
 208 #    $body = ReadRestOfComment($1);
 209     if (!($body =~ s%\"\s*\)\s*;\s*$%%m)) {
 210       $body = ReadRestOfDocstring($filename,$line,"$1\n");
 211     } else {
 212       # Handle single-line docstrings
 213       $body =~ s%^\s*\"%%;
 214     }
 215     if ($fDebug) {
 216       print STDERR "GOT hook $c_hookname,$scheme_hookname at ",
 217           " $filename:$line body:\n$body\n";
 218     }
 219     ProcessHookComment($filename, $line, $scheme_hookname, $num_args, $body);
 220   } elsif (m/${prefix}_VAR(?:_READ_ONLY|_INIT(?:_PERMANENT)?)\s*\(\s*([^,]+)\s*,\s*\"([^"]+)"/o) {
 221     #FIXGJB: not ideal, since macro needs to end on same line
 222     # or else the comment will not get found --02/11/99 gjb
 223     my $c_varname = $1;
 224     my $scheme_varname = $2;
 225     my $filename = $ARGV;
 226     my $line = $.;
 227     my $body = <>;
 228 #    print STDERR "Found var $c_varname\n";
 229     if ($c_varname ne "NULL" &&
 230         !CNameMatchesSchemeName($c_varname,$scheme_varname)) {
 231       print STDERR "$ARGV:$.:**** Scheme variable name `$scheme_varname' does not match `$c_varname'\n";
 232     }
 233     if ($body !~ m%/\*\*\s*(.*)%) {
 234       $_ = $body;
 235       print STDERR "$ARGV:$.:**** Variable $scheme_varname is missing /** description comment\n";
 236       redo MAINLOOP;
 237     }
 238     $body = ReadRestOfComment($1);
 239     if ($fDebug) {
 240       print STDERR "GOT variable $c_varname,$scheme_varname at ",
 241           " $filename:$line body:\n$body\n";
 242     }
 243     ProcessVarComment($filename, $line, $scheme_varname, $body);
 244   } elsif ($fScheme && m%^\(define-module\s+(\([^\)]*\))%) {
 245     $current_module = $1;
 246   } elsif ($fScheme && m%^\(define\*?-public\s+\(([^\s\)]+)%) {
 247     my $scheme_header = $_;
 248     my $proc_name = $1;
 249     my $filename = $ARGV;
 250     my $line = $.;
 251     # Keep reading lines until eof or a paren in leftmost column
 252     while (defined($_ = <>) && $_ !~ m/^\(/) {
 253       $scheme_header .= $_;
 254       if (eof) {
 255         close(ARGV);
 256         $current_module = "";
 257       }
 258     }
 259     ProcessSchemeHeader($filename, $current_module, $proc_name, $line, $scheme_header);
 260     redo if (defined($_)); # start loop over w/o reading next line
 261   } elsif ($fScheme && m%^\(define-string-matcher\s+(\S+)%) {
 262     my $scheme_header = $_;
 263     my $proc_name = $1;
 264     my $filename = $ARGV;
 265     my $line = $.;
 266     # Keep reading lines until eof or a paren in leftmost column
 267     while (defined($_ = <>) && $_ !~ m/^\(/) {
 268       $scheme_header .= $_;
 269       if (eof) {
 270         close(ARGV);
 271         $current_module = "";
 272       }
 273     }
 274     ProcessSchemeExtension($filename, $current_module, $proc_name, $line, $scheme_header);
 275     redo if (defined($_)); # start loop over w/o reading next line
 276   } elsif ($fScheme && m%^\(add-(boolean-style|window-style|window-hint)-option\s+\#:(\S+)%) {
 277     my $filename = $ARGV;
 278     my $line = $.;
 279     ProcessWindowStyleOption($filename,$line,$1,$2);
 280   } elsif ($fScheme && m%^\(define-public\s+([^\s\)]+)%) {
 281     # this is for variables, so we don't need the optional * above
 282     $last_public_scheme_definition = $1;
 283   } elsif (m%(?:/|^;;;\s*)\*\*\s*(\w[^:\n\s]*)(?::\s*(.*?))?\s*$%) {
 284     # matches a /** CHAPTER: DESCRIPTION (e.g., CONCEPT) comment
 285     my $type = $1;
 286     my $description = $2;
 287     if (!defined($description) || $description eq "") {
 288       if ($type eq "VAR" &&
 289           $last_public_scheme_definition ne "") {
 290         $description = $last_public_scheme_definition;
 291       } else {
 292         print STDERR "$ARGV:$.:**** Missing \": section\" in /**$type marker\n";
 293         next;
 294       }
 295     }
 296     if ($fDebug) {
 297       print STDERR "GOT $type, $description\n";
 298     }
 299     if ($type eq "" || $description eq "") {
 300       print STDERR "$ARGV:$.:**** Improper /**-style comment: got type = \`$type\', description = \`$description\'.\n";
 301       next;
 302     }
 303     if (uc($type) eq "HOOK") {
 304       my $filename = $ARGV;
 305       my $line = $.;
 306       my $body = ReadRestOfComment("",$fScheme);
 307       print STDERR "**** $filename:$line: warning -- old-style HOOK documentation\n";
 308       ProcessHookComment($filename, $line, $description,-1,$body);
 309     } elsif (uc($type) eq "CONCEPT") {
 310       my $filename = $ARGV;
 311       my $line = $.;
 312       my $body = ReadRestOfComment("",$fScheme);
 313       ProcessConceptComment($filename, $line, $description,$body);
 314     } elsif (uc($type) eq "VAR") {
 315       my $filename = $ARGV;
 316       my $line = $.;
 317       my $body = ReadRestOfComment("",$fScheme);
 318       ProcessVarComment($filename, $line, $description, $body);
 319     } else {
 320       print STDERR "$ARGV:$.:**** Unrecognized type for /**-style comment = \`$type\'\n";
 321       next;
 322     }
 323   } elsif (m%^\s*$%) {
 324     $last_public_scheme_definition = "";
 325   }
 326 }
 327
 328 my $sgml_name = ""; # "$pkg_name.sgml";
 329 if ($opt_o) {
 330   $sgml_name = $opt_o;
 331   $sgml_name .= ".sgml" if ($sgml_name !~ /\..+ml$/);
 332   my $dir = dirname $sgml_name;
 333
 334   open (MARKUP_OUT,">$sgml_name") or die "Could not write to $sgml_name: $!";
 335   chop (my $date = `date +"%d %B %Y"`);
 336   chop (my $year = `date +"%Y"`);
 337
 338   $ref_header_sgml = ReadSgml("$dir/src/ref-header.sgml");
 339   $ref_concepts_intro_sgml = ReadSgml("$dir/src/ref-concepts-intro.sgml");
 340   $ref_hooks_intro_sgml = ReadSgml("$dir/src/ref-hooks-intro.sgml");
 341   $ref_vars_intro_sgml = ReadSgml("$dir/src/ref-vars-intro.sgml");
 342   $ref_proc_bygroup_intro_sgml = ReadSgml("$dir/src/ref-proc-bygroup-intro.sgml");
 343
 344   $ref_header_sgml =~ s/\@DATE\@/$date/g;
 345   $ref_header_sgml =~ s/\@YEAR\@/$year/g;
 346   $ref_header_sgml =~ s/\@VERSION\@/$scwm_version/g;
 347
 348   print MARKUP_OUT "$ref_header_sgml";
 349 }
 350
 351
 352 CONCEPTS_CHAPTER:
 353
 354 # Now output concepts chapter
 355 if ($opt_o) {
 356   DoneWindowStyleOptions(); # close the markup for window styles
 357
 358   print MARKUP_OUT <<START_CONCEPTS_CHAPTER
 359   <chapter>
 360     <title>Concepts</title>
 361       <sect1 id="Concepts-Introduction"><title>Introduction</title>
 362         $ref_concepts_intro_sgml
 363       </sect1>
 364 START_CONCEPTS_CHAPTER
 365    ;
 366   foreach my $concept (sort { lc($a) cmp lc($b) } keys %concepts ) {
 367     my $markup = $concepts{$concept}{markup};
 368     my $concept_id = ScmIdToSgmlId($concept);
 369     $concept_id =~ tr/ _/--/;
 370     print MARKUP_OUT "    <sect1 id=\"$concept_id\"><title>$concept</title><para>\n$markup
 371     </para></sect1>\n";
 372   }
 373
 374   print MARKUP_OUT "  </chapter>\n";
 375 }
 376
 377 if ($opt_C) {
 378   goto SGML_TRAILER;
 379 }
 380
 381 # Now output hooks chapter
 382 if ($opt_o) {
 383   print MARKUP_OUT <<START_HOOKS_CHAPTER
 384   <chapter>
 385     <title>Hooks</title>
 386       <sect1 id="Hooks-Introduction"><title>Introduction</title>
 387         $ref_hooks_intro_sgml
 388       </sect1>
 389 START_HOOKS_CHAPTER
 390   ;
 391   foreach my $hook (sort { lc($a) cmp lc($b) } keys %hooks ) {
 392     my $markup = $hooks{$hook}{markup};
 393     my $numargs = $hooks{$hook}{numargs};
 394     my $args_text = "$numargs args";
 395     if ($numargs == 0) {
 396       $args_text = "thunk";
 397     } elsif ($numargs == 1) {
 398       $args_text = "1 arg";
 399     }
 400     print MARKUP_OUT "    <sect1 id=\"$hook\"><title>$hook ($args_text)</title><para>\n$markup
 401     </para></sect1>\n";
 402   }
 403   print MARKUP_OUT "  </chapter>\n";
 404 }
 405
 406
 407 # Now output vars chapter
 408 if ($opt_o) {
 409   print MARKUP_OUT <<START_VARS_CHAPTER
 410   <chapter>
 411     <title>User variables</title>
 412       <sect1 id="Vars-Introduction"><title>Introduction</title>
 413         $ref_vars_intro_sgml
 414       </sect1>
 415 START_VARS_CHAPTER
 416   ;
 417   foreach my $var (sort { lc($a) cmp lc($b) } keys %vars ) {
 418     my $markup = $vars{$var}{markup};
 419     my $sgmlid = ScmIdToSgmlId($var);
 420     print MARKUP_OUT "    <sect1 id=\"$sgmlid\"><title>$var</title><para>\n$markup
 421     </para></sect1>\n";
 422   }
 423   print MARKUP_OUT "  </chapter>\n";
 424 }
 425
 426 if ($opt_S) {
 427   goto SGML_TRAILER;
 428 }
 429
 430 PROCEDURES_BY_GROUP:
 431
 432 # Now output primitives by defined-in file
 433 if ($opt_o) {
 434   print MARKUP_OUT <<START_PROC_BY_FILE
 435   <chapter>
 436     <title>Procedure Synopses by Group</title>
 437       <sect1 id="Procs-ByGroup-Introduction"><title>Introduction</title>
 438         $ref_proc_bygroup_intro_sgml
 439       </sect1>
 440 START_PROC_BY_FILE
 441   ;
 442
 443   foreach my $file (sort { lc($a) cmp lc($b) } keys %file_funcs) {
 444     my @prims = @{$file_funcs{$file}};
 445     if ($opt_F) {
 446       # keep only primitives that start with "F"
 447       @prims = grep(m/^f/i, @prims);
 448     }
 449     if (scalar(@prims) > 0) {
 450       print MARKUP_OUT "    <sect1><title>$file</title> <itemizedlist>\n";
 451       foreach my $proc (sort { $procedure{$a}{line} <=> $procedure{$b}{line} } @prims ) {
 452         my $markup = $procedure{$proc}{markup};
 453         my $target = $procedure{$proc}{sgml_id};
 454         my $primname = $procedure{$proc}{primname};
 455         my $purpose = $procedure{$proc}{purpose};
 456         my $markup_purpose = $procedure{$proc}{markup_purpose};
 457         print MARKUP_OUT "      <listitem><para><link linkend=\"$target\"><function>$proc</function></link> -- $markup_purpose</para></listitem>\n";
 458       }
 459       print MARKUP_OUT "    </itemizedlist> </sect1>\n";
 460     }
 461   }
 462   print MARKUP_OUT "  </chapter>\n";
 463 }
 464
 465 PROCEDURES_CHAPTER:
 466
 467 if ($opt_o) {
 468   print MARKUP_OUT <<END_CHAP_HEAD
 469   <chapter>
 470     <title>Procedures in Alphabetical Order</title>
 471 END_CHAP_HEAD
 472   ;
 473 }
 474
 475 # This outputs the scwm-procedures.txt file to stdout
 476 foreach my $proc (sort { lc($a) cmp lc($b) } keys %procedure) {
 477   my $usage = $procedure{$proc}{usage};
 478   my $comment = $procedure{$proc}{comment};
 479   my $file = $procedure{$proc}{file};
 480   my $line = $procedure{$proc}{line};
 481   my $markup = $procedure{$proc}{markup};
 482   my $module = $procedure{$proc}{module};
 483   print <<EOC
 484 $usage
 485 - $module
 486 $comment
 487 [From $file:$line]
 488 \f
 489 EOC
 490   ;
 491   if ($opt_o) {
 492     next if $opt_F && $proc !~ m/^f/i;
 493     print MARKUP_OUT $markup, "\n";
 494   }
 495 }
 496
 497 # End the procedures chapter
 498 if ($opt_o) {
 499   print MARKUP_OUT "  </chapter>\n";
 500 }
 501
 502
 503
 504 SGML_TRAILER:
 505
 506 # Now output sgml trailer
 507 if ($opt_o) {
 508   print MARKUP_OUT <<END_TRAILER
 509 </book>
 510 <!-- Keep this comment at the end of the file
 511 Local variables:
 512 mode: sgml
 513 fill-column: 10000
 514 sgml-omittag:nil
 515 sgml-shorttag:t
 516 End:
 517 -->
 518 END_TRAILER
 519   ;
 520 }
 521
 522 if ($opt_V || $opt_O) {
 523   my $file;
 524   if ($opt_V) {
 525     $file = $opt_V;
 526     open(VAR_OUT,">$file") or
 527       die "Could not open $file";
 528     print STDERR "outputting user-options to $file\n";
 529   }
 530
 531   if ($opt_O) {
 532     $file = $opt_O;
 533     open(VAR_DOC_OUT,">$file") or
 534       die "Could not open $file";
 535     print STDERR "outputting vars documentation to $file\n";
 536   }
 537
 538   if ($opt_V) {
 539     print VAR_OUT <<EOC
 540 ;;; AUTOMATICALLY-GENERATED BY extract-docs; DO NOT EDIT!
 541 (define-module (app scwm user-options))
 542
 543 ;; Each element of the list is \'(var-name comment setter getter)
 544 \(define-public user-options \(list
 545 EOC
 546   ;
 547   }
 548   foreach my $var (sort { lc($a) cmp lc($b) } keys %vars ) {
 549     my $comment = $vars{$var}{comment};
 550     my $file = $vars{$var}{file};
 551     my $line = $vars{$var}{line};
 552     my $module = $vars{$var}{module};
 553     # Output information for a user-option variable
 554     print VAR_OUT "\'($var)\n" if $opt_V;
 555
 556     if ($opt_O) {
 557       print VAR_DOC_OUT <<EOC
 558 $var
 559 - $module
 560 $comment
 561 [From $file:$line]
 562
 563 \f
 564 EOC
 565     ;
 566     }
 567   }
 568   if ($opt_V) {
 569     print VAR_OUT "))\n";
 570     close VAR_OUT;
 571   }
 572   if ($opt_O) {
 573     close VAR_DOC_OUT;
 574   }
 575 }
 576
 577 if ($opt_H) {
 578   my $file = $opt_H;
 579   open (HOOKS_OUT,">$file") or
 580     die "Could not open $file";
 581   print STDERR "outputting hooks to $file\n";
 582
 583   foreach my $hook (sort { lc($a) cmp lc($b) } keys %hooks ) {
 584     my $comment = $hooks{$hook}{comment};
 585     my $numargs = $hooks{$hook}{numargs};
 586     my $file = $hooks{$hook}{file};
 587     my $line = $hooks{$hook}{line};
 588     my $module = $hooks{$hook}{module};
 589
 590     print HOOKS_OUT <<EOC;
 591 $hook ($numargs args)
 592 - $module
 593 $comment
 594 [From $file:$line]
 595
 596 \f
 597 EOC
 598   }
 599
 600   close HOOKS_OUT;
 601 }
 602
 603
 604 if ($opt_N) {
 605   my $file = $opt_N;
 606   open (CONCEPTS_OUT,">$file") or
 607     die "Could not open $file";
 608   print STDERR "outputting concepts to $file\n";
 609
 610   foreach my $concept (sort { lc($a) cmp lc($b) } keys %concepts ) {
 611     my $comment = $concepts{$concept}{comment};
 612     my $file = $concepts{$concept}{file};
 613     my $line = $concepts{$concept}{line};
 614
 615     print CONCEPTS_OUT <<EOC;
 616 $concept
 617 -
 618 $comment
 619 [From $file:$line]
 620
 621 \f
 622 EOC
 623   }
 624
 625   close CONCEPTS_OUT;
 626 }
 627
 628
 629 use Text::Balanced;
 630
 631 sub ProcessSchemeHeader( $$$$$ ) {
 632   my ($filename, $module, $proc_name, $line, $header) = @_;
 633   my @arglist;
 634   my ($type,$rest) = ($header =~ m%^\((define\*?-public)\s+(.*)%s);
 635   #  print STDERR "HEAD: $header\n";
 636 #  print STDERR "TYPE: $type\n";
 637   #  print STDERR "REST: $rest\n";
 638   my ($name_and_args,$after_formals) = Text::Balanced::extract_bracketed($rest,'(');
 639 #  print STDERR "NAA: $name_and_args\n";
 640   #  print STDERR "AF: $after_formals\n";
 641   my ($match) = ($name_and_args =~ m%\(\s*([^\s\)]+)%s);
 642   my $comment = Text::Balanced::extract_delimited($after_formals,'"');
 643 #  print STDERR "COMMENT: $comment\n";
 644 #  print STDERR "---------------\n";
 645
 646   if ($fDebug) {
 647     print STDERR "Handling $proc_name from $filename:$line\n";
 648   }
 649
 650   if ($match ne $proc_name) {
 651     print STDERR "$filename:$line:**** $match not same as $proc_name\n";
 652     $proc_name = $match;
 653     undef $comment;
 654   }
 655   if ($match =~ m%^\(%) {
 656     $proc_name = substr($match,1);
 657     # print STDERR "$filename:$line:**** $proc_name is not an ordinary define -- returns a lambda?\n";
 658   }
 659   if (!defined($comment)) {
 660     if ($fWarnIfNoComment) {
 661       print STDERR "$filename:$line:**** $proc_name: could not find comment\n";
 662     }
 663     $comment = "No documentation supplied.";
 664   }
 665 #  my $usage = sprintf "(%s%s%s)", $proc_name, ($#arglist >= 0? " ":""),
 666  #        join(" ",@arglist);
 667   my $usage = $name_and_args;
 668   # Remove leading and trailing quote
 669   $comment =~ s/^\"(.*)\"$/$1/ms;
 670   # Unquote quoted quotes (CRW:FIXME:GJB: are there other things we
 671   # may need to unquote here?)
 672   $comment =~ s/\\"/"/g;
 673 #  print STDERR "Scheme Proc: $proc_name\nArgs: @arglist\n$header\n";
 674 #  print STDERR "$usage\n\n$comment\n\n\f\n";
 675
 676   my $purpose = PurposeFromComment($comment,$filename,$line,$proc_name);
 677
 678   my $sgml_id = ScmIdToSgmlId($proc_name);
 679
 680   my $markup_purpose = MarkupComment($purpose);
 681   my $markup_usage = MarkupUsage($usage);
 682   my $markup_comment = MarkupComment($comment);
 683   my $markup = CreateMarkupBody($proc_name, $sgml_id, $module,
 684                                 $markup_usage, $markup_purpose, $markup_comment,
 685                                 $filename, $line);
 686
 687   $procedure{$proc_name} = { usage => $usage,
 688                              comment => $comment,
 689                              purpose => $purpose,
 690                              sgml_id => $sgml_id,
 691                              module => $module,
 692                              markup_purpose => $markup_purpose,
 693                              markup_usage => $markup_usage,
 694                              markup => $markup,
 695                              file => $filename,
 696                              line => $line,
 697                            };
 698
 699   push @{$file_funcs{$filename}}, $proc_name;
 700
 701 }
 702
 703
 704 # Currently only `define-string-matcher' is handled
 705 sub ProcessSchemeExtension( $$$$$ ) {
 706   my ($filename, $module, $ext_name, $line, $header) = @_;
 707   my @arglist;
 708   my ($type,$rest) = ($header =~ m%^\(define-(string-matcher)\s+\S+\s+(.*)%s);
 709   #  print STDERR "Rest = $rest\n";
 710   my $comment = Text::Balanced::extract_delimited($rest,'"');
 711
 712   if ($fDebug) {
 713     print STDERR "Handling extension $ext_name from $filename:$line\n";
 714   }
 715
 716   if (!defined($comment)) {
 717     if ($fWarnIfNoComment) {
 718       print STDERR "$filename:$line:**** $ext_name: could not find comment\n";
 719     }
 720     $comment = "No documentation supplied.";
 721   }
 722
 723   my $usage = "($ext_name)";
 724
 725   if ($type eq "string-matcher") {
 726     $usage = "($ext_name STRING TYPE CASE-SENSITIVE?)";
 727   }
 728
 729   # Remove leading and trailing quote
 730   $comment =~ s/^\"(.*)\"$/$1/ms;
 731   # Unquote quoted quotes (CRW:FIXME:GJB: are there other things we
 732   # may need to unquote here?)
 733   $comment =~ s/\\"/"/g;
 734
 735   my $purpose = PurposeFromComment($comment,$filename,$line,$ext_name);
 736
 737   my $sgml_id = ScmIdToSgmlId($ext_name);
 738
 739   my $markup_purpose = MarkupComment($purpose);
 740   my $markup_usage = MarkupUsage($usage);
 741   my $markup_comment = MarkupComment($comment);
 742   my $markup = CreateMarkupBody($ext_name, $sgml_id, $module,
 743                                 $markup_usage, $markup_purpose, $markup_comment,
 744                                 $filename, $line);
 745
 746   $procedure{$ext_name} = { usage => $usage,
 747                             comment => $comment,
 748                             purpose => $purpose,
 749                             sgml_id => $sgml_id,
 750                             module => $module,
 751                             markup_purpose => $markup_purpose,
 752                             markup_usage => $markup_usage,
 753                             markup => $markup,
 754                             file => $filename,
 755                             line => $line,
 756                           };
 757
 758   push @{$file_funcs{$filename}}, $ext_name;
 759
 760 }
 761
 762
 763
 764 sub ProcessHeader( $$$ ) {
 765   my ($filename, $line, $header) = @_;
 766 #  print STDERR "header = $header\n";
 767 #  print STDERR "filename = $filename\n";
 768   my ($cprimname, $primname, $req, $opt, $var, $argslist,$space,$intspec,$comment_maybe) =
 769     $header =~ m%^${prefix}_[IW]?PROC\s*\(\s*([^, \t]*),\s*\"([^\"]*)\"\s*,\s*(\d+)\s*,\s*(\d+)\s*,\s*(\d+)\s*,\s*\(([\d\s\w,()\n]*)\)(\s*),(?:[ \t]*([^\n]*?),\s*)?\s*(.*)$%so;
 770
 771 #  print STDERR "argslist = $argslist\n";
 772   if (!defined($comment_maybe)) {
 773     $comment_maybe = $intspec;
 774   }
 775 #  print STDERR "comment_maybe = $comment_maybe\n";
 776   if (defined($space)) {
 777 #    print STDERR "$filename:$line:****WARNING: better to use )) to close arg list\n";
 778   }
 779
 780   if ($fDebug) {
 781     print STDERR "Handing $primname from $filename:$line\n";
 782   }
 783
 784   if (!defined($cprimname)) {
 785     print STDERR "$filename:$line:****ERROR:could not parse argument list\n";
 786     return FALSE;
 787   }
 788   my ($comment) = $comment_maybe =~ m%^\"(.*[^\\])\"\s*\)\s*\#define%s;
 789   my ($fname_define) = $header =~ m%^\s*\#\s*define\s+FUNC_NAME\s+(.*?)\s*$%m;
 790
 791
 792   if (defined($comment)) {
 793     if ($comment =~ m/[^\\]\"/) {
 794       print STDERR "$filename:$line:****ERROR:comment includes an un-escaped double-quote\n";
 795     }
 796     # Unquote quoted quotes (CRW:FIXME:GJB: are there other things we
 797     # may need to unquote here?)
 798     $comment =~ s/\\"/"/g;
 799 #    print STDERR "comment = $comment\n";
 800   }
 801
 802   my $clean_argslist = $argslist;
 803   $clean_argslist =~ s/\bARG_UNUSED\s*\(\s*([^\)]*)\s*\)/$1/g;
 804   $clean_argslist =~ s/\bARG_IGNORE\s*\(\s*([^\)]*)\s*\)/$1/g;
 805 #  print STDERR "clean arglist = $clean_argslist\n";
 806   my $cremovals = ($clean_argslist =~ s/\bSCM\b//g);
 807   $clean_argslist =~ s/\n/ /g;
 808   $clean_argslist =~ s/[ \t]+//g;
 809   @argnames = split(/,/, $clean_argslist);  # this array is for comparison w/ C code
 810   $clean_argslist =~ s/_[pP]\b/?/g;
 811   $clean_argslist =~ s/_[xX]\b/!/g;
 812   $clean_argslist =~ s/_/-/g;
 813   my @args = split(/,/, $clean_argslist);
 814
 815   # now create a hash of the names for testing words in the comment
 816   # whether they are referring to formal parameters
 817   my %argnames = map { uc($_) => 1} @args;
 818
 819   if (!CNameMatchesSchemeName($cprimname, $primname)) {
 820     if (!$fReallyQuiet) {
 821       print STDERR "$filename:$line:**** $cprimname: scheme primitive name `$primname' does not match `$cprimname'\n";
 822     }
 823   }
 824
 825   if ($cremovals != scalar(@args) ) {
 826     print STDERR "$filename:$line:**** $cprimname: types inconsistency (all args should be type SCM)\n";
 827   }
 828
 829   if (($req + $opt + $var) != scalar(@args)  ) {
 830     print STDERR "$filename:$line:**** $cprimname: argument inconsistency -- check #s of arguments\n";
 831   }
 832
 833   if ($var != 0 && $var != 1) {
 834     print STDERR "$filename:$line:**** $cprimname: number of variable arguments == $var -- why?\n";
 835   }
 836
 837   my $fAlreadyWarnedAboutNoComment = FALSE;
 838
 839   if (!defined($comment) || $comment eq "") {
 840     if (!$fReallyQuiet && $fWarnIfNoComment) {
 841       $fAlreadyWarnedAboutNoComment = TRUE;
 842       print STDERR "$filename:$line:**** $cprimname: comment missing\n";
 843 #      print STDERR "comment_maybe = $comment_maybe\n";
 844     }
 845     $comment = "";
 846   }
 847
 848   if (!defined($fname_define)) {
 849     print STDERR "$filename:$line:**** $cprimname: \`#define FUNC_NAME s_$cprimname\' is missing\n";
 850   } elsif ($fname_define ne "s_".$cprimname) {
 851     print STDERR "$filename:$line:**** $cprimname: \`#define FUNC_NAME s_$cprimname\' does not match function name \`$fname_define\'\n";
 852   }
 853
 854   my @required_args = @args[0..($req-1)];
 855   my @optional_args = @args[$req..($req + $opt - 1)];
 856   my @var_args = @args[($req+$opt)..($req+$opt+$var-1)];
 857
 858   my $arg_listing = "";
 859   if ($#args >= 0) {
 860     $arg_listing .= "@required_args";
 861     if ($#optional_args >= 0) {
 862       $arg_listing .= " #&optional @optional_args";
 863     }
 864     if ($#var_args >= 0) {
 865       $arg_listing .= " . @var_args";
 866     }
 867   }
 868
 869   my $usage = sprintf "(%s%s%s)", $primname, ($arg_listing ne ""? " ":""),
 870   $arg_listing;
 871
 872   my %upcase_words = ();
 873
 874   # check to make sure all all-uppercase words in the comment
 875   # refer to formals
 876   foreach my $word (split /[^-+%?\$!\w_\"]+/, $comment) {
 877     if ($word =~ /^[A-Z][-%A-Z0-9_+?!]+$/) {
 878       if (!defined($argnames{$word})) {
 879         next if $word eq "X11";  # do not require this word to be an argumet
 880         if (!$fReallyQuiet) {
 881           print STDERR "$filename:$line:**** $cprimname: all-uppercase word \`$word\' does not match an argument\n";
 882         }
 883       }
 884     }
 885   }
 886
 887   # check to make sure all formals are referred to in the comment
 888   foreach my $formal (keys %argnames) {
 889     if ($comment !~ /\Q$formal\E/) {
 890       if (!$fReallyQuiet && $fWarnIfNoComment && !$fAlreadyWarnedAboutNoComment) {
 891         print STDERR "$filename:$line:**** $cprimname: formal $formal not mentioned in comment\n";
 892       }
 893     }
 894   }
 895
 896   my $purpose = PurposeFromComment($comment,$filename,$line,$cprimname);
 897
 898   # Clean up spacing in $comment -- use \n instead of $ since
 899   # the latter matches before the new line
 900   $comment =~ s/^\s*\n//mg;
 901   # delete whitespace-only lines in old-comment, so we don't get a warning
 902   # on them -- they're useful to avoid Emacs's reindent-paragraph
 903   # from causing the synopsis sentence to have extra words tacked onto the end
 904
 905   my $old_comment = $comment;
 906
 907   $comment =~ s/^\s+//mg;
 908   if ($comment ne $old_comment) {
 909     if (!$fQuiet) {
 910       print STDERR "$filename:$line:**** $cprimname: leading spaces (indentation) is being omitted\n";
 911     }
 912   }
 913
 914   # Clean up trailing space, but don't warn about it
 915   $comment =~ s/\s+$//mg;
 916
 917   IspellText($filename,$line,$comment) if $opt_s;
 918
 919   my $sgml_id = $cprimname;
 920   $sgml_id =~ s/_/-/g;
 921
 922   # Now want to do the markup of $comment, and set $markup_comment
 923   # FIXGJB: fold into testing, above
 924   my $markup_comment = MarkupComment($comment);
 925
 926   # Mark formals within comment with <parameter> tag
 927   # must sort by length so longer formals get replaced first
 928   # note that it is essential to convert to lowercase as we
 929   # go, otherwise shorter substitutions will be made inside
 930   # an already-substitued <param> </param> pair
 931   foreach my $formal (sort { length($b) <=> length($a) } keys %argnames) {
 932     $markup_comment =~ s%(\Q$formal\E)%<parameter>\L$1\E</parameter>%g;
 933   }
 934
 935   # Just do simple markup of the usage
 936   my $markup_usage = MarkupUsage($usage);
 937
 938   my $markup_purpose = MarkupComment($purpose);
 939
 940   my $module = "Built-in Primitive";
 941   if ($filename =~ m%^modules/([^/]*)%) {
 942     $module = "Primitive from (app scwm $1)";
 943   }
 944
 945   my $markup = CreateMarkupBody($primname, $sgml_id, $module,
 946                                 $markup_usage, $markup_purpose, $markup_comment,
 947                                 $filename, $line);
 948
 949   if ($fDebug) {
 950     print STDERR <<EOC
 951 scheme-primitive-name:  $primname
 952 C-primitive-name:       $cprimname
 953 arg kinds:              $req, $opt, $var
 954 args:                   @{[join(",",@args)]}
 955 arg listing:            $arg_listing
 956 fname define:           $fname_define
 957 EOC
 958 ;
 959   }
 960   $procedure{$primname} = { usage => $usage,
 961                             comment => $comment,
 962                             purpose => $purpose,
 963                             sgml_id => $sgml_id,
 964                             module => $module,
 965                             markup_purpose => $markup_purpose,
 966                             markup_usage => $markup_usage,
 967                             markup => $markup,
 968                             file => $filename,
 969                             line => $line,
 970                           };
 971   push @{$file_funcs{$filename}}, $primname;
 972
 973   return TRUE;
 974 }
 975
 976 # remember, no underscores in sgml ids
 977 sub ScmIdToSgmlId ( $ ) {
 978   my ($id) = @_;
 979   $id =~ s/\?$/-p/g;
 980   $id =~ s/!$/-x/g;
 981   $id =~ s/\/$/-d/g;
 982   $id =~ s/:/--/g;
 983   $id =~ s/%/pct/g;
 984   $id =~ s/[\?\!\_\$\^\&\/]/-/g;
 985   $id =~ s/->/-to-/g;
 986   return $id;
 987 }
 988
 989 sub PurposeFromComment ( $$$$ ) {
 990   my ($comment,$filename,$line,$primname) = @_;
 991
 992   my ($purpose) = $comment =~ m%(.*?[\.;\n])%;
 993
 994   if (!defined $purpose) {
 995     # did not match, so must have been a one-liner w/o a newline
 996     $purpose = $comment;
 997   }
 998   chomp ($purpose); # in case it matched the newline
 999   if (!defined($purpose) || $purpose !~ /\.\s*$/) {
1000     if (!$fQuiet && $fWarnIfNoComment && $purpose !~/^\s*$/) {
1001       print STDERR "$filename:$line:**** $primname: first line of comment should be a purpose sentence\n";
1002     }
1003   }
1004   return $purpose;
1005 }
1006
1007 # $comment is the part of the comment we've already read
1008 sub ReadRestOfComment ( $$ ) {
1009   my ($comment, $fScheme) = @_;
1010   if ($fScheme) {
1011     while (defined($_ = <>) && m%^;;;\s*(.*)$%) {
1012       $comment .= "$1\n";
1013       if (eof) {
1014         close(ARGV);
1015         # FIXGJB: this might be wrong-- resetting too early?
1016         $current_module = "";
1017       }
1018     }
1019   } else {
1020     # read rest of C comment
1021     $comment .= "\n";
1022     if ($comment !~ m%\*/%) {
1023       while (defined($_ = <>) && $_ !~ m%\*/%) {
1024         $comment .= $_;
1025         if (eof) {
1026           close(ARGV);
1027           # FIXGJB: this might be wrong-- resetting too early?
1028           $current_module = "";
1029         }
1030       }
1031       $comment .= $_;
1032     }
1033     $comment =~ s%\*/\s*$%%s;
1034   }
1035   return $comment;
1036 }
1037
1038 sub ReadRestOfDocstring ( $ ) {
1039   my ($filename,$line,$docstring) = @_;
1040   while (defined($_ = <>) && $_ !~ m%[^\\]\"\s*\)\s*;\s*$%) {
1041     $docstring .= $_;
1042     if (eof) {
1043       close(ARGV);
1044       $current_module = "";
1045     }
1046   }
1047   $docstring .= $_;
1048   $docstring =~ s%\"\s*\)\s*;\s*$%%m;
1049   if ($docstring =~ m/[^\\]\"/) {
1050     print STDERR "$filename:$line:****ERROR:docstring includes an un-escaped double-quote\n";
1051   }
1052   # Unquote quoted quotes (CRW:FIXME:GJB: are there other things we
1053   # may need to unquote here?)
1054   $docstring =~ s/\\"/"/g;
1055   return $docstring;
1056 }
1057
1058 sub ProcessConceptComment ( $$$$ ) {
1059   my ($filename,$line,$description,$comment) = @_;
1060   $comment =~ s%\*/\s*$%%m;
1061   if ($fDebug) {
1062     print STDERR "Concept \`$description\' with body = \n$comment\n";
1063   }
1064
1065   IspellText($filename,$line,$comment) if $opt_s;
1066
1067   my $markup = MarkupComment($comment);
1068
1069   $concepts{$description} = { comment => $comment,
1070                               markup => $markup,
1071                               file => $filename,
1072                               line => $line,
1073                             };
1074 }
1075
1076 sub ProcessHookComment ( $$$$$ ) {
1077   my ($filename,$line,$description,$num_args,$comment) = @_;
1078   $comment =~ s%\*/\s*$%%m;
1079   if ($fDebug) {
1080     print STDERR "Hook \`$description\' with body = \n$comment\n";
1081   }
1082
1083   IspellText($filename,$line,$comment) if $opt_s;
1084
1085   my $markup = MarkupComment($comment);
1086   $hooks{$description} = { comment => $comment,
1087                            markup => $markup,
1088                            numargs => $num_args,
1089                            module => $current_module,
1090                            file => $filename,
1091                            line => $line,
1092                          };
1093 }
1094
1095 sub ProcessVarComment ( $$$$ ) {
1096   my ($filename,$line,$description,$comment) = @_;
1097   $comment =~ s%\*/\s*$%%m;
1098   if ($fDebug) {
1099     print STDERR "Var \`$description\' with body = \n$comment\n";
1100   }
1101
1102   IspellText($filename,$line,$comment) if $opt_s;
1103
1104   my $markup = MarkupComment($comment);
1105   $vars{$description} = { comment => $comment,
1106                           markup => $markup,
1107                           module => $current_module,
1108                           file => $filename,
1109                           line => $line,
1110                         };
1111 }
1112
1113
1114
1115 sub CreateMarkupBody ( $$$$$$$ ) {
1116   my ($primname, $sgml_id, $module, $markup_usage, $markup_purpose, $markup_comment,
1117       $filename, $line) = @_;
1118   # Use <refentry>, <refname>, <refpurpose>, <synopsis>
1119
1120   # Filename url links rely on environment variable SCWMDIR being
1121   # set to the base of the scwm distribution
1122   # i.e. $SCWMDIR/scwm/scwm.c should contain main()
1123   my $cvs_url_link = "$scwmdir/$filename";
1124   $cvs_url_link =~ s%/~checkout~%%;
1125   my $markup =
1126 "<refentry id=\"$sgml_id\">
1127   <refnamediv>
1128     <refname>$primname</refname>
1129     <refpurpose>$markup_purpose</refpurpose>
1130   </refnamediv>
1131   <refsynopsisdiv>
1132     <synopsis>$markup_usage</synopsis>
1133   </refsynopsisdiv>
1134   <refsect1>
1135   <title>Description</title>
1136   <para>
1137   $markup_comment
1138   </para>
1139   <refsect2>
1140   <title>Implementation Notes</title>
1141   <para> Module: $module</para>
1142   <para> Defined in <ulink url=\"$scwmdir/$filename\"><filename>$filename</filename></ulink>
1143   at line $line (<ulink url=\"$cvs_url_link\">CVS log</ulink>)</para> </refsect2>
1144   </refsect1>
1145 </refentry>
1146 ";
1147   return $markup;
1148 }
1149
1150
1151
1152 sub MarkupUsage( $ ) {
1153   my ($markup_usage) = @_;
1154   $markup_usage =~ s%&(optional|key|allow-other-keys|rest)%&amp;$1%g;
1155   $markup_usage =~ s%(\s+)&(\s+)%$1&amp;$2%g;
1156   $markup_usage =~ s%(\s+)<(\s+)%$1&lt;$2%g;
1157   $markup_usage =~ s%(\s+)>(\s+)%$1&gt;$2%g;
1158   return $markup_usage;
1159 }
1160
1161
1162 # FIXGJB
1163 sub MarkupComment( $ ) {
1164   my ($body) = @_;
1165
1166   # convert & into &amp; space-delimited <, > into &lt; and &gt;
1167   $body =~ s%&%&amp;%g;
1168   $body =~ s%(\s+)<(\s+)%$1&lt;$2%g;
1169   $body =~ s%(\s+)>(\s+)%$1&gt;$2%g;
1170
1171   # Mark #t and #f within comment with <literal> tag
1172   $body =~ s%(\#[tf])%<literal>$1</literal>%g;
1173
1174   # Replace `procedure' with <function>procedure</function>
1175   $body =~ s%\`([-A-Za-z0-9_?!+\%&\$]+?)\'%
1176     "<link linkend=\"" . ScmIdToSgmlId($1) . "\"><function>$1</function></link>"%eg;
1177
1178   return $body;
1179 }
1180
1181 sub IspellText( $$$ ) {
1182   my ($filename,$line,$text,$response) = @_;
1183   foreach my $word (split /[\d\W]+/, $text) {
1184     # ispell is picky about lots of stuff, so ignore them
1185     next if $word =~ /^[-\#]/;
1186     next if $word !~ /^\w\w+/;
1187     next if $word eq uc($word);
1188     print STDERR "ispell trying $word -> " if $fDebug;
1189     my $junk = <ISPELL_RESPONSE>; # read the blank
1190     print ISPELL $word, "\n";
1191     chomp (my $response = <ISPELL_RESPONSE>);
1192     print STDERR "response = \`$response\'\n" if $fDebug;
1193     if ($response eq "") {
1194       print STDERR "$filename:$line:**** ISPELL is out of sync (last word \`$word\') -- aborting its use!\n";
1195       $opt_s = FALSE;
1196       last;
1197     }
1198     if ($response !~ m/^[+\*]/) {
1199       print STDERR "$filename:$line:**** ispell reported possible misspelling: $word -> $response\n";
1200       print STDERR "Should I add `$word' to my list of known correct words? ";
1201       $response=<STDIN>;
1202       if ($response=~/^y(es)?$/i) {
1203         print ISPELL "*",lc($word),"\n";
1204       }
1205     }
1206   }
1207 }
1208
1209 sub CNameMatchesSchemeNameIgnoreCase( $$ ) {
1210   my ($a, $b) = @_;
1211   $a =~ s/($a)/\L$1/;
1212   $b =~ s/($b)/\L$1/;
1213   CNameMatchesSchemeName($a,$b);
1214 }
1215
1216 sub CNameMatchesSchemeName( $$ ) {
1217   my ($cprimname, $primname) = @_;
1218
1219   # now convert the c function name into the expected (preferred) primitive name:
1220   my $expected_primname = $cprimname;
1221   $expected_primname =~ s/_[pP]\b/?/g;
1222   $expected_primname =~ s/_[xX]\b/!/g;
1223   $expected_primname =~ s/\bpct_/%/g;
1224   $expected_primname =~ s/_/-/g;
1225   # alternative possibility (ignoring chance of multiple to's in string)
1226   my $expected_primname2 = $expected_primname;
1227   $expected_primname2 =~ s/-to-/->/g;
1228
1229   return ($primname eq $expected_primname || $primname eq $expected_primname2);
1230 }
1231
1232 sub ReadSgml( $ ) {
1233   my ($filename) = @_;
1234
1235   open(IN,"<$filename") || die "Could not open $filename: $!";
1236   undef $/;
1237   my $answer = <IN>;
1238   close IN;
1239   return $answer;
1240 }
1241
1242 sub ProcessWindowStyleOption( $$ ) {
1243   my ($file,$line,$kind,$option) = (@_);
1244   if ($fDebug) {
1245     print STDERR "Got window style option for $kind named $option\n";
1246   }
1247
1248   my $winstyle = "Window Style"; # from face.c's embedded CONCEPT comment
1249
1250   my $comment = $concepts{$winstyle}{comment};
1251   my $markup = $concepts{$winstyle}{markup};
1252
1253   if (!$fAddedStyleHeader) {
1254 $markup .= '
1255 <table>
1256 <title>window style options</title>
1257 <tgroup align="char" cols="3">
1258 <thead><row>
1259  <entry>Option</entry>  <entry>Type</entry>  <entry>Implementation</entry>
1260 </row></thead>
1261 <tbody>
1262 ';
1263     $fAddedStyleHeader = TRUE;
1264   }
1265
1266   $comment .= "$option ($kind) from $file:$line\n";
1267   $markup .=
1268     "<row>" .
1269       "<entry/" . MarkupComment($option) . "/ " .
1270         "<entry/" . MarkupComment($kind) . "/ " .
1271           "<entry>$file:$line</entry> " .
1272           " </row>\n";
1273
1274   $concepts{$winstyle}{comment} = $comment;
1275   $concepts{$winstyle}{markup} = $markup;
1276 }
1277
1278 sub DoneWindowStyleOptions() {
1279   my $winstyle = "Window Style"; # from face.c's embedded CONCEPT comment
1280
1281   $concepts{$winstyle}{markup} .= "</tbody></tgroup></table>\n";
1282 }
1283
1284 sub check_arg_name_number_match ( $$\@ ) {
1285   my $validate_fn = shift;
1286   my $argnum = shift;
1287   my $argname = shift;
1288   my $aref_argnames = shift;
1289
1290   if ($fDebug) {
1291     print STDERR "Checking ", $argname, " (arg ", $argnum, ") against list: ", join(" ",@$aref_argnames), "\n"
1292   }
1293   if ($argnum > scalar(@$aref_argnames) ||
1294       $argnames[$argnum-1] ne $argname) {
1295     print STDERR "$ARGV:$.:**** Argument name/number mismatch in $validate_fn line\n";
1296   }
1297 }
1298