home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume30 / perl / patch30 < prev    next >
Encoding:
Text File  |  1992-06-11  |  49.4 KB  |  1,939 lines
  1. Newsgroups: comp.sources.misc
  2. From: lwall@netlabs.com (Larry Wall)
  3. Subject:  v30i041:  perl - The perl programming language, Patch30
  4. Message-ID: <1992Jun11.180756.1426@sparky.imd.sterling.com>
  5. X-Md4-Signature: 655951ed82458e9acd368f8737df5cbd
  6. Date: Thu, 11 Jun 1992 18:07:56 GMT
  7. Approved: kent@sparky.imd.sterling.com
  8.  
  9. Submitted-by: lwall@netlabs.com (Larry Wall)
  10. Posting-number: Volume 30, Issue 41
  11. Archive-name: perl/patch30
  12. Environment: UNIX, MS-DOS, OS2
  13. Patch-To: perl: Volume 18, Issue 19-54
  14.  
  15. System: perl version 4.0
  16. Patch #: 30
  17. Priority: highish
  18. Subject: patch #20, continued
  19.  
  20. Description:
  21.     See patch #20.
  22.  
  23. Fix:    From rn, say "| patch -p -N -d DIR", where DIR is your perl source
  24.     directory.  Outside of rn, say "cd DIR; patch -p -N <thisarticle".
  25.     If you don't have the patch program, apply the following by hand,
  26.     or get patch (version 2.0, latest patchlevel).
  27.  
  28.     After patching:
  29.         *** DO NOTHING--INSTALL ALL PATCHES UP THROUGH #33 FIRST ***
  30.  
  31.     If patch indicates that patchlevel is the wrong version, you may need
  32.     to apply one or more previous patches, or the patch may already
  33.     have been applied.  See the patchlevel.h file to find out what has or
  34.     has not been applied.  In any event, don't continue with the patch.
  35.  
  36.     If you are missing previous patches they can be obtained from me:
  37.  
  38.     Larry Wall
  39.     lwall@netlabs.com
  40.  
  41.     If you send a mail message of the following form it will greatly speed
  42.     processing:
  43.  
  44.     Subject: Command
  45.     @SH mailpatch PATH perl 4.0 LIST
  46.            ^ note the c
  47.  
  48.     where PATH is a return path FROM ME TO YOU either in Internet notation,
  49.     or in bang notation from some well-known host, and LIST is the number
  50.     of one or more patches you need, separated by spaces, commas, and/or
  51.     hyphens.  Saying 35- says everything from 35 to the end.
  52.  
  53.  
  54. Index: patchlevel.h
  55. Prereq: 29
  56. 1c1
  57. < #define PATCHLEVEL 29
  58. ---
  59. > #define PATCHLEVEL 30
  60.  
  61. Index: perly.y
  62. *** perly.y.old    Mon Jun  8 17:51:22 1992
  63. --- perly.y    Mon Jun  8 17:51:23 1992
  64. ***************
  65. *** 1,4 ****
  66. ! /* $RCSfile: perly.y,v $$Revision: 4.0.1.2 $$Date: 91/11/05 18:17:38 $
  67.    *
  68.    *    Copyright (c) 1991, Larry Wall
  69.    *
  70. --- 1,4 ----
  71. ! /* $RCSfile: perly.y,v $$Revision: 4.0.1.4 $$Date: 92/06/08 17:33:25 $
  72.    *
  73.    *    Copyright (c) 1991, Larry Wall
  74.    *
  75. ***************
  76. *** 6,11 ****
  77. --- 6,22 ----
  78.    *    License or the Artistic License, as specified in the README file.
  79.    *
  80.    * $Log:    perly.y,v $
  81. +  * Revision 4.0.1.4  92/06/08  17:33:25  lwall
  82. +  * patch20: one of the backdoors to expectterm was on the wrong reduction
  83. +  * 
  84. +  * Revision 4.0.1.3  92/06/08  15:18:16  lwall
  85. +  * patch20: an expression may now start with a bareword
  86. +  * patch20: relaxed requirement for semicolon at the end of a block
  87. +  * patch20: added ... as variant on ..
  88. +  * patch20: fixed double debug break in foreach with implicit array assignment
  89. +  * patch20: if {block} {block} didn't work any more
  90. +  * patch20: deleted some minor memory leaks
  91. +  * 
  92.    * Revision 4.0.1.2  91/11/05  18:17:38  lwall
  93.    * patch11: extra comma at end of list is now allowed in more places (Hi, Felix!)
  94.    * patch11: once-thru blocks didn't display right in the debugger
  95. ***************
  96. *** 47,54 ****
  97.   
  98.   %token <ival> '{' ')'
  99.   
  100. ! %token <cval> WORD
  101. ! %token <ival> APPEND OPEN SSELECT LOOPEX
  102.   %token <ival> USING FORMAT DO SHIFT PUSH POP LVALFUN
  103.   %token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT FLIST
  104.   %token <ival> FOR FILOP FILOP2 FILOP3 FILOP4 FILOP22 FILOP25
  105. --- 58,65 ----
  106.   
  107.   %token <ival> '{' ')'
  108.   
  109. ! %token <cval> WORD LABEL
  110. ! %token <ival> APPEND OPEN SSELECT LOOPEX DOTDOT
  111.   %token <ival> USING FORMAT DO SHIFT PUSH POP LVALFUN
  112.   %token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT FLIST
  113.   %token <ival> FOR FILOP FILOP2 FILOP3 FILOP4 FILOP22 FILOP25
  114. ***************
  115. *** 95,100 ****
  116. --- 106,112 ----
  117.           {
  118.   #if defined(YYDEBUG) && defined(DEBUGGING)
  119.               yydebug = (debug & 1);
  120. +             expectterm = 2;
  121.   #endif
  122.           }
  123.       /*CONTINUED*/    lineseq
  124. ***************
  125. *** 116,130 ****
  126.               { $$ = $2; }
  127.       |    ELSIF '(' expr ')' compblock
  128.               { cmdline = $1;
  129. !                 $$ = make_ccmd(C_ELSIF,$3,$5); }
  130.       ;
  131.   
  132.   block    :    '{' remember lineseq '}'
  133.               { $$ = block_head($3);
  134. !               if (cmdline > $1)
  135.                     cmdline = $1;
  136.                 if (savestack->ary_fill > $2)
  137. !                 restorelist($2); }
  138.       ;
  139.   
  140.   remember:    /* NULL */    /* in case they push a package name */
  141. --- 128,143 ----
  142.               { $$ = $2; }
  143.       |    ELSIF '(' expr ')' compblock
  144.               { cmdline = $1;
  145. !                 $$ = make_ccmd(C_ELSIF,1,$3,$5); }
  146.       ;
  147.   
  148.   block    :    '{' remember lineseq '}'
  149.               { $$ = block_head($3);
  150. !               if (cmdline > (line_t)$1)
  151.                     cmdline = $1;
  152.                 if (savestack->ary_fill > $2)
  153. !                 restorelist($2);
  154. !               expectterm = 2; }
  155.       ;
  156.   
  157.   remember:    /* NULL */    /* in case they push a package name */
  158. ***************
  159. *** 150,158 ****
  160.                   else {
  161.                     $$ = Nullcmd;
  162.                     cmdline = NOLINE;
  163. !                 } }
  164.       |    label sideff ';'
  165. !             { $$ = add_label($1,$2); }
  166.       ;
  167.   
  168.   sideff    :    error
  169. --- 163,173 ----
  170.                   else {
  171.                     $$ = Nullcmd;
  172.                     cmdline = NOLINE;
  173. !                 }
  174. !                 expectterm = 2; }
  175.       |    label sideff ';'
  176. !             { $$ = add_label($1,$2);
  177. !               expectterm = 2; }
  178.       ;
  179.   
  180.   sideff    :    error
  181. ***************
  182. *** 181,208 ****
  183.                   $$ = invert(make_icmd(C_IF,$3,$5)); }
  184.       |    IF block compblock
  185.               { cmdline = $1;
  186. !                 $$ = make_ccmd(C_IF,cmd_to_arg($2),$3); }
  187.       |    UNLESS block compblock
  188.               { cmdline = $1;
  189. !                 $$ = invert(make_ccmd(C_IF,cmd_to_arg($2),$3)); }
  190.       ;
  191.   
  192.   loop    :    label WHILE '(' texpr ')' compblock
  193.               { cmdline = $2;
  194.                   $$ = wopt(add_label($1,
  195. !                 make_ccmd(C_WHILE,$4,$6) )); }
  196.       |    label UNTIL '(' expr ')' compblock
  197.               { cmdline = $2;
  198.                   $$ = wopt(add_label($1,
  199. !                 invert(make_ccmd(C_WHILE,$4,$6)) )); }
  200.       |    label WHILE block compblock
  201.               { cmdline = $2;
  202.                   $$ = wopt(add_label($1,
  203. !                 make_ccmd(C_WHILE, cmd_to_arg($3),$4) )); }
  204.       |    label UNTIL block compblock
  205.               { cmdline = $2;
  206.                   $$ = wopt(add_label($1,
  207. !                 invert(make_ccmd(C_WHILE, cmd_to_arg($3),$4)) )); }
  208.       |    label FOR REG '(' expr crp compblock
  209.               { cmdline = $2;
  210.                   /*
  211. --- 196,223 ----
  212.                   $$ = invert(make_icmd(C_IF,$3,$5)); }
  213.       |    IF block compblock
  214.               { cmdline = $1;
  215. !                 $$ = make_icmd(C_IF,cmd_to_arg($2),$3); }
  216.       |    UNLESS block compblock
  217.               { cmdline = $1;
  218. !                 $$ = invert(make_icmd(C_IF,cmd_to_arg($2),$3)); }
  219.       ;
  220.   
  221.   loop    :    label WHILE '(' texpr ')' compblock
  222.               { cmdline = $2;
  223.                   $$ = wopt(add_label($1,
  224. !                 make_ccmd(C_WHILE,1,$4,$6) )); }
  225.       |    label UNTIL '(' expr ')' compblock
  226.               { cmdline = $2;
  227.                   $$ = wopt(add_label($1,
  228. !                 invert(make_ccmd(C_WHILE,1,$4,$6)) )); }
  229.       |    label WHILE block compblock
  230.               { cmdline = $2;
  231.                   $$ = wopt(add_label($1,
  232. !                 make_ccmd(C_WHILE, 1, cmd_to_arg($3),$4) )); }
  233.       |    label UNTIL block compblock
  234.               { cmdline = $2;
  235.                   $$ = wopt(add_label($1,
  236. !                 invert(make_ccmd(C_WHILE,1,cmd_to_arg($3),$4)) )); }
  237.       |    label FOR REG '(' expr crp compblock
  238.               { cmdline = $2;
  239.                   /*
  240. ***************
  241. *** 229,235 ****
  242.                       Nullarg)),
  243.                         Nullarg),
  244.                       wopt(over($3,add_label($1,
  245. !                       make_ccmd(C_WHILE,
  246.                       make_op(O_ARRAY, 1,
  247.                         stab2arg(A_STAB,scrstab),
  248.                         Nullarg,Nullarg ),
  249. --- 244,250 ----
  250.                       Nullarg)),
  251.                         Nullarg),
  252.                       wopt(over($3,add_label($1,
  253. !                       make_ccmd(C_WHILE, 0,
  254.                       make_op(O_ARRAY, 1,
  255.                         stab2arg(A_STAB,scrstab),
  256.                         Nullarg,Nullarg ),
  257. ***************
  258. *** 239,245 ****
  259.                   }
  260.                   else {
  261.                   $$ = wopt(over($3,add_label($1,
  262. !                 make_ccmd(C_WHILE,$5,$7) )));
  263.                   }
  264.               }
  265.       |    label FOR '(' expr crp compblock
  266. --- 254,260 ----
  267.                   }
  268.                   else {
  269.                   $$ = wopt(over($3,add_label($1,
  270. !                 make_ccmd(C_WHILE,1,$5,$7) )));
  271.                   }
  272.               }
  273.       |    label FOR '(' expr crp compblock
  274. ***************
  275. *** 256,262 ****
  276.                       Nullarg)),
  277.                         Nullarg),
  278.                       wopt(over(defstab,add_label($1,
  279. !                       make_ccmd(C_WHILE,
  280.                       make_op(O_ARRAY, 1,
  281.                         stab2arg(A_STAB,scrstab),
  282.                         Nullarg,Nullarg ),
  283. --- 271,277 ----
  284.                       Nullarg)),
  285.                         Nullarg),
  286.                       wopt(over(defstab,add_label($1,
  287. !                       make_ccmd(C_WHILE, 0,
  288.                       make_op(O_ARRAY, 1,
  289.                         stab2arg(A_STAB,scrstab),
  290.                         Nullarg,Nullarg ),
  291. ***************
  292. *** 266,272 ****
  293.                   }
  294.                   else {    /* lisp, anyone? */
  295.                   $$ = wopt(over(defstab,add_label($1,
  296. !                 make_ccmd(C_WHILE,$4,$6) )));
  297.                   }
  298.               }
  299.       |    label FOR '(' nexpr ';' texpr ';' nexpr ')' block
  300. --- 281,287 ----
  301.                   }
  302.                   else {    /* lisp, anyone? */
  303.                   $$ = wopt(over(defstab,add_label($1,
  304. !                 make_ccmd(C_WHILE,1,$4,$6) )));
  305.                   }
  306.               }
  307.       |    label FOR '(' nexpr ';' texpr ';' nexpr ')' block
  308. ***************
  309. *** 275,283 ****
  310.                   yyval.compval.comp_alt = $8;
  311.                   cmdline = $2;
  312.                   $$ = append_line($4,wopt(add_label($1,
  313. !                 make_ccmd(C_WHILE,$6,yyval.compval) ))); }
  314.       |    label compblock    /* a block is a loop that happens once */
  315. !             { $$ = add_label($1,make_ccmd(C_BLOCK,Nullarg,$2)); }
  316.       ;
  317.   
  318.   nexpr    :    /* NULL */
  319. --- 290,298 ----
  320.                   yyval.compval.comp_alt = $8;
  321.                   cmdline = $2;
  322.                   $$ = append_line($4,wopt(add_label($1,
  323. !                 make_ccmd(C_WHILE,1,$6,yyval.compval) ))); }
  324.       |    label compblock    /* a block is a loop that happens once */
  325. !             { $$ = add_label($1,make_ccmd(C_BLOCK,1,Nullarg,$2)); }
  326.       ;
  327.   
  328.   nexpr    :    /* NULL */
  329. ***************
  330. *** 286,298 ****
  331.       ;
  332.   
  333.   texpr    :    /* NULL means true */
  334. !             { (void)scanstr("1"); $$ = yylval.arg; }
  335.       |    expr
  336.       ;
  337.   
  338.   label    :    /* empty */
  339.               { $$ = Nullch; }
  340. !     |    WORD ':'
  341.       ;
  342.   
  343.   decl    :    format
  344. --- 301,313 ----
  345.       ;
  346.   
  347.   texpr    :    /* NULL means true */
  348. !             { (void)scanstr("1",SCAN_DEF); $$ = yylval.arg; }
  349.       |    expr
  350.       ;
  351.   
  352.   label    :    /* empty */
  353.               { $$ = Nullch; }
  354. !     |    LABEL
  355.       ;
  356.   
  357.   decl    :    format
  358. ***************
  359. *** 339,344 ****
  360. --- 354,360 ----
  361.                 curstash->tbl_coeffsize = 0;
  362.                 Safefree($2); $2 = Nullch;
  363.                 cmdline = NOLINE;
  364. +               expectterm = 2;
  365.               }
  366.       ;
  367.   
  368. ***************
  369. *** 409,415 ****
  370.               { $$ = make_op(O_BIT_OR, 2, $1, $3, Nullarg); }
  371.       |    sexpr DOTDOT sexpr
  372.               { arg4 = Nullarg;
  373. !               $$ = make_op(O_F_OR_R, 4, $1, $3, Nullarg); }
  374.       |    sexpr ANDAND sexpr
  375.               { $$ = make_op(O_AND, 2, $1, $3, Nullarg); }
  376.       |    sexpr OROR sexpr
  377. --- 425,432 ----
  378.               { $$ = make_op(O_BIT_OR, 2, $1, $3, Nullarg); }
  379.       |    sexpr DOTDOT sexpr
  380.               { arg4 = Nullarg;
  381. !               $$ = make_op(O_F_OR_R, 4, $1, $3, Nullarg);
  382. !               $$[0].arg_flags |= $2; }
  383.       |    sexpr ANDAND sexpr
  384.               { $$ = make_op(O_AND, 2, $1, $3, Nullarg); }
  385.       |    sexpr OROR sexpr
  386. ***************
  387. *** 449,454 ****
  388. --- 466,472 ----
  389.                   $$ = make_op($1, 1,
  390.                   stab2arg(A_STAB,stabent($2,TRUE)),
  391.                   Nullarg, Nullarg);
  392. +                 Safefree($2); $2 = Nullch;
  393.               }
  394.       |    FILETEST sexpr
  395.               { opargs[$1] = 1;
  396. ***************
  397. *** 487,497 ****
  398.               { $$ = make_op(O_ARRAY, 1,
  399.                   stab2arg(A_STAB,$1),
  400.                   Nullarg, Nullarg); }
  401. !     |    REG '{' expr '}'    %prec '('
  402.               { $$ = make_op(O_HELEM, 2,
  403.                   stab2arg(A_STAB,hadd($1)),
  404.                   jmaybe($3),
  405. !                 Nullarg); }
  406.       |    '(' expr crp '[' expr ']'    %prec '('
  407.               { $$ = make_op(O_LSLICE, 3,
  408.                   Nullarg,
  409. --- 505,516 ----
  410.               { $$ = make_op(O_ARRAY, 1,
  411.                   stab2arg(A_STAB,$1),
  412.                   Nullarg, Nullarg); }
  413. !     |    REG '{' expr ';' '}'    %prec '('
  414.               { $$ = make_op(O_HELEM, 2,
  415.                   stab2arg(A_STAB,hadd($1)),
  416.                   jmaybe($3),
  417. !                 Nullarg);
  418. !                 expectterm = FALSE; }
  419.       |    '(' expr crp '[' expr ']'    %prec '('
  420.               { $$ = make_op(O_LSLICE, 3,
  421.                   Nullarg,
  422. ***************
  423. *** 507,522 ****
  424.                   stab2arg(A_STAB,aadd($1)),
  425.                   listish(make_list($3)),
  426.                   Nullarg); }
  427. !     |    ARY '{' expr '}'    %prec '('
  428.               { $$ = make_op(O_HSLICE, 2,
  429.                   stab2arg(A_STAB,hadd($1)),
  430.                   listish(make_list($3)),
  431. !                 Nullarg); }
  432. !     |    DELETE REG '{' expr '}'    %prec '('
  433.               { $$ = make_op(O_DELETE, 2,
  434.                   stab2arg(A_STAB,hadd($2)),
  435.                   jmaybe($4),
  436. !                 Nullarg); }
  437.       |    ARYLEN    %prec '('
  438.               { $$ = stab2arg(A_ARYLEN,$1); }
  439.       |    RSTRING    %prec '('
  440. --- 526,549 ----
  441.                   stab2arg(A_STAB,aadd($1)),
  442.                   listish(make_list($3)),
  443.                   Nullarg); }
  444. !     |    ARY '{' expr ';' '}'    %prec '('
  445.               { $$ = make_op(O_HSLICE, 2,
  446.                   stab2arg(A_STAB,hadd($1)),
  447.                   listish(make_list($3)),
  448. !                 Nullarg);
  449. !                 expectterm = FALSE; }
  450. !     |    DELETE REG '{' expr ';' '}'    %prec '('
  451.               { $$ = make_op(O_DELETE, 2,
  452.                   stab2arg(A_STAB,hadd($2)),
  453.                   jmaybe($4),
  454. !                 Nullarg);
  455. !                 expectterm = FALSE; }
  456. !     |    DELETE '(' REG '{' expr ';' '}' ')'    %prec '('
  457. !             { $$ = make_op(O_DELETE, 2,
  458. !                 stab2arg(A_STAB,hadd($3)),
  459. !                 jmaybe($4),
  460. !                 Nullarg);
  461. !                 expectterm = FALSE; }
  462.       |    ARYLEN    %prec '('
  463.               { $$ = stab2arg(A_ARYLEN,$1); }
  464.       |    RSTRING    %prec '('
  465. ***************
  466. *** 543,559 ****
  467.                   stab2arg(A_WORD,stabent($2,MULTI)),
  468.                   make_list(Nullarg),
  469.                   Nullarg);
  470.                   $$->arg_flags |= AF_DEPR; }
  471.       |    AMPER WORD '(' ')'
  472.               { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
  473.                   stab2arg(A_WORD,stabent($2,MULTI)),
  474.                   make_list(Nullarg),
  475. !                 Nullarg); }
  476.       |    AMPER WORD
  477.               { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
  478.                   stab2arg(A_WORD,stabent($2,MULTI)),
  479.                   Nullarg,
  480. !                 Nullarg); }
  481.       |    DO REG '(' expr crp
  482.               { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
  483.                   stab2arg(A_STAB,$2),
  484. --- 570,591 ----
  485.                   stab2arg(A_WORD,stabent($2,MULTI)),
  486.                   make_list(Nullarg),
  487.                   Nullarg);
  488. +                 Safefree($2); $2 = Nullch;
  489.                   $$->arg_flags |= AF_DEPR; }
  490.       |    AMPER WORD '(' ')'
  491.               { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
  492.                   stab2arg(A_WORD,stabent($2,MULTI)),
  493.                   make_list(Nullarg),
  494. !                 Nullarg);
  495. !                 Safefree($2); $2 = Nullch;
  496. !             }
  497.       |    AMPER WORD
  498.               { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
  499.                   stab2arg(A_WORD,stabent($2,MULTI)),
  500.                   Nullarg,
  501. !                 Nullarg);
  502. !                 Safefree($2); $2 = Nullch;
  503. !             }
  504.       |    DO REG '(' expr crp
  505.               { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
  506.                   stab2arg(A_STAB,$2),
  507. ***************
  508. *** 609,620 ****
  509.               { $$ = make_op(O_OPEN, 2,
  510.                   stab2arg(A_WORD,stabent($2,TRUE)),
  511.                   stab2arg(A_STAB,stabent($2,TRUE)),
  512. !                 Nullarg); }
  513.       |    OPEN '(' WORD ')'
  514.               { $$ = make_op(O_OPEN, 2,
  515.                   stab2arg(A_WORD,stabent($3,TRUE)),
  516.                   stab2arg(A_STAB,stabent($3,TRUE)),
  517. !                 Nullarg); }
  518.       |    OPEN '(' handle cexpr ')'
  519.               { $$ = make_op(O_OPEN, 2,
  520.                   $3,
  521. --- 641,656 ----
  522.               { $$ = make_op(O_OPEN, 2,
  523.                   stab2arg(A_WORD,stabent($2,TRUE)),
  524.                   stab2arg(A_STAB,stabent($2,TRUE)),
  525. !                 Nullarg);
  526. !                 Safefree($2); $2 = Nullch;
  527. !             }
  528.       |    OPEN '(' WORD ')'
  529.               { $$ = make_op(O_OPEN, 2,
  530.                   stab2arg(A_WORD,stabent($3,TRUE)),
  531.                   stab2arg(A_STAB,stabent($3,TRUE)),
  532. !                 Nullarg);
  533. !                 Safefree($3); $3 = Nullch;
  534. !             }
  535.       |    OPEN '(' handle cexpr ')'
  536.               { $$ = make_op(O_OPEN, 2,
  537.                   $3,
  538. ***************
  539. *** 763,769 ****
  540.               { $$ = make_op($1,2,
  541.                   stab2arg(A_WORD,stabent($2,TRUE)),
  542.                   stab2arg(A_STAB,defstab),
  543. !                 Nullarg); }
  544.       |    LISTOP WORD expr
  545.               { $$ = make_op($1,2,
  546.                   stab2arg(A_WORD,stabent($2,TRUE)),
  547. --- 799,807 ----
  548.               { $$ = make_op($1,2,
  549.                   stab2arg(A_WORD,stabent($2,TRUE)),
  550.                   stab2arg(A_STAB,defstab),
  551. !                 Nullarg);
  552. !                 Safefree($2); $2 = Nullch;
  553. !             }
  554.       |    LISTOP WORD expr
  555.               { $$ = make_op($1,2,
  556.                   stab2arg(A_WORD,stabent($2,TRUE)),
  557. ***************
  558. *** 823,828 ****
  559. --- 861,867 ----
  560.                   warn(
  561.                     "\"%s\" may clash with future reserved word",
  562.                     $1 );
  563. +                 Safefree($1); $1 = Nullch;
  564.               }
  565.           ;
  566.   %% /* PROGRAM */
  567.  
  568. Index: atarist/test/pi.pl
  569. *** atarist/test/pi.pl.old    Mon Jun  8 17:45:13 1992
  570. --- atarist/test/pi.pl    Mon Jun  8 17:45:13 1992
  571. ***************
  572. *** 0 ****
  573. --- 1,174 ----
  574. + # ---------------------------------------------------------------------------
  575. + # pi.perl  computes pi (3.14...) about 5120 Digits
  576. + #
  577. + # W. Kebsch, July-1988  {uunet!mcvax}!unido!nixpbe!kebsch
  578. + 
  579. + $my_name = $0;
  580. + $version = $my_name . "-1.2";
  581. + 
  582. + # some working parameter
  583. + 
  584. + $smax =  5120;          # max digits
  585. + $lmax =     4;          # digits per one array element
  586. + $hmax = 10000;          # one array element contains: 0..9999
  587. + $smin = $lmax;          # min digits
  588. + $mag  =     7;          # magic number
  589. + 
  590. + # subroutines
  591. + 
  592. + sub mul_tm              # multiply the tm array with a long value
  593. + {
  594. +     $cb = pop(@_);      # elements(array)
  595. +     $x  = pop(@_);      # value
  596. + 
  597. +     $c = 0;
  598. +     for($i = 1; $i <= $cb; $i++)
  599. +     {
  600. +     $z      = $tm[$i] * $x + $c;
  601. +     $c      = int($z / $hmax);
  602. +     $tm[$i] = $z - $c * $hmax;
  603. +     }
  604. + }
  605. + 
  606. + sub mul_pm              # multiply the pm array with a long value
  607. + {
  608. +     $cb = pop(@_);      # elements(array)
  609. +     $x  = pop(@_);      # value
  610. + 
  611. +     $c = 0;
  612. +     for($i = 1; $i <= $cb; $i++)
  613. +     {
  614. +     $z      = $pm[$i] * $x + $c;
  615. +     $c      = int($z / $hmax);
  616. +     $pm[$i] = $z - $c * $hmax;
  617. +     }
  618. + }
  619. + 
  620. + sub divide              # divide the tm array by a long value
  621. + {
  622. +     $cb = pop(@_);      # elements(array)
  623. +     $x  = pop(@_);      # value
  624. + 
  625. +     $c = 0;
  626. +     for($i = $cb; $i >= 1; $i--)
  627. +     {
  628. +     $z      = $tm[$i] + $c;
  629. +     $q      = int($z / $x);
  630. +     $tm[$i] = $q;
  631. +     $c      = ($z - $q * $x) * $hmax;
  632. +     }
  633. + }
  634. + 
  635. + sub add                 # add tm array to pm array
  636. + {
  637. +     $cb = pop(@_);      # elements(array)
  638. + 
  639. +     $c = 0;
  640. +     for($i = 1; $i <= $cb; $i++)
  641. +     {
  642. +     $z = $pm[$i] + $tm[$i] + $c;
  643. +     if($z >= $hmax)
  644. +     {
  645. +         $pm[$i] = $z - $hmax;
  646. +         $c      = 1;
  647. +     }
  648. +     else
  649. +     {
  650. +         $pm[$i] = $z;
  651. +         $c      = 0;
  652. +     }
  653. +     }
  654. + }
  655. + 
  656. + $m0 = 0; $m1 = 0; $m2 = 0;
  657. + 
  658. + sub check_xb            # reduce current no. of elements (speed up!)
  659. + {
  660. +     $cb = pop(@_);      # current no. of elements
  661. + 
  662. +     if(($pm[$cb] == $m0) && ($pm[$cb - 1] == $m1) && ($pm[$cb - 2] == $m2))
  663. +     {
  664. +     $cb--;
  665. +     }
  666. +     $m0 = $pm[$cb];
  667. +     $m1 = $pm[$cb - 1];
  668. +     $m2 = $pm[$cb - 2];
  669. +     $cb;
  670. + }
  671. + 
  672. + sub display             # show the result
  673. + {
  674. +     $cb = pop(@_);      # elements(array);
  675. + 
  676. +     printf("\n%3d.", $pm[$cb]);
  677. +     $j = $mag - $lmax;
  678. +     for($i = $cb - 1; $i >= $j; $i--)
  679. +     {
  680. +     printf(" %04d", $pm[$i]);
  681. +     }
  682. +     print "\n";
  683. + }
  684. + 
  685. + sub the_job             # let's do the job
  686. + {
  687. +     $s = pop(@_);       # no. of digits
  688. + 
  689. +     $s  = int(($s + $lmax - 1) / $lmax) * $lmax;
  690. +     $b  = int($s / $lmax) + $mag - $lmax;
  691. +     $xb = $b;
  692. +     $t  = int($s * 5 / 3);
  693. + 
  694. +     for($i = 1; $i <= $b; $i++)         # init arrays
  695. +     {
  696. +     $pm[$i] = 0;
  697. +     $tm[$i] = 0;
  698. +     }
  699. +     $pm[$b - 1] = $hmax / 2;
  700. +     $tm[$b - 1] = $hmax / 2;
  701. + 
  702. +     printf("digits:%5d, terms:%5d, elements:%5d\n", $s, $t, $b);
  703. +     for($n = 1; $n <= $t; $n++)
  704. +     {
  705. +     printf("\r\t\t\t  term:%5d", $n);
  706. +     if($n < 200)
  707. +     {
  708. +         do mul_tm((4 * ($n * $n - $n) + 1), $xb);
  709. +     }
  710. +     else
  711. +     {
  712. +         do mul_tm((2 * $n - 1), $xb);
  713. +         do mul_tm((2 * $n - 1), $xb);
  714. +     }
  715. +     if($n < 100)
  716. +     {
  717. +         do divide(($n * (16 * $n + 8)), $xb);
  718. +     }
  719. +     else
  720. +     {
  721. +         do divide((8 * $n), $xb);
  722. +         do divide((2 * $n + 1), $xb);
  723. +     }
  724. +     do add($xb);
  725. +     if($xb > $mag)
  726. +     {
  727. +         $xb = do check_xb($xb);
  728. +     }
  729. +     }
  730. +     do mul_pm(6, $b);
  731. +     do display($b);
  732. +     ($user,$sys,$cuser,$csys) = times;
  733. +     printf("\n[u=%g  s=%g  cu=%g  cs=%g]\n",$user, $sys, $cuser, $csys);
  734. + }
  735. + 
  736. + # main block ----------------------------------------------------------------
  737. + 
  738. + $no_of_args = $#ARGV + 1;
  739. + print("$version, ");
  740. + die("usage: $my_name <no. of digits>") unless($no_of_args == 1);
  741. + $digits = int($ARGV[0]);
  742. + die("no. of digits out of range [$smin\..$smax]")
  743. +                 unless(($digits >= $smin) && ($digits <= $smax));
  744. + do the_job($digits);
  745. + exit 0;
  746. + 
  747. + # That's all ----------------------------------------------------------------
  748.  
  749. Index: pstruct
  750. *** pstruct.old    Mon Jun  8 17:51:29 1992
  751. --- pstruct    Mon Jun  8 17:51:30 1992
  752. ***************
  753. *** 0 ****
  754. --- 1,1071 ----
  755. + #!/usr/local/bin/perl
  756. + #
  757. + #
  758. + #   c2ph (aka pstruct)
  759. + #   Tom Christiansen, <tchrist@convex.com>
  760. + #   
  761. + #   As pstruct, dump C structures as generated from 'cc -g -S' stabs.
  762. + #   As c2ph, do this PLUS generate perl code for getting at the structures.
  763. + #
  764. + #   See the usage message for more.  If this isn't enough, read the code.
  765. + #
  766. + 
  767. + $RCSID = '$RCSfile: pstruct,v $$Revision: 4.0.1.1 $$Date: 92/06/08 15:19:40 $';
  768. + 
  769. + 
  770. + ######################################################################
  771. + 
  772. + # some handy data definitions.   many of these can be reset later.
  773. + 
  774. + $bitorder = 'b';  # ascending; set to B for descending bit fields
  775. + 
  776. + %intrinsics = 
  777. + %template = (
  778. +     'char',             'c',
  779. +     'unsigned char',         'C',
  780. +     'short',            's',
  781. +     'short int',        's',
  782. +     'unsigned short',        'S',
  783. +     'unsigned short int',    'S',
  784. +     'short unsigned int',    'S',
  785. +     'int',            'i',
  786. +     'unsigned int',        'I',
  787. +     'long',            'l',
  788. +     'long int',            'l',
  789. +     'unsigned long',        'L',
  790. +     'unsigned long',        'L',
  791. +     'long unsigned int',    'L',
  792. +     'unsigned long int',    'L',
  793. +     'long long',        'q',
  794. +     'long long int',        'q',
  795. +     'unsigned long long',    'Q',
  796. +     'unsigned long long int',    'Q',
  797. +     'float',            'f',
  798. +     'double',            'd',
  799. +     'pointer',            'p',
  800. +     'null',            'x',
  801. +     'neganull',            'X',
  802. +     'bit',            $bitorder,
  803. + ); 
  804. + 
  805. + &buildscrunchlist;
  806. + delete $intrinsics{'neganull'};
  807. + delete $intrinsics{'bit'};
  808. + delete $intrinsics{'null'};
  809. + 
  810. + # use -s to recompute sizes
  811. + %sizeof = (
  812. +     'char',             '1',
  813. +     'unsigned char',         '1',
  814. +     'short',            '2',
  815. +     'short int',        '2',
  816. +     'unsigned short',        '2',
  817. +     'unsigned short int',    '2',
  818. +     'short unsigned int',    '2',
  819. +     'int',            '4',
  820. +     'unsigned int',        '4',
  821. +     'long',            '4',
  822. +     'long int',            '4',
  823. +     'unsigned long',        '4',
  824. +     'unsigned long int',    '4',
  825. +     'long unsigned int',    '4',
  826. +     'long long',        '8',
  827. +     'long long int',        '8',
  828. +     'unsigned long long',    '8',
  829. +     'unsigned long long int',    '8',
  830. +     'float',            '4',
  831. +     'double',            '8',
  832. +     'pointer',            '4',
  833. + );
  834. + 
  835. + ($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
  836. + 
  837. + ($offset_fmt, $size_fmt) = ('d', 'd');
  838. + 
  839. + $indent = 2;
  840. + 
  841. + $CC = 'cc';
  842. + $CFLAGS = '-g -S';
  843. + $DEFINES = '';
  844. + 
  845. + $perl++ if $0 =~ m#/?c2ph$#;
  846. + 
  847. + require 'getopts.pl';
  848. + 
  849. + eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
  850. + 
  851. + &Getopts('aixdpvtnws:') || &usage(0);
  852. + 
  853. + $opt_d && $debug++;
  854. + $opt_t && $trace++;
  855. + $opt_p && $perl++;
  856. + $opt_v && $verbose++;
  857. + $opt_n && ($perl = 0);
  858. + 
  859. + if ($opt_w) {
  860. +     ($type_width, $member_width, $offset_width) = (45, 35, 8);
  861. + } 
  862. + if ($opt_x) {
  863. +     ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
  864. + }
  865. + 
  866. + eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
  867. + 
  868. + sub PLUMBER {
  869. +     select(STDERR);
  870. +     print "oops, apperent pager foulup\n";
  871. +     $isatty++;
  872. +     &usage(1);
  873. + } 
  874. + 
  875. + sub usage {
  876. +     local($oops) = @_;
  877. +     unless (-t STDOUT) {
  878. +     select(STDERR);
  879. +     } elsif (!$oops) {
  880. +     $isatty++;
  881. +     $| = 1;
  882. +     print "hit <RETURN> for further explanation: ";
  883. +     <STDIN>;
  884. +     open (PIPE, "|". ($ENV{PAGER} || 'more'));
  885. +     $SIG{PIPE} = PLUMBER;
  886. +     select(PIPE);
  887. +     } 
  888. + 
  889. +     print "usage: $0 [-dpnP] [var=val] [files ...]\n";
  890. + 
  891. +     exit unless $isatty;
  892. + 
  893. +     print <<EOF;
  894. + 
  895. + Options:
  896. + 
  897. + -w    wide; short for: type_width=45 member_width=35 offset_width=8
  898. + -x    hex; short for:  offset_fmt=x offset_width=08 size_fmt=x size_width=04
  899. + 
  900. + -n      do not generate perl code  (default when invoked as pstruct)
  901. + -p      generate perl code         (default when invoked as c2ph)
  902. + -v    generate perl code, with C decls as comments
  903. + 
  904. + -i    do NOT recompute sizes for intrinsic datatypes
  905. + -a    dump information on intrinsics also
  906. + 
  907. + -t     trace execution
  908. + -d    spew reams of debugging output
  909. + 
  910. + -slist  give comma-separated list a structures to dump
  911. + 
  912. + 
  913. + Var Name        Default Value    Meaning
  914. + 
  915. + EOF
  916. + 
  917. +     &defvar('CC', 'which_compiler to call');
  918. +     &defvar('CFLAGS', 'how to generate *.s files with stabs');
  919. +     &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
  920. + 
  921. +     print "\n";
  922. + 
  923. +     &defvar('type_width', 'width of type field   (column 1)');
  924. +     &defvar('member_width', 'width of member field (column 2)');
  925. +     &defvar('offset_width', 'width of offset field (column 3)');
  926. +     &defvar('size_width', 'width of size field   (column 4)');
  927. + 
  928. +     print "\n";
  929. + 
  930. +     &defvar('offset_fmt', 'sprintf format type for offset');
  931. +     &defvar('size_fmt', 'sprintf format type for size');
  932. + 
  933. +     print "\n";
  934. + 
  935. +     &defvar('indent', 'how far to indent each nesting level');
  936. + 
  937. +    print <<'EOF';
  938. + 
  939. +     If any *.[ch] files are given, these will be catted together into
  940. +     a temporary *.c file and sent through:
  941. +         $CC $CFLAGS $DEFINES 
  942. +     and the resulting *.s groped for stab information.  If no files are
  943. +     supplied, then stdin is read directly with the assumption that it
  944. +     contains stab information.  All other liens will be ignored.  At
  945. +     most one *.s file should be supplied.
  946. + 
  947. + EOF
  948. +     close PIPE;
  949. +     exit 1;
  950. + } 
  951. + 
  952. + sub defvar {
  953. +     local($var, $msg) = @_;
  954. +     printf "%-16s%-15s  %s\n", $var, eval "\$$var", $msg;
  955. + } 
  956. + 
  957. + $recurse = 1;
  958. + 
  959. + if (@ARGV) {
  960. +     if (grep(!/\.[csh]$/,@ARGV)) {
  961. +     warn "Only *.[csh] files expected!\n";
  962. +     &usage;
  963. +     } 
  964. +     elsif (grep(/\.s$/,@ARGV)) {
  965. +     if (@ARGV > 1) { 
  966. +         warn "Only one *.s file allowed!\n";
  967. +         &usage;
  968. +     }
  969. +     } 
  970. +     elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
  971. +     local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
  972. +     $chdir = "cd $dir; " if $dir;
  973. +     &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
  974. +     $ARGV[0] =~ s/\.c$/.s/;
  975. +     } 
  976. +     else {
  977. +     $TMP = "/tmp/c2ph.$$.c";
  978. +     &system("cat @ARGV > $TMP") && exit 1;
  979. +     &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1;
  980. +     unlink $TMP;
  981. +     $TMP =~ s/\.c$/.s/;
  982. +     @ARGV = ($TMP);
  983. +     } 
  984. + }
  985. + 
  986. + if ($opt_s) {
  987. +     for (split(/[\s,]+/, $opt_s)) {
  988. +     $interested{$_}++;
  989. +     } 
  990. + } 
  991. + 
  992. + 
  993. + $| = 1 if $debug;
  994. + 
  995. + main: {
  996. + 
  997. +     if ($trace) {
  998. +     if (-t && !@ARGV) { 
  999. +         print STDERR "reading from your keyboard: ";
  1000. +     } else {
  1001. +         print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
  1002. +     }
  1003. +     }
  1004. + 
  1005. + STAB: while (<>) {
  1006. +     if ($trace && !($. % 10)) {
  1007. +         $lineno = $..'';
  1008. +         print STDERR $lineno, "\b" x length($lineno);
  1009. +     } 
  1010. +     next unless /^\s*\.stabs\s+/;
  1011. +     $line = $_;
  1012. +     s/^\s*\.stabs\s+//; 
  1013. +     &stab; 
  1014. +     }
  1015. +     print STDERR "$.\n" if $trace;
  1016. +     unlink $TMP if $TMP;
  1017. + 
  1018. +     &compute_intrinsics if $perl && !$opt_i;
  1019. + 
  1020. +     print STDERR "resolving types\n" if $trace;
  1021. + 
  1022. +     &resolve_types;
  1023. +     &adjust_start_addrs;
  1024. + 
  1025. +     $sum = 2 + $type_width + $member_width;
  1026. +     $pmask1 = "%-${type_width}s %-${member_width}s"; 
  1027. +     $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
  1028. + 
  1029. +     if ($perl) {
  1030. +     # resolve template -- should be in stab define order, but even this isn't enough.
  1031. +     print STDERR "\nbuilding type templates: " if $trace;
  1032. +     for $i (reverse 0..$#type) {
  1033. +         next unless defined($name = $type[$i]);
  1034. +         next unless defined $struct{$name};
  1035. +         $build_recursed = 0;
  1036. +         &build_template($name) unless defined $template{&psou($name)} ||
  1037. +                     $opt_s && !$interested{$name};
  1038. +     } 
  1039. +     print STDERR "\n\n" if $trace;
  1040. +     }
  1041. + 
  1042. +     print STDERR "dumping structs: " if $trace;
  1043. + 
  1044. + 
  1045. +     foreach $name (sort keys %struct) {
  1046. +     next if $opt_s && !$interested{$name};
  1047. +     print STDERR "$name " if $trace;
  1048. + 
  1049. +     undef @sizeof;
  1050. +     undef @typedef;
  1051. +     undef @offsetof;
  1052. +     undef @indices;
  1053. +     undef @typeof;
  1054. + 
  1055. +     $mname = &munge($name);
  1056. + 
  1057. +     $fname = &psou($name);
  1058. + 
  1059. +     print "# " if $perl && $verbose;
  1060. +     $pcode = '';
  1061. +     print "$fname {\n" if !$perl || $verbose; 
  1062. +     $template{$fname} = &scrunch($template{$fname}) if $perl;
  1063. +     &pstruct($name,$name,0); 
  1064. +     print "# " if $perl && $verbose;
  1065. +     print "}\n" if !$perl || $verbose; 
  1066. +     print "\n" if $perl && $verbose;
  1067. + 
  1068. +     if ($perl) {
  1069. +         print "$pcode";
  1070. + 
  1071. +         printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
  1072. + 
  1073. +         print <<EOF;
  1074. + sub ${mname}'typedef { 
  1075. +     local(\$${mname}'index) = shift;
  1076. +     defined \$${mname}'index 
  1077. +     ? \$${mname}'typedef[\$${mname}'index] 
  1078. +     : \$${mname}'typedef;
  1079. + }
  1080. + EOF
  1081. + 
  1082. +         print <<EOF;
  1083. + sub ${mname}'sizeof { 
  1084. +     local(\$${mname}'index) = shift;
  1085. +     defined \$${mname}'index 
  1086. +     ? \$${mname}'sizeof[\$${mname}'index] 
  1087. +     : \$${mname}'sizeof;
  1088. + }
  1089. + EOF
  1090. + 
  1091. +         print <<EOF;
  1092. + sub ${mname}'offsetof { 
  1093. +     local(\$${mname}'index) = shift;
  1094. +     defined \$${mname}index 
  1095. +     ? \$${mname}'offsetof[\$${mname}'index] 
  1096. +     : \$${mname}'sizeof;
  1097. + }
  1098. + EOF
  1099. + 
  1100. +         print <<EOF;
  1101. + sub ${mname}'typeof { 
  1102. +     local(\$${mname}'index) = shift;
  1103. +     defined \$${mname}index 
  1104. +     ? \$${mname}'typeof[\$${mname}'index] 
  1105. +     : '$name';
  1106. + }
  1107. + EOF
  1108. +     
  1109. + 
  1110. +         print "\$${mname}'typedef = '" . &scrunch($template{$fname}) 
  1111. +         . "';\n";
  1112. + 
  1113. +         print "\$${mname}'sizeof = $sizeof{$name};\n\n";
  1114. + 
  1115. + 
  1116. +         print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
  1117. + 
  1118. +         print "\n";
  1119. + 
  1120. +         print "\@${mname}'typedef[\@${mname}'indices] = (",
  1121. +             join("\n\t", '', @typedef), "\n    );\n\n";
  1122. +         print "\@${mname}'sizeof[\@${mname}'indices] = (",
  1123. +             join("\n\t", '', @sizeof), "\n    );\n\n";
  1124. +         print "\@${mname}'offsetof[\@${mname}'indices] = (",
  1125. +             join("\n\t", '', @offsetof), "\n    );\n\n";
  1126. +         print "\@${mname}'typeof[\@${mname}'indices] = (",
  1127. +             join("\n\t", '', @typeof), "\n    );\n\n";
  1128. + 
  1129. +         $template_printed{$fname}++;
  1130. +         $size_printed{$fname}++;
  1131. +     } 
  1132. +     print "\n";
  1133. +     }
  1134. + 
  1135. +     print STDERR "\n" if $trace;
  1136. + 
  1137. +     unless ($perl && $opt_a) { 
  1138. +     print "\n1;\n";
  1139. +     exit;
  1140. +     }
  1141. + 
  1142. + 
  1143. + 
  1144. +     foreach $name (sort bysizevalue keys %intrinsics) {
  1145. +     next if $size_printed{$name};
  1146. +     print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
  1147. +     }
  1148. + 
  1149. +     print "\n";
  1150. + 
  1151. +     sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
  1152. + 
  1153. + 
  1154. +     foreach $name (sort keys %intrinsics) {
  1155. +     print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
  1156. +     }
  1157. + 
  1158. +     print "\n1;\n";
  1159. +     
  1160. +     exit;
  1161. + }
  1162. + 
  1163. + ########################################################################################
  1164. + 
  1165. + 
  1166. + sub stab {
  1167. +     next unless /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/;  # (\d+,\d+) is for sun
  1168. +     s/"//                         || next;
  1169. +     s/",([x\d]+),([x\d]+),([x\d]+),.*//         || next;
  1170. + 
  1171. +     next if /^\s*$/;
  1172. + 
  1173. +     $size = $3 if $3;
  1174. + 
  1175. + 
  1176. +     $line = $_;
  1177. + 
  1178. +     if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
  1179. +     print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
  1180. +     &pdecl($pdecl);
  1181. +     next;
  1182. +     }
  1183. + 
  1184. + 
  1185. + 
  1186. +     if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {  
  1187. +     local($ident) = $2;
  1188. +     push(@intrinsics, $ident);
  1189. +     $typeno = &typeno($3);
  1190. +     $type[$typeno] = $ident;
  1191. +     print STDERR "intrinsic $ident in new type $typeno\n" if $debug; 
  1192. +     next;
  1193. +     }
  1194. + 
  1195. +     if (($name, $typeordef, $typeno, $extra, $struct, $_) 
  1196. +     = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/) 
  1197. +     {
  1198. +     $typeno = &typeno($typeno);  # sun foolery
  1199. +     } 
  1200. +     elsif (/^[\$\w]+:/) {
  1201. +     next; # variable
  1202. +     }
  1203. +     else { 
  1204. +     warn "can't grok stab: <$_> in: $line " if $_;
  1205. +     next;
  1206. +     } 
  1207. + 
  1208. +     #warn "got size $size for $name\n";
  1209. +     $sizeof{$name} = $size if $size;
  1210. + 
  1211. +     s/;[-\d]*;[-\d]*;$//;  # we don't care about ranges
  1212. + 
  1213. +     $typenos{$name} = $typeno;
  1214. + 
  1215. +     unless (defined $type[$typeno]) {
  1216. +     &panic("type 0??") unless $typeno;
  1217. +     $type[$typeno] = $name unless defined $type[$typeno];
  1218. +     printf "new type $typeno is $name" if $debug;
  1219. +     if ($extra =~ /\*/ && defined $type[$struct]) {
  1220. +         print ", a typedef for a pointer to " , $type[$struct] if $debug;
  1221. +     }
  1222. +     } else {
  1223. +     printf "%s is type %d", $name, $typeno if $debug;
  1224. +     print ", a typedef for " , $type[$typeno] if $debug;
  1225. +     } 
  1226. +     print "\n" if $debug;
  1227. +     #next unless $extra =~ /[su*]/;
  1228. + 
  1229. +     #$type[$struct] = $name;
  1230. + 
  1231. +     if ($extra =~ /[us*]/) {
  1232. +     &sou($name, $extra);
  1233. +     $_ = &sdecl($name, $_, 0);
  1234. +     }
  1235. +     elsif (/^=ar/) {
  1236. +     print "it's a bare array typedef -- that's pretty sick\n" if $debug;
  1237. +     $_ = "$typeno$_";
  1238. +     $scripts = '';
  1239. +     $_ = &adecl($_,1);
  1240. + 
  1241. +     }
  1242. +     elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) {  # the ?'s are for gcc
  1243. +     push(@intrinsics, $2);
  1244. +     $typeno = &typeno($3);
  1245. +     $type[$typeno] = $2;
  1246. +     print STDERR "intrinsic $2 in new type $typeno\n" if $debug; 
  1247. +     }
  1248. +     elsif (s/^=e//) { # blessed by thy compiler; mine won't do this
  1249. +     &edecl;
  1250. +     } 
  1251. +     else {
  1252. +     warn "Funny remainder for $name on line $_ left in $line " if $_;
  1253. +     } 
  1254. + }
  1255. + 
  1256. + sub typeno {  # sun thinks types are (0,27) instead of just 27
  1257. +     local($_) = @_;
  1258. +     s/\(\d+,(\d+)\)/$1/;
  1259. +     $_;
  1260. + } 
  1261. + 
  1262. + sub pstruct {
  1263. +     local($what,$prefix,$base) = @_; 
  1264. +     local($field, $fieldname, $typeno, $count, $offset, $entry); 
  1265. +     local($fieldtype);
  1266. +     local($type, $tname); 
  1267. +     local($mytype, $mycount, $entry2);
  1268. +     local($struct_count) = 0;
  1269. +     local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
  1270. +     local($bits,$bytes);
  1271. +     local($template);
  1272. + 
  1273. + 
  1274. +     local($mname) = &munge($name);
  1275. + 
  1276. +     sub munge { 
  1277. +     local($_) = @_;
  1278. +     s/[\s\$\.]/_/g;
  1279. +     $_;
  1280. +     }
  1281. + 
  1282. +     local($sname) = &psou($what);
  1283. + 
  1284. +     $nesting++;
  1285. + 
  1286. +     for $field (split(/;/, $struct{$what})) {
  1287. +     $pad = $prepad = 0;
  1288. +     $entry = ''; 
  1289. +     ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field); 
  1290. + 
  1291. +     $type = $type[$typeno];
  1292. + 
  1293. +     $type =~ /([^[]*)(\[.*\])?/;
  1294. +     $mytype = $1;
  1295. +     $count .= $2;
  1296. +     $fieldtype = &psou($mytype);
  1297. + 
  1298. +     local($fname) = &psou($name);
  1299. + 
  1300. +     if ($build_templates) {
  1301. + 
  1302. +         $pad = ($offset - ($lastoffset + $lastlength))/8 
  1303. +         if defined $lastoffset;
  1304. + 
  1305. +         if (! $finished_template{$sname}) {
  1306. +         if ($isaunion{$what}) {
  1307. +             $template{$sname} .= 'X' x $revpad . ' '    if $revpad;
  1308. +         } else {
  1309. +             $template{$sname} .= 'x' x $pad    . ' '    if $pad;
  1310. +         }
  1311. +         }
  1312. + 
  1313. +         $template = &fetch_template($type) x 
  1314. +                 ($count ? &scripts2count($count) : 1);
  1315. + 
  1316. +         if (! $finished_template{$sname}) {
  1317. +         $template{$sname} .= $template;
  1318. +         }
  1319. + 
  1320. +         $revpad = $length/8 if $isaunion{$what};
  1321. + 
  1322. +         ($lastoffset, $lastlength) = ($offset, $length);
  1323. + 
  1324. +     } else { 
  1325. +         print '# ' if $perl && $verbose;
  1326. +         $entry = sprintf($pmask1,
  1327. +             ' ' x ($nesting * $indent) . $fieldtype,
  1328. +             "$prefix.$fieldname" . $count); 
  1329. + 
  1330. +         $entry =~ s/(\*+)( )/$2$1/; 
  1331. + 
  1332. +         printf $pmask2,
  1333. +             $entry,
  1334. +             ($base+$offset)/8,
  1335. +             ($bits = ($base+$offset)%8) ? ".$bits" : "  ",
  1336. +             $length/8,
  1337. +             ($bits = $length % 8) ? ".$bits": ""
  1338. +             if !$perl || $verbose;
  1339. + 
  1340. + 
  1341. +         if ($perl && $nesting == 1) {
  1342. +         $template = &scrunch(&fetch_template($type) x 
  1343. +                 ($count ? &scripts2count($count) : 1));
  1344. +         push(@sizeof, int($length/8) .",\t# $fieldname");
  1345. +         push(@offsetof, int($offset/8) .",\t# $fieldname");
  1346. +         push(@typedef, "'$template', \t# $fieldname");
  1347. +         $type =~ s/(struct|union) //;
  1348. +         push(@typeof, "'$type" . ($count ? $count : '') .
  1349. +             "',\t# $fieldname");
  1350. +         }
  1351. + 
  1352. +         print '  ', ' ' x $indent x $nesting, $template
  1353. +                 if $perl && $verbose;
  1354. + 
  1355. +         print "\n" if !$perl || $verbose;
  1356. + 
  1357. +     }    
  1358. +     if ($perl) {
  1359. +         local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
  1360. +         $mycount *= &scripts2count($count) if $count;
  1361. +         if ($nesting==1 && !$build_templates) {
  1362. +         $pcode .= sprintf("sub %-32s { %4d; }\n", 
  1363. +             "${mname}'${fieldname}", $struct_count);
  1364. +         push(@indices, $struct_count);
  1365. +         }
  1366. +         $struct_count += $mycount;
  1367. +     } 
  1368. + 
  1369. + 
  1370. +     &pstruct($type, "$prefix.$fieldname", $base+$offset) 
  1371. +         if $recurse && defined $struct{$type}; 
  1372. +     }
  1373. + 
  1374. +     $countof{$what} = $struct_count unless defined $countof{$whati};
  1375. + 
  1376. +     $template{$sname} .= '$' if $build_templates;
  1377. +     $finished_template{$sname}++;
  1378. + 
  1379. +     if ($build_templates && !defined $sizeof{$name}) {
  1380. +     local($fmt) = &scrunch($template{$sname});
  1381. +     print STDERR "no size for $name, punting with $fmt..." if $debug;
  1382. +     eval '$sizeof{$name} = length(pack($fmt, ()))';
  1383. +     if ($@) {
  1384. +         chop $@;
  1385. +         warn "couldn't get size for \$name: $@";
  1386. +     } else {
  1387. +         print STDERR $sizeof{$name}, "\n" if $debUg;
  1388. +     }
  1389. +     } 
  1390. + 
  1391. +     --$nesting;
  1392. + }
  1393. + 
  1394. + 
  1395. + sub psize {
  1396. +     local($me) = @_; 
  1397. +     local($amstruct) = $struct{$me} ?  'struct ' : '';
  1398. + 
  1399. +     print '$sizeof{\'', $amstruct, $me, '\'} = '; 
  1400. +     printf "%d;\n", $sizeof{$me}; 
  1401. + }
  1402. + 
  1403. + sub pdecl {
  1404. +     local($pdecl) = @_;
  1405. +     local(@pdecls);
  1406. +     local($tname);
  1407. + 
  1408. +     warn "pdecl: $pdecl\n" if $debug;
  1409. + 
  1410. +     $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
  1411. +     $pdecl =~ s/\*//g; 
  1412. +     @pdecls = split(/=/, $pdecl); 
  1413. +     $typeno = $pdecls[0];
  1414. +     $tname = pop @pdecls;
  1415. + 
  1416. +     if ($tname =~ s/^f//) { $tname = "$tname&"; } 
  1417. +     #else { $tname = "$tname*"; } 
  1418. + 
  1419. +     for (reverse @pdecls) {
  1420. +     $tname  .= s/^f// ? "&" : "*"; 
  1421. +     #$tname =~ s/^f(.*)/$1&/;
  1422. +     print "type[$_] is $tname\n" if $debug;
  1423. +     $type[$_] = $tname unless defined $type[$_];
  1424. +     } 
  1425. + }
  1426. + 
  1427. + 
  1428. + 
  1429. + sub adecl {
  1430. +     ($arraytype, $unknown, $lower, $upper) = ();
  1431. +     #local($typeno);
  1432. +     # global $typeno, @type
  1433. +     local($_, $typedef) = @_;
  1434. + 
  1435. +     while (s/^((\d+)=)?ar(\d+);//) {
  1436. +     ($arraytype, $unknown) = ($2, $3); 
  1437. +     if (s/^(\d+);(\d+);//) {
  1438. +         ($lower, $upper) = ($1, $2); 
  1439. +         $scripts .= '[' .  ($upper+1) . ']'; 
  1440. +     } else {
  1441. +         warn "can't find array bounds: $_"; 
  1442. +     } 
  1443. +     }
  1444. +     if (s/^([\d*f=]*),(\d+),(\d+);//) {
  1445. +     ($start, $length) = ($2, $3); 
  1446. +     local($whatis) = $1;
  1447. +     if ($whatis =~ /^(\d+)=/) {
  1448. +         $typeno = $1;
  1449. +         &pdecl($whatis);
  1450. +     } else {
  1451. +         $typeno = $whatis;
  1452. +     }
  1453. +     } elsif (s/^(\d+)(=[*suf]\d*)//) {
  1454. +     local($whatis) = $2; 
  1455. + 
  1456. +     if ($whatis =~ /[f*]/) {
  1457. +         &pdecl($whatis); 
  1458. +     } elsif ($whatis =~ /[su]/) {  # 
  1459. +         print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n" 
  1460. +         if $debug;
  1461. +         #$type[$typeno] = $name unless defined $type[$typeno];
  1462. +         ##printf "new type $typeno is $name" if $debug;
  1463. +         $typeno = $1;
  1464. +         $type[$typeno] = "$prefix.$fieldname";
  1465. +         local($name) = $type[$typeno];
  1466. +         &sou($name, $whatis);
  1467. +         $_ = &sdecl($name, $_, $start+$offset);
  1468. +         1;
  1469. +         $start = $start{$name};
  1470. +         $offset = $sizeof{$name};
  1471. +         $length = $offset;
  1472. +     } else {
  1473. +         warn "what's this? $whatis in $line ";
  1474. +     } 
  1475. +     } elsif (/^\d+$/) {
  1476. +     $typeno = $_;
  1477. +     } else {
  1478. +     warn "bad array stab: $_ in $line ";
  1479. +     next STAB;
  1480. +     } 
  1481. +     #local($wasdef) = defined($type[$typeno]) && $debug;
  1482. +     #if ($typedef) { 
  1483. +     #print "redefining $type[$typeno] to " if $wasdef;
  1484. +     #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
  1485. +     #print "$type[$typeno]\n" if $wasdef;
  1486. +     #} else {
  1487. +     #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
  1488. +     #}
  1489. +     $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
  1490. +     print "type[$arraytype] is $type[$arraytype]\n" if $debug;
  1491. +     print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
  1492. +     $_;
  1493. + }
  1494. + 
  1495. + 
  1496. + 
  1497. + sub sdecl {
  1498. +     local($prefix, $_, $offset) = @_;
  1499. + 
  1500. +     local($fieldname, $scripts, $type, $arraytype, $unknown,
  1501. +     $whatis, $pdecl, $upper,$lower, $start,$length) = ();
  1502. +     local($typeno,$sou);
  1503. + 
  1504. + 
  1505. + SFIELD:
  1506. +     while (/^([^;]+);/) {
  1507. +     $scripts = '';
  1508. +     warn "sdecl $_\n" if $debug;
  1509. +     if (s/^([\$\w]+)://) { 
  1510. +         $fieldname = $1;
  1511. +     } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # 
  1512. +         $typeno = &typeno($1);
  1513. +         $type[$typeno] = "$prefix.$fieldname";
  1514. +         local($name) = "$prefix.$fieldname";
  1515. +         &sou($name,$2);
  1516. +         $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
  1517. +         $start = $start{$name};
  1518. +         $offset += $sizeof{$name};
  1519. +         #print "done with anon, start is $start, offset is $offset\n";
  1520. +         #next SFIELD;
  1521. +     } else  {
  1522. +         warn "weird field $_ of $line" if $debug;
  1523. +         next STAB;
  1524. +         #$fieldname = &gensym;
  1525. +         #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
  1526. +     }
  1527. + 
  1528. +     if (/^\d+=ar/) {
  1529. +         $_ = &adecl($_);
  1530. +     }
  1531. +     elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
  1532. +         ($start, $length) =  ($2, $3); 
  1533. +         &panic("no length?") unless $length;
  1534. +         $typeno = &typeno($1) if $1;
  1535. +     }
  1536. +     elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
  1537. +         ($pdecl, $start, $length) =  ($1,$5,$6); 
  1538. +         &pdecl($pdecl); 
  1539. +     }
  1540. +     elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
  1541. +         ($typeno, $sou) = ($1, $2);
  1542. +         $typeno = &typeno($typeno);
  1543. +         if (defined($type[$typeno])) {
  1544. +         warn "now how did we get type $1 in $fieldname of $line?";
  1545. +         } else {
  1546. +         print "anon type $typeno is $prefix.$fieldname\n" if $debug;
  1547. +         $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
  1548. +         };
  1549. +         local($name) = "$prefix.$fieldname";
  1550. +         &sou($name,$sou);
  1551. +         print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
  1552. +         $type[$typeno] = "$prefix.$fieldname";
  1553. +         $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); 
  1554. +         $start = $start{$name};
  1555. +         $length = $sizeof{$name};
  1556. +     }
  1557. +     else {
  1558. +         warn "can't grok stab for $name ($_) in line $line "; 
  1559. +         next STAB; 
  1560. +     }
  1561. + 
  1562. +     &panic("no length for $prefix.$fieldname") unless $length;
  1563. +     $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
  1564. +     }
  1565. +     if (s/;\d*,(\d+),(\d+);//) {
  1566. +     local($start, $size) = ($1, $2); 
  1567. +     $sizeof{$prefix} = $size;
  1568. +     print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug; 
  1569. +     $start{$prefix} = $start; 
  1570. +     } 
  1571. +     $_;
  1572. + }
  1573. + 
  1574. + sub edecl {
  1575. +     s/;$//;
  1576. +     $enum{$name} = $_;
  1577. +     $_ = '';
  1578. + } 
  1579. + 
  1580. + sub resolve_types {
  1581. +     local($sou);
  1582. +     for $i (0 .. $#type) {
  1583. +     next unless defined $type[$i];
  1584. +     $_ = $type[$i];
  1585. +     unless (/\d/) {
  1586. +         print "type[$i] $type[$i]\n" if $debug;
  1587. +         next;
  1588. +     }
  1589. +     print "type[$i] $_ ==> " if $debug;
  1590. +     s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
  1591. +     s/^(\d+)\&/&type($1)/e; 
  1592. +     s/^(\d+)/&type($1)/e; 
  1593. +     s/(\*+)([^*]+)(\*+)/$1$3$2/;
  1594. +     s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
  1595. +     s/^(\d+)([\*\[].*)/&type($1).$2/e;
  1596. +     #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
  1597. +     $type[$i] = $_;
  1598. +     print "$_\n" if $debug;
  1599. +     }
  1600. + }
  1601. + sub type { &psou($type[$_[0]] || "<UNDEFINED>"); } 
  1602. + 
  1603. + sub adjust_start_addrs {
  1604. +     for (sort keys %start) {
  1605. +     ($basename = $_) =~ s/\.[^.]+$//;
  1606. +     $start{$_} += $start{$basename};
  1607. +     print "start: $_ @ $start{$_}\n" if $debug;
  1608. +     }
  1609. + }
  1610. + 
  1611. + sub sou {
  1612. +     local($what, $_) = @_;
  1613. +     /u/ && $isaunion{$what}++;
  1614. +     /s/ && $isastruct{$what}++;
  1615. + }
  1616. + 
  1617. + sub psou {
  1618. +     local($what) = @_;
  1619. +     local($prefix) = '';
  1620. +     if ($isaunion{$what})  {
  1621. +     $prefix = 'union ';
  1622. +     } elsif ($isastruct{$what})  {
  1623. +     $prefix = 'struct ';
  1624. +     }
  1625. +     $prefix . $what;
  1626. + }
  1627. + 
  1628. + sub scrunch {
  1629. +     local($_) = @_;
  1630. + 
  1631. +     study;
  1632. + 
  1633. +     s/\$//g;
  1634. +     s/  / /g;
  1635. +     1 while s/(\w) \1/$1$1/g;
  1636. + 
  1637. +     # i wanna say this, but perl resists my efforts:
  1638. +     #       s/(\w)(\1+)/$2 . length($1)/ge;
  1639. + 
  1640. +     &quick_scrunch;
  1641. + 
  1642. +     s/ $//;
  1643. + 
  1644. +     $_;
  1645. + }
  1646. + 
  1647. + sub buildscrunchlist {
  1648. +     $scrunch_code = "sub quick_scrunch {\n";
  1649. +     for (values %intrinsics) {
  1650. +         $scrunch_code .= "\ts/($_{2,})/'$_' . length(\$1)/ge;\n";
  1651. +     } 
  1652. +     $scrunch_code .= "}\n";
  1653. +     print "$scrunch_code" if $debug;
  1654. +     eval $scrunch_code;
  1655. +     &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
  1656. + } 
  1657. + 
  1658. + sub fetch_template {
  1659. +     local($mytype) = @_;
  1660. +     local($fmt);
  1661. +     local($count) = 1;
  1662. + 
  1663. +     &panic("why do you care?") unless $perl;
  1664. + 
  1665. +     if ($mytype =~ s/(\[\d+\])+$//) {
  1666. +     $count .= $1;
  1667. +     } 
  1668. + 
  1669. +     if ($mytype =~ /\*/) {
  1670. +     $fmt = $template{'pointer'};
  1671. +     } 
  1672. +     elsif (defined $template{$mytype}) {
  1673. +     $fmt = $template{$mytype};
  1674. +     } 
  1675. +     elsif (defined $struct{$mytype}) {
  1676. +     if (!defined $template{&psou($mytype)}) {
  1677. +         &build_template($mytype) unless $mytype eq $name;
  1678. +     } 
  1679. +     elsif ($template{&psou($mytype)} !~ /\$$/) {
  1680. +         #warn "incomplete template for $mytype\n";
  1681. +     } 
  1682. +     $fmt = $template{&psou($mytype)} || '?';
  1683. +     } 
  1684. +     else {
  1685. +     warn "unknown fmt for $mytype\n";
  1686. +     $fmt = '?';
  1687. +     } 
  1688. + 
  1689. +     $fmt x $count . ' ';
  1690. + }
  1691. + 
  1692. + sub compute_intrinsics {
  1693. +     local($TMP) = "/tmp/c2ph-i.$$.c";
  1694. +     open (TMP, ">$TMP") || die "can't open $TMP: $!";
  1695. +     select(TMP);
  1696. + 
  1697. +     print STDERR "computing intrinsic sizes: " if $trace;
  1698. + 
  1699. +     undef %intrinsics;
  1700. + 
  1701. +     print <<'EOF';
  1702. + main() {
  1703. +     char *mask = "%d %s\n";
  1704. + EOF
  1705. + 
  1706. +     for $type (@intrinsics) {
  1707. +     next if $type eq 'void';
  1708. +     print <<"EOF";
  1709. +     printf(mask,sizeof($type), "$type");
  1710. + EOF
  1711. +     } 
  1712. + 
  1713. +     print <<'EOF';
  1714. +     printf(mask,sizeof(char *), "pointer");
  1715. +     exit(0);
  1716. + }
  1717. + EOF
  1718. +     close TMP;
  1719. + 
  1720. +     select(STDOUT);
  1721. +     open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|");
  1722. +     while (<PIPE>) {
  1723. +     chop;
  1724. +     split(' ',$_,2);;
  1725. +     print "intrinsic $_[1] is size $_[0]\n" if $debug;
  1726. +     $sizeof{$_[1]} = $_[0];
  1727. +     $intrinsics{$_[1]} = $template{$_[0]};
  1728. +     } 
  1729. +     close(PIPE) || die "couldn't read intrinsics!";
  1730. +     unlink($TMP, '/tmp/a.out');
  1731. +     print STDERR "done\n" if $trace;
  1732. + } 
  1733. + 
  1734. + sub scripts2count {
  1735. +     local($_) = @_;
  1736. + 
  1737. +     s/^\[//;
  1738. +     s/\]$//;
  1739. +     s/\]\[/*/g;
  1740. +     $_ = eval;
  1741. +     &panic("$_: $@") if $@;
  1742. +     $_;
  1743. + }
  1744. + 
  1745. + sub system {
  1746. +     print STDERR "@_\n" if $trace;
  1747. +     system @_;
  1748. + } 
  1749. + 
  1750. + sub build_template { 
  1751. +     local($name) = @_;
  1752. + 
  1753. +     &panic("already got a template for $name") if defined $template{$name};
  1754. + 
  1755. +     local($build_templates) = 1;
  1756. + 
  1757. +     local($lparen) = '(' x $build_recursed;
  1758. +     local($rparen) = ')' x $build_recursed;
  1759. + 
  1760. +     print STDERR "$lparen$name$rparen " if $trace;
  1761. +     $build_recursed++;
  1762. +     &pstruct($name,$name,0);
  1763. +     print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
  1764. +     --$build_recursed;
  1765. + }
  1766. + 
  1767. + 
  1768. + sub panic {
  1769. + 
  1770. +     select(STDERR);
  1771. + 
  1772. +     print "\npanic: @_\n";
  1773. + 
  1774. +     exit 1 if $] <= 4.003;  # caller broken
  1775. + 
  1776. +     local($i,$_);
  1777. +     local($p,$f,$l,$s,$h,$a,@a,@sub);
  1778. +     for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
  1779. +     @a = @DB'args;
  1780. +     for (@a) {
  1781. +         if (/^StB\000/ && length($_) == length($_main{'_main'})) {
  1782. +         $_ = sprintf("%s",$_);
  1783. +         }
  1784. +         else {
  1785. +         s/'/\\'/g;
  1786. +         s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
  1787. +         s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
  1788. +         s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
  1789. +         }
  1790. +     }
  1791. +     $w = $w ? '@ = ' : '$ = ';
  1792. +     $a = $h ? '(' . join(', ', @a) . ')' : '';
  1793. +     push(@sub, "$w&$s$a from file $f line $l\n");
  1794. +     last if $signal;
  1795. +     }
  1796. +     for ($i=0; $i <= $#sub; $i++) {
  1797. +     last if $signal;
  1798. +     print $sub[$i];
  1799. +     }
  1800. +     exit 1;
  1801. + } 
  1802. + 
  1803. + sub squishseq {
  1804. +     local($num);
  1805. +     local($last) = -1e8;
  1806. +     local($string);
  1807. +     local($seq) = '..';
  1808. + 
  1809. +     while (defined($num = shift)) {
  1810. +         if ($num == ($last + 1)) {
  1811. +             $string .= $seq unless $inseq++;
  1812. +             $last = $num;
  1813. +             next;
  1814. +         } elsif ($inseq) {
  1815. +             $string .= $last unless $last == -1e8;
  1816. +         }
  1817. + 
  1818. +         $string .= ',' if defined $string;
  1819. +         $string .= $num;
  1820. +         $last = $num;
  1821. +         $inseq = 0;
  1822. +     }
  1823. +     $string .= $last if $inseq && $last != -e18;
  1824. +     $string;
  1825. + }
  1826.  
  1827. Index: lib/pwd.pl
  1828. Prereq: 4.0
  1829. *** lib/pwd.pl.old    Mon Jun  8 17:49:09 1992
  1830. --- lib/pwd.pl    Mon Jun  8 17:49:10 1992
  1831. ***************
  1832. *** 1,8 ****
  1833.   ;# pwd.pl - keeps track of current working directory in PWD environment var
  1834.   ;#
  1835. ! ;# $Header: pwd.pl,v 4.0 91/03/20 01:26:03 lwall Locked $
  1836.   ;#
  1837.   ;# $Log:    pwd.pl,v $
  1838.   ;# Revision 4.0  91/03/20  01:26:03  lwall
  1839.   ;# 4.0 baseline.
  1840.   ;# 
  1841. --- 1,11 ----
  1842.   ;# pwd.pl - keeps track of current working directory in PWD environment var
  1843.   ;#
  1844. ! ;# $RCSfile: pwd.pl,v $$Revision: 4.0.1.1 $$Date: 92/06/08 13:45:22 $
  1845.   ;#
  1846.   ;# $Log:    pwd.pl,v $
  1847. + ;# Revision 4.0.1.1  92/06/08  13:45:22  lwall
  1848. + ;# patch20: support added to pwd.pl to strip automounter crud
  1849. + ;# 
  1850.   ;# Revision 4.0  91/03/20  01:26:03  lwall
  1851.   ;# 4.0 baseline.
  1852.   ;# 
  1853. ***************
  1854. *** 25,33 ****
  1855.       if ($ENV{'PWD'}) {
  1856.       local($dd,$di) = stat('.');
  1857.       local($pd,$pi) = stat($ENV{'PWD'});
  1858. !     return if $di == $pi && $dd == $pd;
  1859.       }
  1860. !     chop($ENV{'PWD'} = `pwd`);
  1861.   }
  1862.   
  1863.   sub main'chdir {
  1864. --- 28,47 ----
  1865.       if ($ENV{'PWD'}) {
  1866.       local($dd,$di) = stat('.');
  1867.       local($pd,$pi) = stat($ENV{'PWD'});
  1868. !     if ($di != $pi || $dd != $pd) {
  1869. !         chop($ENV{'PWD'} = `pwd`);
  1870. !     }
  1871.       }
  1872. !     else {
  1873. !     chop($ENV{'PWD'} = `pwd`);
  1874. !     }
  1875. !     if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
  1876. !     local($pd,$pi) = stat($2);
  1877. !     local($dd,$di) = stat($1);
  1878. !     if ($di == $pi && $dd == $pd) {
  1879. !         $ENV{'PWD'}="$2$3";
  1880. !     }
  1881. !     }
  1882.   }
  1883.   
  1884.   sub main'chdir {
  1885.  
  1886. Index: t/op/readdir.t
  1887. *** t/op/readdir.t.old    Mon Jun  8 17:52:11 1992
  1888. --- t/op/readdir.t    Mon Jun  8 17:52:11 1992
  1889. ***************
  1890. *** 6,18 ****
  1891.   print "1..3\n";
  1892.   
  1893.   if (opendir(OP, "op")) { print "ok 1\n"; } else { print "not ok 1\n"; }
  1894. ! @D = grep(/^[^\.]/, readdir(OP));
  1895.   closedir(OP);
  1896.   
  1897.   if (@D > 20 && @D < 100) { print "ok 2\n"; } else { print "not ok 2\n"; }
  1898.   
  1899.   @R = sort @D;
  1900. ! @G = <op/*>;
  1901.   while (@R && @G && "op/".$R[0] eq $G[0]) {
  1902.       shift(@R);
  1903.       shift(@G);
  1904. --- 6,18 ----
  1905.   print "1..3\n";
  1906.   
  1907.   if (opendir(OP, "op")) { print "ok 1\n"; } else { print "not ok 1\n"; }
  1908. ! @D = grep(/^[^\.].*\.t$/, readdir(OP));
  1909.   closedir(OP);
  1910.   
  1911.   if (@D > 20 && @D < 100) { print "ok 2\n"; } else { print "not ok 2\n"; }
  1912.   
  1913.   @R = sort @D;
  1914. ! @G = <op/*.t>;
  1915.   while (@R && @G && "op/".$R[0] eq $G[0]) {
  1916.       shift(@R);
  1917.       shift(@G);
  1918.  
  1919. Index: atarist/test/readme
  1920. *** atarist/test/readme.old    Mon Jun  8 17:45:19 1992
  1921. --- atarist/test/readme    Mon Jun  8 17:45:19 1992
  1922. ***************
  1923. *** 0 ****
  1924. --- 1,3 ----
  1925. + this directory contain simple tests for the atariST port. to run a test
  1926. + simply enter
  1927. +     perl file
  1928.  
  1929. Index: hints/ultrix_1.sh
  1930. *** hints/ultrix_1.sh.old    Mon Jun  8 17:48:25 1992
  1931. --- hints/ultrix_1.sh    Mon Jun  8 17:48:26 1992
  1932. ***************
  1933. *** 0 ****
  1934. --- 1 ----
  1935. + ccflags="$ccflags -DULTRIX_STDIO_BOTCH"
  1936.  
  1937. *** End of Patch 30 ***
  1938. exit 0 # Just in case...
  1939.