From: Larry Wall Date: Wed, 8 Aug 1990 17:01:53 +0000 (+0000) Subject: perl 3.0 patch #22 patch #19, continued X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=154e51a4a1b0258759b5e901183403af515a35b9;p=p5sagit%2Fp5-mst-13.2.git perl 3.0 patch #22 patch #19, continued See patch #19. --- diff --git a/eval.c b/eval.c index 9978779..42436e4 100644 --- a/eval.c +++ b/eval.c @@ -1,4 +1,4 @@ -/* $Header: eval.c,v 3.0.1.6 90/03/27 15:53:51 lwall Locked $ +/* $Header: eval.c,v 3.0.1.7 90/08/09 03:33:44 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,16 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: eval.c,v $ + * Revision 3.0.1.7 90/08/09 03:33:44 lwall + * patch19: made ~ do vector operation on strings like &, | and ^ + * patch19: dbmopen(%name...) didn't work right + * patch19: dbmopen(name, 'filename', undef) now refrains from creating + * patch19: empty %array now returns 0 in scalar context + * patch19: die with no arguments no longer exits unconditionally + * patch19: return outside a subroutine now returns a reasonable message + * patch19: rename done with unlink()/link()/unlink() now checks for clobbering + * patch19: -s now returns size of file + * * Revision 3.0.1.6 90/03/27 15:53:51 lwall * patch16: MSDOS support * patch16: support for machines that can't cast negative floats to unsigned ints @@ -50,7 +60,9 @@ #include "EXTERN.h" #include "perl.h" +#ifndef NSIG #include +#endif #ifdef I_FCNTL #include @@ -282,7 +294,7 @@ register int sp; if (when >= 0) value = (double)(when % tmplong); else - value = (double)(tmplong - (-when % tmplong)); + value = (double)(tmplong - ((-when - 1) % tmplong)) - 1; #endif goto donumset; case O_ADD: @@ -440,10 +452,19 @@ register int sp; value = (double) !str_true(st[1]); goto donumset; case O_COMPLEMENT: + if (!sawvec || st[1]->str_nok) { #ifndef lint - value = (double) ~U_L(str_gnum(st[1])); + value = (double) ~U_L(str_gnum(st[1])); #endif - goto donumset; + goto donumset; + } + else { + STR_SSET(str,st[1]); + tmps = str_get(str); + for (anum = str->str_cur; anum; anum--) + *tmps = ~*tmps; + } + break; case O_SELECT: tmps = stab_name(defoutstab); if (maxarg > 0) { @@ -503,11 +524,11 @@ register int sp; break; case O_DBMOPEN: #ifdef SOME_DBM - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; + stab = arg[1].arg_ptr.arg_stab; + if (st[3]->str_nok || st[3]->str_pok) + anum = (int)str_gnum(st[3]); else - stab = stabent(str_get(st[1]),TRUE); - anum = (int)str_gnum(st[3]); + anum = -1; value = (double)hdbmopen(stab_hash(stab),str_get(st[2]),anum); goto donumset; #else @@ -515,10 +536,7 @@ register int sp; #endif case O_DBMCLOSE: #ifdef SOME_DBM - if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); + stab = arg[1].arg_ptr.arg_stab; hdbmclose(stab_hash(stab)); goto say_yes; #else @@ -539,7 +557,7 @@ register int sp; goto say_zero; else goto say_undef; - break; + /* break; */ case O_TRANS: value = (double) do_trans(str,arg); str = arg->arg_ptr.arg_str; @@ -582,7 +600,8 @@ register int sp; astore(stack,sp + maxarg, Nullstr); st = stack->ary_array; } - Copy(ary->ary_array, &st[sp+1], maxarg, STR*); + st += sp; + Copy(ary->ary_array, &st[1], maxarg, STR*); sp += maxarg; goto array_return; } @@ -618,6 +637,8 @@ register int sp; } else { tmpstab = arg[1].arg_ptr.arg_stab; + if (!stab_hash(tmpstab)->tbl_fill) + goto say_zero; sprintf(buf,"%d/%d",stab_hash(tmpstab)->tbl_fill, stab_hash(tmpstab)->tbl_max+1); str_set(str,buf); @@ -677,7 +698,7 @@ register int sp; gimme,arglast); goto array_return; case O_SPLICE: - sp = do_splice(stab_array(arg[1].arg_ptr.arg_stab),str,gimme,arglast); + sp = do_splice(stab_array(arg[1].arg_ptr.arg_stab),gimme,arglast); goto array_return; case O_PUSH: if (arglast[2] - arglast[1] != 1) @@ -821,7 +842,7 @@ register int sp; tmps = str_get(st[2]); } if (!tmps || !*tmps) - exit(1); + tmps = "Died"; fatal("%s",tmps); goto say_zero; case O_PRTF: @@ -1064,8 +1085,11 @@ register int sp; } #endif } - if (loop_ptr < 0) + if (loop_ptr < 0) { + if (tmps && strEQ(tmps, "_SUB_")) + fatal("Can't return outside a subroutine"); fatal("Bad label: %s", maxarg > 0 ? tmps : ""); + } if (!lastretstr && optype == O_LAST && lastsize) { st -= arglast[0]; st += lastspbase + 1; @@ -1136,6 +1160,10 @@ register int sp; sp = do_time(str,gmtime(&when), gimme,arglast); goto array_return; + case O_TRUNCATE: + sp = do_truncate(str,arg, + gimme,arglast); + goto array_return; case O_LSTAT: case O_STAT: sp = do_stat(str,arg, @@ -1317,7 +1345,7 @@ register int sp; argtype = arg[2].arg_type & A_MASK; argptr = arg[2].arg_ptr; sp = arglast[0]; - st -= sp; + st -= sp++; goto re_eval; } str_set(str,""); @@ -1392,6 +1420,7 @@ register int sp; else { value = (double)((unsigned int)argflags & 0xffff); } + do_execfree(); /* free any memory child malloced on vfork */ goto donumset; } if ((arg[1].arg_type & A_MASK) == A_STAB) @@ -1510,11 +1539,15 @@ register int sp; #ifdef RENAME value = (double)(rename(tmps,tmps2) >= 0); #else - if (euid || stat(tmps2,&statbuf) < 0 || - (statbuf.st_mode & S_IFMT) != S_IFDIR ) - (void)UNLINK(tmps2); /* avoid unlinking a directory */ - if (!(anum = link(tmps,tmps2))) - anum = UNLINK(tmps); + if (same_dirent(tmps2, tmps) /* can always rename to same name */ + anum = 1; + else { + if (euid || stat(tmps2,&statbuf) < 0 || + (statbuf.st_mode & S_IFMT) != S_IFDIR ) + (void)UNLINK(tmps2); + if (!(anum = link(tmps,tmps2))) + anum = UNLINK(tmps); + } value = (double)(anum >= 0); #endif goto donumset; @@ -1738,6 +1771,8 @@ register int sp; } value = (double)(ary->ary_fill + 1); break; + + case O_REQUIRE: case O_DOFILE: case O_EVAL: if (maxarg < 1) @@ -1803,9 +1838,8 @@ register int sp; case O_FTSIZE: if (mystat(arg,st[1]) < 0) goto say_undef; - if (statcache.st_size) - goto say_yes; - goto say_no; + value = (double)statcache.st_size; + goto donumset; case O_FTSOCK: #ifdef S_IFSOCK @@ -2037,10 +2071,7 @@ register int sp; case O_ESERVENT: value = (double) endservent(); goto donumset; - case O_SSELECT: - sp = do_select(gimme,arglast); - goto array_return; - case O_SOCKETPAIR: + case O_SOCKPAIR: if ((arg[1].arg_type & A_MASK) == A_WORD) stab = arg[1].arg_ptr.arg_stab; else @@ -2089,8 +2120,7 @@ register int sp; case O_CONNECT: case O_LISTEN: case O_ACCEPT: - case O_SSELECT: - case O_SOCKETPAIR: + case O_SOCKPAIR: case O_GHBYNAME: case O_GHBYADDR: case O_GHOSTENT: @@ -2119,6 +2149,13 @@ register int sp; badsock: fatal("Unsupported socket function"); #endif /* SOCKET */ + case O_SSELECT: +#ifdef SELECT + sp = do_select(gimme,arglast); + goto array_return; +#else + fatal("select not implemented"); +#endif case O_FILENO: if (maxarg < 1) goto say_undef; @@ -2256,8 +2293,9 @@ array_return: deb("%s RETURNS (\"%s\")\n",opname[optype],str_get(st[1])); break; default: - deb("%s RETURNS %d ARGS (\"%s\",%s\"%s\"\n",opname[optype],anum, - str_get(st[1]),anum==2?"":"...,",str_get(st[anum])); + tmps = str_get(st[1]); + deb("%s RETURNS %d ARGS (\"%s\",%s\"%s\")\n",opname[optype], + anum,tmps,anum==2?"":"...,",str_get(st[anum])); break; } } diff --git a/evalargs.xc b/evalargs.xc index 711d9a9..5d4458d 100644 --- a/evalargs.xc +++ b/evalargs.xc @@ -2,9 +2,14 @@ * kit sizes from getting too big. */ -/* $Header: evalargs.xc,v 3.0.1.5 90/03/27 15:54:42 lwall Locked $ +/* $Header: evalargs.xc,v 3.0.1.6 90/08/09 03:37:15 lwall Locked $ * * $Log: evalargs.xc,v $ + * Revision 3.0.1.6 90/08/09 03:37:15 lwall + * patch19: passing *name to subroutine now forces filehandle and array creation + * patch19: `command` in array context now returns array of lines + * patch19: input is a little more efficient + * * Revision 3.0.1.5 90/03/27 15:54:42 lwall * patch16: MSDOS support * @@ -98,7 +103,14 @@ #endif break; case A_STAR: - st[++sp] = (STR*)argptr.arg_stab; + stab = argptr.arg_stab; + st[++sp] = (STR*)stab; + if (!stab_xarray(stab)) + aadd(stab); + if (!stab_xhash(stab)) + hadd(stab); + if (!stab_io(stab)) + stab_io(stab) = stio_new(); #ifdef DEBUGGING if (debug & 8) { (void)sprintf(buf,"STAR *%s",stab_name(argptr.arg_stab)); @@ -221,14 +233,30 @@ fp = mypopen(tmps,"r"); str_set(str,""); if (fp) { - while (str_gets(str,fp,str->str_cur) != Nullch) - ; + if (gimme == G_SCALAR) { + while (str_gets(str,fp,str->str_cur) != Nullch) + ; + } + else { + for (;;) { + if (++sp > stack->ary_max) { + astore(stack, sp, Nullstr); + st = stack->ary_array; + } + st[sp] = str_static(&str_undef); + if (str_gets(st[sp],fp,0) == Nullch) { + sp--; + break; + } + } + } statusvalue = mypclose(fp); } else statusvalue = -1; - st[++sp] = str; + if (gimme == G_SCALAR) + st[++sp] = str; #ifdef DEBUGGING tmps = "BACK"; #endif @@ -268,6 +296,8 @@ do_read: if (anum > 1) /* assign to scalar */ gimme = G_SCALAR; /* force context to scalar */ + if (gimme == G_ARRAY) + str = str_static(&str_undef); ++sp; fp = Nullfp; if (stab_io(last_in_stab)) { @@ -362,11 +392,11 @@ goto keepgoing; /* unmatched wildcard? */ } if (gimme == G_ARRAY) { - st[sp] = str_static(st[sp]); if (++sp > stack->ary_max) { astore(stack, sp, Nullstr); st = stack->ary_array; } + str = str_static(&str_undef); goto keepgoing; } } diff --git a/form.c b/form.c index ba82433..c4b248a 100644 --- a/form.c +++ b/form.c @@ -1,4 +1,4 @@ -/* $Header: form.c,v 3.0.1.1 90/02/28 17:39:34 lwall Locked $ +/* $Header: form.c,v 3.0.1.2 90/08/09 03:38:40 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,9 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: form.c,v $ + * Revision 3.0.1.2 90/08/09 03:38:40 lwall + * patch19: did preliminary work toward debugging packages and evals + * * Revision 3.0.1.1 90/02/28 17:39:34 lwall * patch9: ... in format threw off subsequent field * @@ -28,11 +31,11 @@ register FCMD *fcmd; register int items; STR *str; ARG *parselist(); - line_t oldline = line; + line_t oldline = curcmd->c_line; int oldsave = savestack->ary_fill; str = fcmd->f_unparsed; - line = fcmd->f_line; + curcmd->c_line = fcmd->f_line; fcmd->f_unparsed = Nullstr; (void)savehptr(&curstash); curstash = str->str_u.str_hash; @@ -58,7 +61,7 @@ register FCMD *fcmd; } if (fcmd && fcmd->f_type) fatal("Not enough field values"); - line = oldline; + curcmd->c_line = oldline; Safefree(arg); str_free(str); } @@ -280,6 +283,7 @@ int sp; break; } } + CHKLEN(1); *d++ = '\0'; } diff --git a/h2ph.SH b/h2ph.SH new file mode 100644 index 0000000..cac5ada --- /dev/null +++ b/h2ph.SH @@ -0,0 +1,247 @@ +case $CONFIG in +'') + if test ! -f config.sh; then + ln ../config.sh . || \ + ln ../../config.sh . || \ + ln ../../../config.sh . || \ + (echo "Can't find config.sh."; exit 1) + fi + . config.sh + ;; +esac +: This forces SH files to create target in same directory as SH file. +: This is so that make depend always knows where to find SH derivatives. +case "$0" in +*/*) cd `expr X$0 : 'X\(.*\)/'` ;; +esac +echo "Extracting h2ph (with variable substitutions)" +: This section of the file will have variable substitutions done on it. +: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. +: Protect any dollar signs and backticks that you do not want interpreted +: by putting a backslash in front. You may delete these comments. +$spitshell >h2ph <>h2ph <<'!NO!SUBS!' + +chdir '/usr/include' || die "Can't cd /usr/include"; + +%isatype = ('char',1,'short',1,'int',1,'long',1); + +foreach $file (@ARGV) { + ($outfile = $file) =~ s/\.h$/.ph/; + print "$file -> $outfile\n"; + if ($file =~ m|^(.*)/|) { + $dir = $1; + if (!-d "$perlincl/$dir") { + mkdir("$perlincl/$dir",0777); + } + } + open(IN,"$file") || ((warn "Can't open $file: $!\n"),next); + open(OUT,">$perlincl/$outfile") || die "Can't create $outfile: $!\n"; + while () { + chop; + while (/\\$/) { + chop; + $_ .= ; + chop; + } + if (s:/\*:\200:g) { + s:\*/:\201:g; + s/\200[^\201]*\201//g; # delete single line comments + if (s/\200.*//) { # begin multi-line comment? + $_ .= '/*'; + $_ .= ; + redo; + } + } + if (s/^#\s*//) { + if (s/^define\s+(\w+)//) { + $name = $1; + $new = ''; + s/\s+$//; + if (s/^\(([\w,\s]*)\)//) { + $args = $1; + if ($args ne '') { + foreach $arg (split(/,\s*/,$args)) { + $curargs{$arg} = 1; + } + $args =~ s/\b(\w)/\$$1/g; + $args = "local($args) = \@_;\n$t "; + } + s/^\s+//; + do expr(); + $new =~ s/(["\\])/\\$1/g; + if ($t ne '') { + $new =~ s/(['\\])/\\$1/g; + print OUT $t, + "eval 'sub $name {\n$t ${args}eval \"$new\";\n$t}';\n"; + } + else { + print OUT "sub $name {\n ${args}eval \"$new\";\n}\n"; + } + %curargs = (); + } + else { + s/^\s+//; + do expr(); + $new = 1 if $new eq ''; + if ($t ne '') { + $new =~ s/(['\\])/\\$1/g; + print OUT $t,"eval 'sub $name {",$new,";}';\n"; + } + else { + print OUT $t,"sub $name {",$new,";}\n"; + } + } + } + elsif (/^include <(.*)>/) { + print OUT $t,"do '$1' || die \"Can't include $1: \$!\";\n"; + } + elsif (/^ifdef\s+(\w+)/) { + print OUT $t,"if (defined &$1) {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } + elsif (/^ifndef\s+(\w+)/) { + print OUT $t,"if (!defined &$1) {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } + elsif (s/^if\s+//) { + $new = ''; + do expr(); + print OUT $t,"if ($new) {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } + elsif (s/^elif\s+//) { + $new = ''; + do expr(); + $tab -= 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + print OUT $t,"}\n${t}elsif ($new) {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } + elsif (/^else/) { + $tab -= 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + print OUT $t,"}\n${t}else {\n"; + $tab += 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + } + elsif (/^endif/) { + $tab -= 4; + $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); + print OUT $t,"}\n"; + } + } + } + print OUT "1;\n"; +} + +sub expr { + while ($_ ne '') { + s/^(\s+)// && do {$new .= ' '; next;}; + s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;}; + s/^(\d+)// && do {$new .= $1; next;}; + s/^("(\\"|[^"])*")// && do {$new .= $1; next;}; + s/^'((\\"|[^"])*)'// && do { + if ($curargs{$1}) { + $new .= "ord('\$$1')"; + } + else { + $new .= "ord('$1')"; + } + next; + }; + s/^(struct\s+\w+)// && do {$new .= "'$1'"; next;}; + s/^sizeof\s*\(([^)]+)\)/{$1}/ && do { + $new .= '$sizeof'; + next; + }; + s/^([_a-zA-Z]\w*)// && do { + $id = $1; + if ($curargs{$id}) { + $new .= '$' . $id; + } + elsif ($id eq 'defined') { + $new .= 'defined'; + } + elsif (/^\(/) { + s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/; # cheat + $new .= " &$id"; + } + elsif ($isatype{$id}) { + $new .= "'$id'"; + } + else { + $new .= ' &' . $id; + } + next; + }; + s/^(.)// && do {$new .= $1; next;}; + } +} +############################################################################## + + # These next few lines are legal in both Perl and nroff. + +.00; # finish .ig + +'di \" finish diversion--previous line must be blank +.nr nl 0-1 \" fake up transition to first page again +.nr % 0 \" start at page 1 +'; __END__ ############# From here on it's a standard manual page ############ +.TH H2PH 1 "August 8, 1990" +.AT 3 +.SH NAME +h2ph \- convert .h C header files to .ph Perl header files +.SH SYNOPSIS +.B h2ph [headerfiles] +.SH DESCRIPTION +.I h2ph +converts any C header files specified to the corresponding Perl header file +format. +It is most easily run while in /usr/include: +.nf + + cd /usr/include; h2ph * sys/* + +.fi +.SH ENVIRONMENT +No environment variables are used. +.SH FILES +/usr/include/*.h +.br +/usr/include/sys/*.h +.br +etc. +.SH AUTHOR +Larry Wall +.SH "SEE ALSO" +perl(1) +.SH DIAGNOSTICS +The usual warnings if it can't read or write the files involved. +.SH BUGS +Doesn't construct the %sizeof array for you. +.PP +It doesn't handle all C constructs, but it does attempt to isolate +definitions inside evals so that you can get at the definitions +that it can translate. +.PP +It's only intended as a rough tool. +You may need to dicker with the files produced. +.ex +!NO!SUBS! +chmod 755 h2ph +$eunicefix h2ph +rm -f h2ph.man +ln h2ph h2ph.man diff --git a/h2pl/eg/sys/errno.pl b/h2pl/eg/sys/errno.pl new file mode 100644 index 0000000..d9ba3be --- /dev/null +++ b/h2pl/eg/sys/errno.pl @@ -0,0 +1,92 @@ +$EPERM = 0x1; +$ENOENT = 0x2; +$ESRCH = 0x3; +$EINTR = 0x4; +$EIO = 0x5; +$ENXIO = 0x6; +$E2BIG = 0x7; +$ENOEXEC = 0x8; +$EBADF = 0x9; +$ECHILD = 0xA; +$EAGAIN = 0xB; +$ENOMEM = 0xC; +$EACCES = 0xD; +$EFAULT = 0xE; +$ENOTBLK = 0xF; +$EBUSY = 0x10; +$EEXIST = 0x11; +$EXDEV = 0x12; +$ENODEV = 0x13; +$ENOTDIR = 0x14; +$EISDIR = 0x15; +$EINVAL = 0x16; +$ENFILE = 0x17; +$EMFILE = 0x18; +$ENOTTY = 0x19; +$ETXTBSY = 0x1A; +$EFBIG = 0x1B; +$ENOSPC = 0x1C; +$ESPIPE = 0x1D; +$EROFS = 0x1E; +$EMLINK = 0x1F; +$EPIPE = 0x20; +$EDOM = 0x21; +$ERANGE = 0x22; +$EWOULDBLOCK = 0x23; +$EINPROGRESS = 0x24; +$EALREADY = 0x25; +$ENOTSOCK = 0x26; +$EDESTADDRREQ = 0x27; +$EMSGSIZE = 0x28; +$EPROTOTYPE = 0x29; +$ENOPROTOOPT = 0x2A; +$EPROTONOSUPPORT = 0x2B; +$ESOCKTNOSUPPORT = 0x2C; +$EOPNOTSUPP = 0x2D; +$EPFNOSUPPORT = 0x2E; +$EAFNOSUPPORT = 0x2F; +$EADDRINUSE = 0x30; +$EADDRNOTAVAIL = 0x31; +$ENETDOWN = 0x32; +$ENETUNREACH = 0x33; +$ENETRESET = 0x34; +$ECONNABORTED = 0x35; +$ECONNRESET = 0x36; +$ENOBUFS = 0x37; +$EISCONN = 0x38; +$ENOTCONN = 0x39; +$ESHUTDOWN = 0x3A; +$ETOOMANYREFS = 0x3B; +$ETIMEDOUT = 0x3C; +$ECONNREFUSED = 0x3D; +$ELOOP = 0x3E; +$ENAMETOOLONG = 0x3F; +$EHOSTDOWN = 0x40; +$EHOSTUNREACH = 0x41; +$ENOTEMPTY = 0x42; +$EPROCLIM = 0x43; +$EUSERS = 0x44; +$EDQUOT = 0x45; +$ESTALE = 0x46; +$EREMOTE = 0x47; +$EDEADLK = 0x48; +$ENOLCK = 0x49; +$MTH_UNDEF_SQRT = 0x12C; +$MTH_OVF_EXP = 0x12D; +$MTH_UNDEF_LOG = 0x12E; +$MTH_NEG_BASE = 0x12F; +$MTH_ZERO_BASE = 0x130; +$MTH_OVF_POW = 0x131; +$MTH_LRG_SIN = 0x132; +$MTH_LRG_COS = 0x133; +$MTH_LRG_TAN = 0x134; +$MTH_LRG_COT = 0x135; +$MTH_OVF_TAN = 0x136; +$MTH_OVF_COT = 0x137; +$MTH_UNDEF_ASIN = 0x138; +$MTH_UNDEF_ACOS = 0x139; +$MTH_UNDEF_ATAN2 = 0x13A; +$MTH_OVF_SINH = 0x13B; +$MTH_OVF_COSH = 0x13C; +$MTH_UNDEF_ZLOG = 0x13D; +$MTH_UNDEF_ZDIV = 0x13E; diff --git a/h2pl/eg/sys/ioctl.pl b/h2pl/eg/sys/ioctl.pl new file mode 100644 index 0000000..0b552ca --- /dev/null +++ b/h2pl/eg/sys/ioctl.pl @@ -0,0 +1,186 @@ +$_IOCTL_ = 0x1; +$TIOCGSIZE = 0x40087468; +$TIOCSSIZE = 0x80087467; +$IOCPARM_MASK = 0x7F; +$IOC_VOID = 0x20000000; +$IOC_OUT = 0x40000000; +$IOC_IN = 0x80000000; +$IOC_INOUT = 0xC0000000; +$TIOCGETD = 0x40047400; +$TIOCSETD = 0x80047401; +$TIOCHPCL = 0x20007402; +$TIOCMODG = 0x40047403; +$TIOCMODS = 0x80047404; +$TIOCM_LE = 0x1; +$TIOCM_DTR = 0x2; +$TIOCM_RTS = 0x4; +$TIOCM_ST = 0x8; +$TIOCM_SR = 0x10; +$TIOCM_CTS = 0x20; +$TIOCM_CAR = 0x40; +$TIOCM_CD = 0x40; +$TIOCM_RNG = 0x80; +$TIOCM_RI = 0x80; +$TIOCM_DSR = 0x100; +$TIOCGETP = 0x40067408; +$TIOCSETP = 0x80067409; +$TIOCSETN = 0x8006740A; +$TIOCEXCL = 0x2000740D; +$TIOCNXCL = 0x2000740E; +$TIOCFLUSH = 0x80047410; +$TIOCSETC = 0x80067411; +$TIOCGETC = 0x40067412; +$TIOCSET = 0x80047413; +$TIOCBIS = 0x80047414; +$TIOCBIC = 0x80047415; +$TIOCGET = 0x40047416; +$TANDEM = 0x1; +$CBREAK = 0x2; +$LCASE = 0x4; +$ECHO = 0x8; +$CRMOD = 0x10; +$RAW = 0x20; +$ODDP = 0x40; +$EVENP = 0x80; +$ANYP = 0xC0; +$NLDELAY = 0x300; +$NL0 = 0x0; +$NL1 = 0x100; +$NL2 = 0x200; +$NL3 = 0x300; +$TBDELAY = 0xC00; +$TAB0 = 0x0; +$TAB1 = 0x400; +$TAB2 = 0x800; +$XTABS = 0xC00; +$CRDELAY = 0x3000; +$CR0 = 0x0; +$CR1 = 0x1000; +$CR2 = 0x2000; +$CR3 = 0x3000; +$VTDELAY = 0x4000; +$FF0 = 0x0; +$FF1 = 0x4000; +$BSDELAY = 0x8000; +$BS0 = 0x0; +$BS1 = 0x8000; +$ALLDELAY = 0xFF00; +$CRTBS = 0x10000; +$PRTERA = 0x20000; +$CRTERA = 0x40000; +$TILDE = 0x80000; +$MDMBUF = 0x100000; +$LITOUT = 0x200000; +$TOSTOP = 0x400000; +$FLUSHO = 0x800000; +$NOHANG = 0x1000000; +$L001000 = 0x2000000; +$CRTKIL = 0x4000000; +$L004000 = 0x8000000; +$CTLECH = 0x10000000; +$PENDIN = 0x20000000; +$DECCTQ = 0x40000000; +$NOFLSH = 0x80000000; +$TIOCCSET = 0x800E7417; +$TIOCCGET = 0x400E7418; +$TIOCLBIS = 0x8004747F; +$TIOCLBIC = 0x8004747E; +$TIOCLSET = 0x8004747D; +$TIOCLGET = 0x4004747C; +$LCRTBS = 0x1; +$LPRTERA = 0x2; +$LCRTERA = 0x4; +$LTILDE = 0x8; +$LMDMBUF = 0x10; +$LLITOUT = 0x20; +$LTOSTOP = 0x40; +$LFLUSHO = 0x80; +$LNOHANG = 0x100; +$LCRTKIL = 0x400; +$LCTLECH = 0x1000; +$LPENDIN = 0x2000; +$LDECCTQ = 0x4000; +$LNOFLSH = 0x8000; +$TIOCSBRK = 0x2000747B; +$TIOCCBRK = 0x2000747A; +$TIOCSDTR = 0x20007479; +$TIOCCDTR = 0x20007478; +$TIOCGPGRP = 0x40047477; +$TIOCSPGRP = 0x80047476; +$TIOCSLTC = 0x80067475; +$TIOCGLTC = 0x40067474; +$TIOCOUTQ = 0x40047473; +$TIOCSTI = 0x80017472; +$TIOCNOTTY = 0x20007471; +$TIOCPKT = 0x80047470; +$TIOCPKT_DATA = 0x0; +$TIOCPKT_FLUSHREAD = 0x1; +$TIOCPKT_FLUSHWRITE = 0x2; +$TIOCPKT_STOP = 0x4; +$TIOCPKT_START = 0x8; +$TIOCPKT_NOSTOP = 0x10; +$TIOCPKT_DOSTOP = 0x20; +$TIOCSTOP = 0x2000746F; +$TIOCSTART = 0x2000746E; +$TIOCREMOTE = 0x20007469; +$TIOCGWINSZ = 0x40087468; +$TIOCSWINSZ = 0x80087467; +$TIOCRESET = 0x20007466; +$OTTYDISC = 0x0; +$NETLDISC = 0x1; +$NTTYDISC = 0x2; +$FIOCLEX = 0x20006601; +$FIONCLEX = 0x20006602; +$FIONREAD = 0x4004667F; +$FIONBIO = 0x8004667E; +$FIOASYNC = 0x8004667D; +$FIOSETOWN = 0x8004667C; +$FIOGETOWN = 0x4004667B; +$STPUTTABLE = 0x8004667A; +$STGETTABLE = 0x80046679; +$SIOCSHIWAT = 0x80047300; +$SIOCGHIWAT = 0x40047301; +$SIOCSLOWAT = 0x80047302; +$SIOCGLOWAT = 0x40047303; +$SIOCATMARK = 0x40047307; +$SIOCSPGRP = 0x80047308; +$SIOCGPGRP = 0x40047309; +$SIOCADDRT = 0x8034720A; +$SIOCDELRT = 0x8034720B; +$SIOCSIFADDR = 0x8020690C; +$SIOCGIFADDR = 0xC020690D; +$SIOCSIFDSTADDR = 0x8020690E; +$SIOCGIFDSTADDR = 0xC020690F; +$SIOCSIFFLAGS = 0x80206910; +$SIOCGIFFLAGS = 0xC0206911; +$SIOCGIFBRDADDR = 0xC0206912; +$SIOCSIFBRDADDR = 0x80206913; +$SIOCGIFCONF = 0xC0086914; +$SIOCGIFNETMASK = 0xC0206915; +$SIOCSIFNETMASK = 0x80206916; +$SIOCGIFMETRIC = 0xC0206917; +$SIOCSIFMETRIC = 0x80206918; +$SIOCSARP = 0x8024691E; +$SIOCGARP = 0xC024691F; +$SIOCDARP = 0x80246920; +$PIXCONTINUE = 0x80747000; +$PIXSTEP = 0x80747001; +$PIXTERMINATE = 0x20007002; +$PIGETFLAGS = 0x40747003; +$PIXINHERIT = 0x80747004; +$PIXDETACH = 0x20007005; +$PIXGETSUBCODE = 0xC0747006; +$PIXRDREGS = 0xC0747007; +$PIXWRREGS = 0xC0747008; +$PIXRDVREGS = 0xC0747009; +$PIXWRVREGS = 0xC074700A; +$PIXRDVSTATE = 0xC074700B; +$PIXWRVSTATE = 0xC074700C; +$PIXRDCREGS = 0xC074700D; +$PIXWRCREGS = 0xC074700E; +$PIRDSDRS = 0xC074700F; +$PIXGETSIGACTION = 0xC0747010; +$PIGETU = 0xC0747011; +$PISETRWTID = 0xC0747012; +$PIXGETTHCOUNT = 0xC0747013; +$PIXRUN = 0x20007014; diff --git a/h2pl/getioctlsizes b/h2pl/getioctlsizes new file mode 100644 index 0000000..b7d4a0d --- /dev/null +++ b/h2pl/getioctlsizes @@ -0,0 +1,13 @@ +#!/usr/bin/perl + +open (IOCTLS,'/usr/include/sys/ioctl.h') || die "ioctl open failed"; + +while () { + if (/^\s*#\s*define\s+\w+\s+_IO(R|W|WR)\(\w+,\s*\w+,\s*([^)]+)/) { + $need{$2}++; + } +} + +foreach $key ( sort keys %need ) { + print $key,"\n"; +} diff --git a/handy.h b/handy.h index a19f684..3eea478 100644 --- a/handy.h +++ b/handy.h @@ -1,4 +1,4 @@ -/* $Header: handy.h,v 3.0.1.1 89/11/17 15:25:55 lwall Locked $ +/* $Header: handy.h,v 3.0.1.2 90/08/09 03:48:28 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,9 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: handy.h,v $ + * Revision 3.0.1.2 90/08/09 03:48:28 lwall + * patch19: various MSDOS and OS/2 patches folded in + * * Revision 3.0.1.1 89/11/17 15:25:55 lwall * patch5: some machines already define TRUE and FALSE * @@ -67,12 +70,21 @@ typedef unsigned short line_t; char *safemalloc(); char *saferealloc(); void safefree(); +#ifndef MSDOS #define New(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))) #define Newc(x,v,n,t,c) (v = (c*)safemalloc((MEM_SIZE)((n) * sizeof(t)))) #define Newz(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))), \ bzero((char*)(v), (n) * sizeof(t)) #define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) #define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) +#else +#define New(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t)))) +#define Newc(x,v,n,t,c) (v = (c*)safemalloc(((unsigned long)(n) * sizeof(t)))) +#define Newz(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t)))), \ + bzero((char*)(v), (n) * sizeof(t)) +#define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t)))) +#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t)))) +#endif /* MSDOS */ #define Safefree(d) safefree((char*)d) #define Str_new(x,len) str_new(len) #else /* LEAKTEST */ diff --git a/hash.c b/hash.c index e0b00ea..ffeaf1d 100644 --- a/hash.c +++ b/hash.c @@ -1,4 +1,4 @@ -/* $Header: hash.c,v 3.0.1.3 90/03/27 15:59:09 lwall Locked $ +/* $Header: hash.c,v 3.0.1.4 90/08/09 03:50:22 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,9 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: hash.c,v $ + * Revision 3.0.1.4 90/08/09 03:50:22 lwall + * patch19: dbmopen(name, 'filename', undef) now refrains from creating + * * Revision 3.0.1.3 90/03/27 15:59:09 lwall * patch16: @dbmvalues{'foo','bar'} could use the same cache entry for both values * @@ -23,6 +26,16 @@ #include "EXTERN.h" #include "perl.h" +static char coeff[] = { + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1}; + STR * hfetch(tb,key,klen,lval) register HASH *tb; @@ -502,19 +515,22 @@ int mode; if (tb->tbl_dbm) /* never really closed it */ return TRUE; #endif - if (tb->tbl_dbm) + if (tb->tbl_dbm) { hdbmclose(tb); + tb->tbl_dbm = 0; + } hclear(tb); #ifdef NDBM - tb->tbl_dbm = dbm_open(fname, O_RDWR|O_CREAT, mode); - if (!tb->tbl_dbm) /* oops, just try reading it */ - tb->tbl_dbm = dbm_open(fname, O_RDONLY, mode); + if (mode >= 0) + tb->tbl_dbm = dbm_open(fname, O_RDWR|O_CREAT, mode); + if (!tb->tbl_dbm) + tb->tbl_dbm = dbm_open(fname, O_RDWR, mode); #else if (dbmrefcnt++) fatal("Old dbm can only open one database"); sprintf(buf,"%s.dir",fname); if (stat(buf, &statbuf) < 0) { - if (close(creat(buf,mode)) < 0) + if (mode < 0 || close(creat(buf,mode)) < 0) return FALSE; sprintf(buf,"%s.pag",fname); if (close(creat(buf,mode)) < 0) diff --git a/hash.h b/hash.h index d13f2b7..430fcfe 100644 --- a/hash.h +++ b/hash.h @@ -1,4 +1,4 @@ -/* $Header: hash.h,v 3.0 89/10/18 15:18:39 lwall Locked $ +/* $Header: hash.h,v 3.0.1.1 90/08/09 03:51:34 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,9 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: hash.h,v $ + * Revision 3.0.1.1 90/08/09 03:51:34 lwall + * patch19: various MSDOS and OS/2 patches folded in + * * Revision 3.0 89/10/18 15:18:39 lwall * 3.0 baseline * @@ -15,20 +18,7 @@ #define DBM_CACHE_MAX 63 /* cache 64 entries for dbm file */ /* (resident array acts as a write-thru cache)*/ -#define COEFFSIZE (16 * 8) /* size of array below */ -#ifdef DOINIT -char coeff[] = { - 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, - 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, - 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, - 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, - 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, - 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, - 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, - 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1}; -#else -extern char coeff[]; -#endif +#define COEFFSIZE (16 * 8) /* size of coeff array */ typedef struct hentry HENT; diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl index b8cff89..b3fb02b 100644 --- a/lib/dumpvar.pl +++ b/lib/dumpvar.pl @@ -1,25 +1,32 @@ package dumpvar; +# translate control chars to ^X - Randal Schwartz +sub unctrl { + local($_) = @_; + s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg; + $_; +} sub main'dumpvar { - ($package) = @_; + ($package,@vars) = @_; local(*stab) = eval("*_$package"); while (($key,$val) = each(%stab)) { { + next if @vars && !grep($key eq $_,@vars); local(*entry) = $val; if (defined $entry) { - print "\$$key = '$entry'\n"; + print "\$$key = '",&unctrl($entry),"'\n"; } if (defined @entry) { print "\@$key = (\n"; foreach $num ($[ .. $#entry) { - print " $num\t'",$entry[$num],"'\n"; + print " $num\t'",&unctrl($entry[$num]),"'\n"; } print ")\n"; } if ($key ne "_$package" && defined %entry) { print "\%$key = (\n"; foreach $key (sort keys(%entry)) { - print " $key\t'",$entry{$key},"'\n"; + print " $key\t'",&unctrl($entry{$key}),"'\n"; } print ")\n"; } diff --git a/lib/flush.pl b/lib/flush.pl new file mode 100644 index 0000000..1d22819 --- /dev/null +++ b/lib/flush.pl @@ -0,0 +1,22 @@ +;# Usage: &flush(FILEHANDLE) +;# flushes the named filehandle + +;# Usage: &printflush(FILEHANDLE, "prompt: ") +;# prints arguments and flushes filehandle + +sub flush { + local($old) = select(shift); + $| = 1; + print ""; + $| = 0; + select($old); +} + +sub printflush { + local($old) = select(shift); + $| = 1; + print @_; + $| = 0; + select($old); +} + diff --git a/lib/importenv.pl b/lib/importenv.pl index c321a20..db3128b 100644 --- a/lib/importenv.pl +++ b/lib/importenv.pl @@ -1,8 +1,8 @@ -;# $Header: importenv.pl,v 3.0 89/10/18 15:19:39 lwall Locked $ +;# $Header: importenv.pl,v 3.0.1.1 90/08/09 03:56:38 lwall Locked $ ;# This file, when interpreted, pulls the environment into normal variables. ;# Usage: -;# do 'importenv.pl'; +;# require 'importenv.pl'; ;# or ;# #include diff --git a/makelib.SH b/makelib.SH index 6cc9783..e74ba8d 100644 --- a/makelib.SH +++ b/makelib.SH @@ -1,192 +1,2 @@ -case $CONFIG in -'') - if test ! -f config.sh; then - ln ../config.sh . || \ - ln ../../config.sh . || \ - ln ../../../config.sh . || \ - (echo "Can't find config.sh."; exit 1) - fi - . config.sh - ;; -esac -: This forces SH files to create target in same directory as SH file. -: This is so that make depend always knows where to find SH derivatives. -case "$0" in -*/*) cd `expr X$0 : 'X\(.*\)/'` ;; -esac -echo "Extracting makelib (with variable substitutions)" -: This section of the file will have variable substitutions done on it. -: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. -: Protect any dollar signs and backticks that you do not want interpreted -: by putting a backslash in front. You may delete these comments. -$spitshell >makelib <>makelib <<'!NO!SUBS!' - -chdir '/usr/include' || die "Can't cd /usr/include"; - -%isatype = ('char',1,'short',1,'int',1,'long',1); - -foreach $file (@ARGV) { - print $file,"\n"; - if ($file =~ m|^(.*)/|) { - $dir = $1; - if (!-d "$perlincl/$dir") { - mkdir("$perlincl/$dir",0777); - } - } - open(IN,"$file") || ((warn "Can't open $file: $!\n"),next); - open(OUT,">$perlincl/$file") || die "Can't create $file: $!\n"; - while () { - chop; - while (/\\$/) { - chop; - $_ .= ; - chop; - } - if (s:/\*:\200:g) { - s:\*/:\201:g; - s/\200[^\201]*\201//g; # delete single line comments - if (s/\200.*//) { # begin multi-line comment? - $_ .= '/*'; - $_ .= ; - redo; - } - } - if (s/^#\s*//) { - if (s/^define\s+(\w+)//) { - $name = $1; - $new = ''; - s/\s+$//; - if (s/^\(([\w,\s]*)\)//) { - $args = $1; - if ($args ne '') { - foreach $arg (split(/,\s*/,$args)) { - $curargs{$arg} = 1; - } - $args =~ s/\b(\w)/\$$1/g; - $args = "local($args) = \@_;\n$t "; - } - s/^\s+//; - do expr(); - $new =~ s/(["\\])/\\$1/g; - if ($t ne '') { - $new =~ s/(['\\])/\\$1/g; - print OUT $t, - "eval 'sub $name {\n$t ${args}eval \"$new\";\n$t}';\n"; - } - else { - print OUT "sub $name {\n ${args}eval \"$new\";\n}\n"; - } - %curargs = (); - } - else { - s/^\s+//; - do expr(); - $new = 1 if $new eq ''; - if ($t ne '') { - $new =~ s/(['\\])/\\$1/g; - print OUT $t,"eval 'sub $name {",$new,";}';\n"; - } - else { - print OUT $t,"sub $name {",$new,";}\n"; - } - } - } - elsif (/^include <(.*)>/) { - print OUT $t,"do '$1' || die \"Can't include $1: \$!\";\n"; - } - elsif (/^ifdef\s+(\w+)/) { - print OUT $t,"if (defined &$1) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^ifndef\s+(\w+)/) { - print OUT $t,"if (!defined &$1) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (s/^if\s+//) { - $new = ''; - do expr(); - print OUT $t,"if ($new) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (s/^elif\s+//) { - $new = ''; - do expr(); - $tab -= 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n${t}elsif ($new) {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^else/) { - $tab -= 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n${t}else {\n"; - $tab += 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - } - elsif (/^endif/) { - $tab -= 4; - $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); - print OUT $t,"}\n"; - } - } - } - print OUT "1;\n"; -} - -sub expr { - while ($_ ne '') { - s/^(\s+)// && do {$new .= ' '; next;}; - s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;}; - s/^(\d+)// && do {$new .= $1; next;}; - s/^("(\\"|[^"])*")// && do {$new .= $1; next;}; - s/^'((\\"|[^"])*)'// && do { - if ($curargs{$1}) { - $new .= "ord('\$$1')"; - } - else { - $new .= "ord('$1')"; - } - next; - }; - s/^(struct\s+\w+)// && do {$new .= "'$1'"; next;}; - s/^sizeof\s*\(([^)]+)\)/{$1}/ && do { - $new .= '$sizeof'; - next; - }; - s/^([_a-zA-Z]\w*)// && do { - $id = $1; - if ($curargs{$id}) { - $new .= '$' . $id; - } - elsif ($id eq 'defined') { - $new .= 'defined'; - } - elsif (/^\(/) { - s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/; # cheat - $new .= "&$id"; - } - elsif ($isatype{$id}) { - $new .= "'$id'"; - } - else { - $new .= '&' . $id; - } - next; - }; - s/^(.)// && do {$new .= $1; next;}; - } -} -!NO!SUBS! -chmod 755 makelib -$eunicefix makelib +echo "makelib.SH has been renamed to h2ph.SH" +rm makelib diff --git a/patchlevel.h b/patchlevel.h index 49ea5df..7c3da2c 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 21 +#define PATCHLEVEL 22 diff --git a/usub/man2mus b/usub/man2mus new file mode 100644 index 0000000..a304678 --- /dev/null +++ b/usub/man2mus @@ -0,0 +1,66 @@ +#!/usr/bin/perl +while (<>) { + if (/^\.SH SYNOPSIS/) { + $spec = ''; + for ($_ = <>; $_ && !/^\.SH/; $_ = <>) { + s/^\.[IRB][IRB]\s*//; + s/^\.[IRB]\s+//; + next if /^\./; + s/\\f\w//g; + s/\\&//g; + s/^\s+//; + next if /^$/; + next if /^#/; + $spec .= $_; + } + $_ = $spec; + 0 while s/\(([^),;]*)\s*,\s*([^);]*)\)/($1|$2)/g; + s/\(\*([^,;]*)\)\(\)/(*)()$1/g; + s/(\w+)\[\]/*$1/g; + + s/\n/ /g; + s/\s+/ /g; + s/(\w+) \(([^*])/$1($2/g; + s/^ //; + s/ ?; ?/\n/g; + s/\) /)\n/g; + s/ \* / \*/g; + s/\* / \*/g; + + $* = 1; + 0 while s/^((struct )?\w+ )([^\n,]*), ?(.*)/$1$3\n$1$4/g; + $* = 0; + s/\|/,/g; + + @cases = (); + for (reverse split(/\n/,$_)) { + if (/\)$/) { + ($type,$name,$args) = split(/(\w+)\(/); + $type =~ s/ $//; + if ($type =~ /^(\w+) =/) { + $type = $type{$1} if $type{$1}; + } + $type = 'int' if $type eq ''; + @args = grep(/./, split(/[,)]/,$args)); + $case = "CASE $type $name\n"; + foreach $arg (@args) { + $type = $type{$arg} || "int"; + $type =~ s/ //g; + $type .= "\t" if length($type) < 8; + if ($type =~ /\*/) { + $case .= "IO $type $arg\n"; + } + else { + $case .= "I $type $arg\n"; + } + } + $case .= "END\n\n"; + unshift(@cases, $case); + } + else { + $type{$name} = $type if ($type,$name) = /(.*\W)(\w+)$/; + } + } + print @cases; + } +}