perl 3.0 patch #38

Larry Wall lwall at jpl-devvax.JPL.NASA.GOV
Sat Nov 10 22:25:59 AEST 1990


System: perl version 3.0
Patch #: 38
Priority: 
Subject: various portability fixes
Subject: new arbitrary precision libraries from Mark Biggar
Subject: added alarm function
Subject: socket, recv, select, socketpair, setsockopt didn't eval all args
Subject: random cleanup
Subject: optimized join('',...)
Subject: printf cleaned up
Subject: -e _ was wrong if last stat failed
Subject: more msdos/os2 upgrades
Subject: temp string values are now copied less often
Subject: sort parameters are now in the right package
Subject: couldn't return from sort routine
Subject: added hooks for unexec()
Subject: array slurps are now faster and take less memory
Subject: initial revision
Subject: the debugger wouldn't stop correctly or do action routines
Subject: syslog.pl was referencing an absolute path
Subject: documented tr///cds
Subject: references to $0 produced core dumps
Subject: patterns with multiple constant strings occasionally malfed
Subject: patterns like /foo.*foo/ sped up some
Subject: patterns like /^foo.*bar/ sped up some
Subject: /[^whatever]+/ could scan past end of string
Subject: fixed a memory leakage on local(*foo)
Subject: tr was busted in metacharacters on signed char machines
Subject: sequence of s/^x//; s/x$//; could screw up malloc

Description:
	Forget the description, it's too late at night...

Fix:	From rn, say "| patch -p -N -d DIR", where DIR is your perl source
	directory.  Outside of rn, say "cd DIR; patch -p -N <thisarticle".
	If you don't have the patch program, apply the following by hand,
	or get patch (version 2.0, latest patchlevel).

	After patching:
		*** DO NOTHING--INSTALL ALL PATCHES UP THROUGH #40 FIRST ***

	If patch indicates that patchlevel is the wrong version, you may need
	to apply one or more previous patches, or the patch may already
	have been applied.  See the patchlevel.h file to find out what has or
	has not been applied.  In any event, don't continue with the patch.

	If you are missing previous patches they can be obtained from me:

	Larry Wall
	lwall at jpl-devvax.jpl.nasa.gov

	If you send a mail message of the following form it will greatly speed
	processing:

	Subject: Command
	@SH mailpatch PATH perl 3.0 LIST
		   ^ note the c

	where PATH is a return path FROM ME TO YOU either in Internet notation,
	or in bang notation from some well-known host, and LIST is the number
	of one or more patches you need, separated by spaces, commas, and/or
	hyphens.  Saying 35- says everything from 35 to the end.


	You can also get the patches via anonymous FTP from
	jpl-devvax.jpl.nasa.gov (128.149.1.143).

Index: patchlevel.h
Prereq: 37
1c1
< #define PATCHLEVEL 37
---
> #define PATCHLEVEL 38

Index: Configure
Prereq: 3.0.1.11
*** Configure.old	Sat Nov 10 02:20:57 1990
--- Configure	Sat Nov 10 02:21:14 1990
***************
*** 8,14 ****
  # and edit it to reflect your system.  Some packages may include samples
  # of config.h for certain machines, so you might look for one of those.)
  #
! # $Header: Configure,v 3.0.1.11 90/10/20 01:55:30 lwall Locked $
  #
  # Yes, you may rip this off to use in other distribution packages.
  # (Note: this Configure script was generated automatically.  Rather than
--- 8,14 ----
  # and edit it to reflect your system.  Some packages may include samples
  # of config.h for certain machines, so you might look for one of those.)
  #
! # $Header: Configure,v 3.0.1.12 90/11/10 00:57:30 lwall Locked $
  #
  # Yes, you may rip this off to use in other distribution packages.
  # (Note: this Configure script was generated automatically.  Rather than
***************
*** 1404,1409 ****
--- 1404,1412 ----
      libc="$1"
  elif test -f $libc; then
      echo "Your C library is in $libc, like you said before."
+     if test $libc = "/lib/libc"; then
+ 	libc="$libc /lib/clib"
+     fi
  elif test -f /lib/libc.a; then
      echo "Your C library is in /lib/libc.a.  You're normal."
      libc=/lib/libc.a
***************
*** 1449,1455 ****
  set `echo $libc $libnames | tr ' ' '\012' | sort | uniq`
  $echo $n "Extracting names from $* for later perusal...$c"
  nm $* 2>/dev/null >libc.tmp
! $sed -n -e 's/^.* [ATD]  *_[_.]*//p' -e 's/^.* [ATD] //p' <libc.tmp >libc.list
  if $contains '^printf$' libc.list >/dev/null 2>&1; then
      echo "done"
  else
--- 1452,1458 ----
  set `echo $libc $libnames | tr ' ' '\012' | sort | uniq`
  $echo $n "Extracting names from $* for later perusal...$c"
  nm $* 2>/dev/null >libc.tmp
! $sed -n -e 's/^.* [ATDS]  *_[_.]*//p' -e 's/^.* [ATDS] //p' <libc.tmp >libc.list
  if $contains '^printf$' libc.list >/dev/null 2>&1; then
      echo "done"
  else

Index: MANIFEST
*** MANIFEST.old	Sat Nov 10 02:21:33 1990
--- MANIFEST	Sat Nov 10 02:21:36 1990
***************
*** 85,90 ****
--- 85,93 ----
  hash.h			Public declarations for the above
  ioctl.pl		Sample ioctl.pl
  lib/abbrev.pl		An abbreviation table builder
+ lib/bigfloat.pl		An arbitrary precision floating point package
+ lib/bigint.pl		An arbitrary precision integer arithmetic package
+ lib/bigrat.pl		An arbitrary precision rational arithmetic package
  lib/cacheout.pl		Manages output filehandles when you need too many
  lib/complete.pl		A command completion subroutine
  lib/ctime.pl		A ctime workalike
***************
*** 132,137 ****
--- 135,141 ----
  os2/perl.bad		names of protect-only API calls for BIND
  os2/perl.cs		Compiler script for perl
  os2/perl.def		Linker defs for perl
+ os2/perldb.dif		Changes to make the debugger work
  os2/perlglob.cs		Compiler script for perlglob
  os2/perlglob.def	Linker defs for perlglob
  os2/perlsh.cmd		Poor man's shell for os2
***************
*** 184,189 ****
--- 188,194 ----
  t/io.pipe		See if secure pipes work
  t/io.print		See if print commands work
  t/io.tell		See if file seeking works
+ t/lib.big		See if lib/bigint.pl works
  t/op.append		See if . works
  t/op.array		See if array operations work
  t/op.auto		See if autoincrement et all work
***************
*** 257,259 ****
--- 262,265 ----
  x2p/util.c		Utility routines
  x2p/util.h		Public declarations for the above
  x2p/walk.c		Parse tree walker
+ config_h.SH	Produces config.h.

Index: Makefile.SH
Prereq: 3.0.1.10
*** Makefile.SH.old	Sat Nov 10 01:26:16 1990
--- Makefile.SH	Sat Nov 10 01:26:18 1990
***************
*** 25,33 ****
  
  echo "Extracting Makefile (with variable substitutions)"
  cat >Makefile <<!GROK!THIS!
! # $Header: Makefile.SH,v 3.0.1.10 90/10/20 01:59:21 lwall Locked $
  #
  # $Log:	Makefile.SH,v $
  # Revision 3.0.1.10  90/10/20  01:59:21  lwall
  # patch37: added cryptlib support to Makefile
  # 
--- 25,36 ----
  
  echo "Extracting Makefile (with variable substitutions)"
  cat >Makefile <<!GROK!THIS!
! # $Header: Makefile.SH,v 3.0.1.11 90/11/10 01:25:51 lwall Locked $
  #
  # $Log:	Makefile.SH,v $
+ # Revision 3.0.1.11  90/11/10  01:25:51  lwall
+ # patch38: new arbitrary precision libraries from Mark Biggar
+ # 
  # Revision 3.0.1.10  90/10/20  01:59:21  lwall
  # patch37: added cryptlib support to Makefile
  # 
***************
*** 377,383 ****
  	cd x2p; $(MAKE) depend
  
  test: perl
! 	- chmod +x t/TEST t/base.* t/comp.* t/cmd.* t/io.* t/op.*; \
  	cd t && (rm -f perl; $(SLN) ../perl .) && ./perl TEST
  
  clist:
--- 380,386 ----
  	cd x2p; $(MAKE) depend
  
  test: perl
! 	- chmod +x t/TEST t/base.* t/comp.* t/cmd.* t/io.* t/op.* t/lib.*; \
  	cd t && (rm -f perl; $(SLN) ../perl .) && ./perl TEST
  
  clist:

Index: x2p/Makefile.SH
Prereq: 3.0.1.6
*** x2p/Makefile.SH.old	Sat Nov 10 02:39:10 1990
--- x2p/Makefile.SH	Sat Nov 10 02:39:17 1990
***************
*** 18,26 ****
  esac
  echo "Extracting x2p/Makefile (with variable substitutions)"
  cat >Makefile <<!GROK!THIS!
! # $Header: Makefile.SH,v 3.0.1.6 90/10/16 11:28:18 lwall Locked $
  #
  # $Log:	Makefile.SH,v $
  # Revision 3.0.1.6  90/10/16  11:28:18  lwall
  # patch29: various portability fixes
  # 
--- 18,29 ----
  esac
  echo "Extracting x2p/Makefile (with variable substitutions)"
  cat >Makefile <<!GROK!THIS!
! # $Header: Makefile.SH,v 3.0.1.7 90/11/10 02:20:15 lwall Locked $
  #
  # $Log:	Makefile.SH,v $
+ # Revision 3.0.1.7  90/11/10  02:20:15  lwall
+ # patch38: random cleanup
+ # 
  # Revision 3.0.1.6  90/10/16  11:28:18  lwall
  # patch29: various portability fixes
  # 
***************
*** 138,147 ****
  fi
  
  clean:
! 	rm -f *.o
  
  realclean: clean
! 	rm -f a2p *.orig */*.orig core $(addedbyconf) a2p.c s2p all
  
  # The following lint has practically everything turned on.  Unfortunately,
  # you have to wade through a lot of mumbo jumbo that can't be suppressed.
--- 141,150 ----
  fi
  
  clean:
! 	rm -f a2p *.o
  
  realclean: clean
! 	rm -f *.orig */*.orig core $(addedbyconf) a2p.c s2p all
  
  # The following lint has practically everything turned on.  Unfortunately,
  # you have to wade through a lot of mumbo jumbo that can't be suppressed.

Index: README
*** README.old	Sat Nov 10 02:21:48 1990
--- README	Sat Nov 10 02:21:52 1990
***************
*** 102,114 ****
      SGI machines may need -Ddouble="long float".
      Ultrix (2.3) may need to hand assemble teval.s with a -J switch.
      Ultrix on MIPS machines may need -DLANGUAGE_C.
      MIPS machines may need to turn off -O on perly.c and tperly.c.
      SCO Xenix may need -m25000 for yacc.
!     Xenix 386 needs -Sm10000 for yacc.
      Genix needs to use libc rather than libc_s, or #undef VARARGS.
      NCR Tower 32 (OS 2.01.01) may need -W2,-Sl,2000 and #undef MKDIR.
      A/UX may need -ZP -DPOSIX, and -g if big cc is used.
      FPS machines may need -J and -DBADSWITCH.
      If you get syntax errors on '(', try -DCRIPPLED_CC or -DBADSWITCH or both.
      Machines with half-implemented dbm routines will need to #undef ODBM & NDBM.
      C's that don't try to restore registers on longjmp() may need -DJMPCLOBBER.
--- 102,118 ----
      SGI machines may need -Ddouble="long float".
      Ultrix (2.3) may need to hand assemble teval.s with a -J switch.
      Ultrix on MIPS machines may need -DLANGUAGE_C.
+     Ultrix 3.[01] on MIPS needs to undefine WAITPID--the system call is busted.
+     MIPS machines may need to undef d_volatile.
      MIPS machines may need to turn off -O on perly.c and tperly.c.
+     Some MIPS machines may need to undefine CASTNEGFLOAT.
      SCO Xenix may need -m25000 for yacc.
!     Xenix 386 needs -Sm11000 for yacc, and may need -UM_I86.
      Genix needs to use libc rather than libc_s, or #undef VARARGS.
      NCR Tower 32 (OS 2.01.01) may need -W2,-Sl,2000 and #undef MKDIR.
      A/UX may need -ZP -DPOSIX, and -g if big cc is used.
      FPS machines may need -J and -DBADSWITCH.
+     UTS may need one or more of -DCRIPPLED_CC, -K or -g, and undef LSTAT.
      If you get syntax errors on '(', try -DCRIPPLED_CC or -DBADSWITCH or both.
      Machines with half-implemented dbm routines will need to #undef ODBM & NDBM.
      C's that don't try to restore registers on longjmp() may need -DJMPCLOBBER.

Index: os2/README.OS2
*** os2/README.OS2.old	Sat Nov 10 02:29:05 1990
--- os2/README.OS2	Sat Nov 10 02:29:08 1990
***************
*** 336,341 ****
--- 336,342 ----
  makefile          Makefile, not tested
  
  perlsh.cmd        the converted perlsh
+ perldb.dif        changes required for perldb.pl (change for your needs)
  selfrun.cmd       sample selfrunning perl script for OS/2
  selfrun.bat       sample selfrunning perl script for DOS mode
  
***************
*** 353,356 ****
                                  rommel at lan.informatik.tu-muenchen.dbp.de
                                  Breslauer Str. 25
                                  D-8756 Kahl/Main
!                                 West (yes, still!) Germany
--- 354,381 ----
                                  rommel at lan.informatik.tu-muenchen.dbp.de
                                  Breslauer Str. 25
                                  D-8756 Kahl/Main
!   
! + I have verified with patchlevel 37, that the OS/2 port compiles,
!   after doing two minor changes. HPFS filenames support was also added.
!   Some bugs were fixed.
! + To compile,
!   - you need the bison parser generator
!   - copy config.h from os2 into the main perl directory (important !)
!   - copy perl.cs and perlglob.cs from the os2 subdir to the main dir
!   - copy a2p.cs from os2 to x2p
!   - say "bison -d perl.y"
!       "ren perl_tab.c perl.c" and
!       "ren perl_tab.h perly.h"	in the main directory
!   - say "cs perl" and
!       "cs perlglob" in the main directory
!   - say "cs a2p" in the x2p subdir
! + If you don't have CS or don't want to use it, you have to
!   construct a makefile ...
! + If you have GNU gdbm, you can define NDBM in config.h and link with a
!   large model library of gdbm.
! + I am not shure if I can verify the OS/2 port with each release
!   from Larry Wall. Therefore, in future releases there may be
!   changes required to compile perl for OS/2.
!  				October 1990
! 				Kai Uwe Rommel
! 				rommel at lan.informatik.tu-muenchen.dbp.de

Index: t/TEST
Prereq: 3.0.1.1
*** t/TEST.old	Sat Nov 10 02:36:58 1990
--- t/TEST	Sat Nov 10 02:37:00 1990
***************
*** 1,6 ****
  #!./perl
  
! # $Header: TEST,v 3.0.1.1 89/11/11 04:58:01 lwall Locked $
  
  # This is written in a peculiar style, since we're trying to avoid
  # most of the constructs we'll be testing for.
--- 1,6 ----
  #!./perl
  
! # $Header: TEST,v 3.0.1.2 90/11/10 02:09:07 lwall Locked $
  
  # This is written in a peculiar style, since we're trying to avoid
  # most of the constructs we'll be testing for.
***************
*** 15,25 ****
  chdir 't' if -f 't/TEST';
  
  if ($ARGV[0] eq '') {
!     @ARGV = split(/[ \n]/,`echo base.* comp.* cmd.* io.* op.*`);
  }
  
! open(config,"../config.sh");
! while (<config>) {
      if (/sharpbang='(.*)'/) {
  	$sharpbang = ($1 eq '#!');
  	last;
--- 15,25 ----
  chdir 't' if -f 't/TEST';
  
  if ($ARGV[0] eq '') {
!     @ARGV = split(/[ \n]/,`echo base.* comp.* cmd.* io.* op.* lib.*`);
  }
  
! open(CONFIG,"../config.sh");
! while (<CONFIG>) {
      if (/sharpbang='(.*)'/) {
  	$sharpbang = ($1 eq '#!');
  	last;

Index: os2/a2p.cs
*** os2/a2p.cs.old	Sat Nov 10 02:29:16 1990
--- os2/a2p.cs	Sat Nov 10 02:29:17 1990
***************
*** 2,8 ****
  (-W1 -Od -Ocgelt hash.c str.c util.c walk.c)
  
  setargv.obj
! a2p.def
  a2p.exe
  
  -AL -LB -S0xA000
--- 2,8 ----
  (-W1 -Od -Ocgelt hash.c str.c util.c walk.c)
  
  setargv.obj
! ..\os2\a2p.def
  a2p.exe
  
  -AL -LB -S0xA000

Index: arg.h
Prereq: 3.0.1.7
*** arg.h.old	Sat Nov 10 02:22:08 1990
--- arg.h	Sat Nov 10 02:22:16 1990
***************
*** 1,4 ****
! /* $Header: arg.h,v 3.0.1.7 90/10/15 14:53:59 lwall Locked $
   *
   *    Copyright (c) 1989, Larry Wall
   *
--- 1,4 ----
! /* $Header: arg.h,v 3.0.1.8 90/11/10 01:04:36 lwall Locked $
   *
   *    Copyright (c) 1989, Larry Wall
   *
***************
*** 6,11 ****
--- 6,15 ----
   *    as specified in the README file that comes with the perl 3.0 kit.
   *
   * $Log:	arg.h,v $
+  * Revision 3.0.1.8  90/11/10  01:04:36  lwall
+  * patch38: added alarm function
+  * patch38: socket, recv, select, socketpair, setsockopt didn't eval all args
+  * 
   * Revision 3.0.1.7  90/10/15  14:53:59  lwall
   * patch29: added SysV IPC
   * patch29: added waitpid
***************
*** 310,316 ****
  #define O_FTATIME 264
  #define O_FTCTIME 265
  #define O_WAITPID 266
! #define MAXO 267
  
  #ifndef DOINIT
  extern char *opname[];
--- 314,321 ----
  #define O_FTATIME 264
  #define O_FTCTIME 265
  #define O_WAITPID 266
! #define O_ALARM 267
! #define MAXO 268
  
  #ifndef DOINIT
  extern char *opname[];
***************
*** 583,589 ****
      "FTATIME",
      "FTCTIME",
      "WAITPID",
!     "264"
  };
  #endif
  
--- 588,595 ----
      "FTATIME",
      "FTCTIME",
      "WAITPID",
!     "ALARM",
!     "268"
  };
  #endif
  
***************
*** 889,903 ****
  	A(0,0,0),	/* DUMP */
  	A(0,3,0),	/* REVERSE */
  	A(1,0,0),	/* ADDROF */
! 	A(1,1,1),	/* SOCKET */
  	A(1,1,0),	/* BIND */
  	A(1,1,0),	/* CONNECT */
  	A(1,1,0),	/* LISTEN */
  	A(1,1,0),	/* ACCEPT */
  	A(1,1,3),	/* SEND */
! 	A(1,1,3),	/* RECV */
! 	A(1,1,1),	/* SSELECT */
! 	A(1,1,1),	/* SOCKPAIR */
  	A(0,3,0),	/* DBSUBR */
  	A(1,0,0),	/* DEFINED */
  	A(1,0,0),	/* UNDEF */
--- 895,909 ----
  	A(0,0,0),	/* DUMP */
  	A(0,3,0),	/* REVERSE */
  	A(1,0,0),	/* ADDROF */
! 	A5(1,1,1,1,0),	/* SOCKET */
  	A(1,1,0),	/* BIND */
  	A(1,1,0),	/* CONNECT */
  	A(1,1,0),	/* LISTEN */
  	A(1,1,0),	/* ACCEPT */
  	A(1,1,3),	/* SEND */
! 	A5(1,1,1,1,0),	/* RECV */
! 	A5(1,1,1,1,0),	/* SSELECT */
! 	A5(1,1,1,1,1),	/* SOCKPAIR */
  	A(0,3,0),	/* DBSUBR */
  	A(1,0,0),	/* DEFINED */
  	A(1,0,0),	/* UNDEF */
***************
*** 952,958 ****
  	A(0,0,0),	/* GETLOGIN */
  	A(1,3,0),	/* SYSCALL */
  	A(1,1,1),	/* GSOCKOPT */
! 	A(1,1,1),	/* SSOCKOPT */
  	A(1,0,0),	/* GETSOCKNAME */
  	A(1,0,0),	/* GETPEERNAME */
  	A(0,3,3),	/* LSLICE */
--- 958,964 ----
  	A(0,0,0),	/* GETLOGIN */
  	A(1,3,0),	/* SYSCALL */
  	A(1,1,1),	/* GSOCKOPT */
! 	A5(1,1,1,1,0),	/* SSOCKOPT */
  	A(1,0,0),	/* GETSOCKNAME */
  	A(1,0,0),	/* GETPEERNAME */
  	A(0,3,3),	/* LSLICE */
***************
*** 981,986 ****
--- 987,993 ----
  	A(1,0,0),	/* FTATIME */
  	A(1,0,0),	/* FTCTIME */
  	A(1,1,0),	/* WAITPID */
+ 	A(1,0,0),	/* ALARM */
  	0
  };
  #undef A

Index: lib/bigfloat.pl
*** lib/bigfloat.pl.old	Sat Nov 10 02:27:54 1990
--- lib/bigfloat.pl	Sat Nov 10 02:27:56 1990
***************
*** 0 ****
--- 1,236 ----
+ package bigfloat;
+ require "bigint.pl";
+ 
+ # Arbitrary length float math package
+ #
+ # number format
+ #   canonical strings have the form /[+-]\d+E[+-]\d+/
+ #   Input values can have inbedded whitespace
+ # Error returns
+ #   'NaN'           An input parameter was "Not a Number" or 
+ #                       divide by zero or sqrt of negative number
+ # Division is computed to 
+ #   max($div_scale,length(dividend).length(divisor)) 
+ #   digits by default.
+ # Also used for default sqrt scale
+ 
+ $div_scale = 40;
+ 
+ # Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'.
+ 
+ $rnd_mode = 'even';
+ 
+ #   bigfloat routines
+ #
+ #   fadd(NSTR, NSTR) return NSTR            addition
+ #   fsub(NSTR, NSTR) return NSTR            subtraction
+ #   fmul(NSTR, NSTR) return NSTR            multiplication
+ #   fdiv(NSTR, NSTR[,SCALE]) returns NSTR   division to SCALE places
+ #   fneg(NSTR) return NSTR                  negation
+ #   fabs(NSTR) return NSTR                  absolute value
+ #   fcmp(NSTR,NSTR) return CODE             compare undef,<0,=0,>0
+ #   fround(NSTR, SCALE) return NSTR         round to SCALE digits
+ #   ffround(NSTR, SCALE) return NSTR        round at SCALEth place
+ #   fnorm(NSTR) return (NSTR)               normalize
+ #   fsqrt(NSTR[, SCALE]) return NSTR        sqrt to SCALE places
+ 
+ # Convert a number to canonical string form.
+ #   Takes something that looks like a number and converts it to
+ #   the form /^[+-]\d+E[+-]\d+$/.
+ sub main'fnorm { #(string) return fnum_str
+     local($_) = @_;
+     s/\s+//g;                               # strip white space
+     if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ && "$2$4" ne '') {
+ 	&norm(($1 ? "$1$2$4" : "+$2$4"),(($4 ne '') ? $6-length($4) : $6));
+     } else {
+ 	'NaN';
+     }
+ }
+ 
+ # normalize number -- for internal use
+ sub norm { #(mantissa, exponent) return fnum_str
+     local($_, $exp) = @_;
+     if ($_ eq 'NaN') {
+ 	'NaN';
+     } else {
+ 	s/^([+-])0+/$1/;                        # strip leading zeros
+ 	if (length($_) == 1) {
+ 	    '+0E+0';
+ 	} else {
+ 	    $exp += length($1) if (s/(0+)$//);  # strip trailing zeros
+ 	    sprintf("%sE%+ld", $_, $exp);
+ 	}
+     }
+ }
+ 
+ # negation
+ sub main'fneg { #(fnum_str) return fnum_str
+     local($_) = &'fnorm($_[0]);
+     substr($_,0,1) =~ tr/+-/-+/ if ($_ ne '+0E+0'); # flip sign
+     $_;
+ }
+ 
+ # absolute value
+ sub main'fabs { #(fnum_str) return fnum_str
+     local($_) = &'fnorm($_[0]);
+     substr($_,0,1) = '+';                       # mash sign
+     $_;
+ }
+ 
+ # multiplication
+ sub main'fmul { #(fnum_str, fnum_str) return fnum_str
+     local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
+     if ($x eq 'NaN' || $y eq 'NaN') {
+ 	'NaN';
+     } else {
+ 	local($xm,$xe) = split('E',$x);
+ 	local($ym,$ye) = split('E',$y);
+ 	&norm(&'bmul($xm,$ym),$xe+$ye);
+     }
+ }
+ 
+ # addition
+ sub main'fadd { #(fnum_str, fnum_str) return fnum_str
+     local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
+     if ($x eq 'NaN' || $y eq 'NaN') {
+ 	'NaN';
+     } else {
+ 	local($xm,$xe) = split('E',$x);
+ 	local($ym,$ye) = split('E',$y);
+ 	($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye);
+ 	&norm(&'badd($ym,$xm.('0' x ($xe-$ye))),$ye);
+     }
+ }
+ 
+ # subtraction
+ sub main'fsub { #(fnum_str, fnum_str) return fnum_str
+     &'fadd($_[0],&'fneg($_[1]));    
+ }
+ 
+ # division
+ #   args are dividend, divisor, scale (optional)
+ #   result has at most max(scale, length(dividend), length(divisor)) digits
+ sub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str
+ {
+     local($x,$y,$scale) = (&'fnorm($_[0]),&'fnorm($_[1]),$_[2]);
+     if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') {
+ 	'NaN';
+     } else {
+ 	local($xm,$xe) = split('E',$x);
+ 	local($ym,$ye) = split('E',$y);
+ 	$scale = $div_scale if (!$scale);
+ 	$scale = length($xm)-1 if (length($xm)-1 > $scale);
+ 	$scale = length($ym)-1 if (length($ym)-1 > $scale);
+ 	$scale = $scale + length($ym) - length($xm);
+ 	&norm(&round(&'bdiv($xm.('0' x $scale),$ym),$ym),
+ 	    $xe-$ye-$scale);
+     }
+ }
+ 
+ # round int $q based on fraction $r/$base using $rnd_mode
+ sub round { #(int_str, int_str, int_str) return int_str
+     local($q,$r,$base) = @_;
+     if ($q eq 'NaN' || $r eq 'NaN') {
+ 	'NaN';
+     } elsif ($rnd_mode eq 'trunc') {
+ 	$q;                         # just truncate
+     } else {
+ 	local($cmp) = &'bcmp(&'bmul($r,'+2'),$base);
+ 	if ( $cmp < 0 ||
+ 		 ($cmp == 0 &&
+ 		  ( $rnd_mode eq 'zero'                             ||
+ 		   ($rnd_mode eq '-inf' && (substr($q,0,1) eq '+')) ||
+ 		   ($rnd_mode eq '+inf' && (substr($q,0,1) eq '-')) ||
+ 		   ($rnd_mode eq 'even' && $q =~ /[24680]$/)        ||
+ 		   ($rnd_mode eq 'odd'  && $q =~ /[13579]$/)        )) ) {
+ 	    $q;                     # round down
+ 	} else {
+ 	    &'badd($q, ((substr($q,0,1) eq '-') ? '-1' : '+1'));
+ 				    # round up
+ 	}
+     }
+ }
+ 
+ # round the mantissa of $x to $scale digits
+ sub main'fround { #(fnum_str, scale) return fnum_str
+     local($x,$scale) = (&'fnorm($_[0]),$_[1]);
+     if ($x eq 'NaN' || $scale <= 0) {
+ 	$x;
+     } else {
+ 	local($xm,$xe) = split('E',$x);
+ 	if (length($xm)-1 <= $scale) {
+ 	    $x;
+ 	} else {
+ 	    &norm(&round(substr($xm,0,$scale+1),
+ 			 "+0".substr($xm,$scale+1,1),"+10"),
+ 		  $xe+length($xm)-$scale-1);
+ 	}
+     }
+ }
+ 
+ # round $x at the 10 to the $scale digit place
+ sub main'ffround { #(fnum_str, scale) return fnum_str
+     local($x,$scale) = (&'fnorm($_[0]),$_[1]);
+     if ($x eq 'NaN') {
+ 	'NaN';
+     } else {
+ 	local($xm,$xe) = split('E',$x);
+ 	if ($xe >= $scale) {
+ 	    $x;
+ 	} else {
+ 	    $xe = length($xm)+$xe-$scale;
+ 	    if ($xe < 1) {
+ 		'+0E+0';
+ 	    } elsif ($xe == 1) {
+ 		&norm(&round('+0',"+0".substr($xm,1,1),"+10"), $scale);
+ 	    } else {
+ 		&norm(&round(substr($xm,0,$trunc),
+ 		      "+0".substr($xm,$trunc,1),"+10"), $scale);
+ 	    }
+ 	}
+     }
+ }
+     
+ # compare 2 values returns one of undef, <0, =0, >0
+ #   returns undef if either or both input value are not numbers
+ sub main'fcmp #(fnum_str, fnum_str) return cond_code
+ {
+     local($x, $y) = (&'fnorm($_[0]),&'fnorm($_[1]));
+     if ($x eq "NaN" || $y eq "NaN") {
+ 	undef;
+     } elsif ($x eq $y) {
+ 	0;
+     } elsif (ord($x) != ord($y)) {
+ 	(ord($y) - ord($x));                # based on signs
+     } else {
+ 	local($xm,$xe) = split('E',$x);
+ 	local($ym,$ye) = split('E',$y);
+ 	if ($xe ne $ye) {
+ 	    ($xe - $ye) * (substr($x,0,1).'1');
+ 	} else {
+ 	    &bigint'cmp($xm,$ym);           # based on value
+ 	}
+     }
+ }
+ 
+ # square root by Newtons method.
+ sub main'fsqrt { #(fnum_str[, scale]) return fnum_str
+     local($x, $scale) = (&'fnorm($_[0]), $_[1]);
+     if ($x eq 'NaN' || $x =~ /^-/) {
+ 	'NaN';
+     } elsif ($x eq '+0E+0') {
+ 	'+0E+0';
+     } else {
+ 	local($xm, $xe) = split('E',$x);
+ 	$scale = $div_scale if (!$scale);
+ 	$scale = length($xm)-1 if ($scale < length($xm)-1);
+ 	local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2));
+ 	while ($gs < 2*$scale) {
+ 	    $guess = &'fmul(&'fadd($guess,&'fdiv($x,$guess,$gs*2)),".5");
+ 	    $gs *= 2;
+ 	}
+ 	&'fround($guess, $scale);
+     }
+ }
+ 
+ 1;

Index: lib/bigint.pl
*** lib/bigint.pl.old	Sat Nov 10 02:28:02 1990
--- lib/bigint.pl	Sat Nov 10 02:28:06 1990
***************
*** 0 ****
--- 1,275 ----
+ package bigint;
+ 
+ # arbitrary size integer math package
+ #
+ # by Mark Biggar
+ #
+ # Canonical Big integer value are strings of the form
+ #       /^[+-]\d+$/ with leading zeros suppressed
+ # Input values to these routines may be strings of the form
+ #       /^\s*[+-]?[\d\s]+$/.
+ # Examples:
+ #   '+0'                            canonical zero value
+ #   '   -123 123 123'               canonical value '-123123123'
+ #   '1 23 456 7890'                 canonical value '+1234567890'
+ # Output values always always in canonical form
+ #
+ # Actual math is done in an internal format consisting of an array
+ #   whose first element is the sign (/^[+-]$/) and whose remaining 
+ #   elements are base 100000 digits with the least significant digit first.
+ # The string 'NaN' is used to represent the result when input arguments 
+ #   are not numbers, as well as the result of dividing by zero
+ #
+ # routines provided are:
+ #
+ #   bneg(BINT) return BINT              negation
+ #   babs(BINT) return BINT              absolute value
+ #   bcmp(BINT,BINT) return CODE         compare numbers (undef,<0,=0,>0)
+ #   badd(BINT,BINT) return BINT         addition
+ #   bsub(BINT,BINT) return BINT         subtraction
+ #   bmul(BINT,BINT) return BINT         multiplication
+ #   bdiv(BINT,BINT) return (BINT,BINT)  division (quo,rem) just quo if scalar
+ #   bmod(BINT,BINT) return BINT         modulus
+ #   bgcd(BINT,BINT) return BINT         greatest common divisor
+ #   bnorm(BINT) return BINT             normalization
+ #
+ 
+ # normalize string form of number.   Strip leading zeros.  Strip any
+ #   white space and add a sign, if missing.
+ # Strings that are not numbers result the value 'NaN'.
+ sub main'bnorm { #(num_str) return num_str
+     local($_) = @_;
+     s/\s+//g;                           # strip white space
+     if (s/^([+-]?)0*(\d+)$/$1$2/) {     # test if number
+ 	substr($_,0,0) = '+' unless $1; # Add missing sign
+ 	s/^-0/+0/;
+ 	$_;
+     } else {
+ 	'NaN';
+     }
+ }
+ 
+ # Convert a number from string format to internal base 100000 format.
+ #   Assumes normalized value as input.
+ sub internal { #(num_str) return int_num_array
+     local($d) = @_;
+     ($is,$il) = (substr($d,0,1),length($d)-2);
+     substr($d,0,1) = '';
+     ($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d)));
+ }
+ 
+ # Convert a number from internal base 100000 format to string format.
+ #   This routine scribbles all over input array.
+ sub external { #(int_num_array) return num_str
+     $es = shift;
+     grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_);   # zero pad
+     &'bnorm(join('', $es, reverse(@_)));    # reverse concat and normalize
+ }
+ 
+ # Negate input value.
+ sub main'bneg { #(num_str) return num_str
+     local($_) = &'bnorm(@_);
+     vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0';
+     s/^H/N/;
+     $_;
+ }
+ 
+ # Returns the absolute value of the input.
+ sub main'babs { #(num_str) return num_str
+     &abs(&'bnorm(@_));
+ }
+ 
+ sub abs { # post-normalized abs for internal use
+     local($_) = @_;
+     s/^-/+/;
+     $_;
+ }
+ 
+ # Compares 2 values.  Returns one of undef, <0, =0, >0. (suitable for sort)
+ sub main'bcmp { #(num_str, num_str) return cond_code
+     local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1]));
+     if ($x eq 'NaN') {
+ 	undef;
+     } elsif ($y eq 'NaN') {
+ 	undef;
+     } else {
+ 	&cmp($x,$y);
+     }
+ }
+ 
+ sub cmp { # post-normalized compare for internal use
+     local($cx, $cy) = @_;
+     $cx cmp $cy
+     &&
+     (
+ 	ord($cy) <=> ord($cx)
+ 	||
+ 	($cx cmp ',') * (length($cy) <=> length($cx) || $cy cmp $cx)
+     );
+ }
+ 
+ sub main'badd { #(num_str, num_str) return num_str
+     local(*x, *y); ($x, $y) = (&'bnorm($_[0]),&'bnorm($_[1]));
+     if ($x eq 'NaN') {
+ 	'NaN';
+     } elsif ($y eq 'NaN') {
+ 	'NaN';
+     } else {
+ 	@x = &internal($x);             # convert to internal form
+ 	@y = &internal($y);
+ 	local($sx, $sy) = (shift @x, shift @y); # get signs
+ 	if ($sx eq $sy) {
+ 	    &external($sx, &add(*x, *y)); # if same sign add
+ 	} else {
+ 	    ($x, $y) = (&abs($x),&abs($y)); # make abs
+ 	    if (&cmp($y,$x) > 0) {
+ 		&external($sy, &sub(*y, *x));
+ 	    } else {
+ 		&external($sx, &sub(*x, *y));
+ 	    }
+ 	}
+     }
+ }
+ 
+ sub main'bsub { #(num_str, num_str) return num_str
+     &'badd($_[0],&'bneg($_[1]));    
+ }
+ 
+ # GCD -- Euclids algorithm Knuth Vol 2 pg 296
+ sub main'bgcd { #(num_str, num_str) return num_str
+     local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1]));
+     if ($x eq 'NaN') {
+ 	'NaN';
+     }
+     elsif ($y eq 'NaN') {
+ 	'NaN';
+     }
+     else {
+ 	($x, $y) = ($y,&'bmod($x,$y)) while $y ne '+0';
+ 	$x;
+     }
+ }
+ 
+ # routine to add two base 100000 numbers
+ #   stolen from Knuth Vol 2 Algorithm A pg 231
+ #   there are separate routines to add and sub as per Kunth pg 233
+ sub add { #(int_num_array, int_num_array) return int_num_array
+     local(*x, *y) = @_;
+     $car = 0;
+     for $x (@x) {
+ 	last unless @y || $car;
+ 	$x -= 100000 if $car = (($x += shift @y + $car) >= 100000);
+     }
+     for $y (@y) {
+ 	last unless $car;
+ 	$y -= 100000 if $car = (($y += $car) >= 100000);
+     }
+     (@x, @y, $car);
+ }
+ 
+ # subtract base 100000 numbers -- stolen from Knuth Vol 2 pg 232, $x > $y
+ sub sub { #(int_num_array, int_num_array) return int_num_array
+     local(*sx, *sy) = @_;
+     $bar = 0;
+     for $sx (@sx) {
+ 	last unless @y || $bar;
+ 	$sx += 100000 if $bar = (($sx -= shift @sy + $bar) < 0);
+     }
+     @sx;
+ }
+ 
+ # multiply two numbers -- stolen from Knuth Vol 2 pg 233
+ sub main'bmul { #(num_str, num_str) return num_str
+     local(*x, *y); ($x, $y) = (&'bnorm($_[0]), &'bnorm($_[1]));
+     if ($x eq 'NaN') {
+ 	'NaN';
+     } elsif ($y eq 'NaN') {
+ 	'NaN';
+     } else {
+ 	@x = &internal($x);
+ 	@y = &internal($y);
+ 	local($signr) = (shift @x ne shift @y) ? '-' : '+';
+ 	@prod = ();
+ 	for $x (@x) {
+ 	    ($car, $cty) = (0, 0);
+ 	    for $y (@y) {
+ 		$prod = $x * $y + $prod[$cty] + $car;
+ 		$prod[$cty++] =
+ 		    $prod - ($car = int($prod * (1/100000))) * 100000;
+ 	    }
+ 	    $prod[$cty] += $car if $car;
+ 	    $x = shift @prod;
+ 	}
+ 	&external($signr, @x, @prod);
+     }
+ }
+ 
+ # modulus
+ sub main'bmod { #(num_str, num_str) return num_str
+     (&'bdiv(@_))[1];
+ }
+ 
+ sub main'bdiv { #(dividend: num_str, divisor: num_str) return num_str
+     local (*x, *y); ($x, $y) = (&'bnorm($_[0]), &'bnorm($_[1]));
+     return wantarray ? ('NaN','NaN') : 'NaN'
+ 	if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0');
+     return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0);
+     @x = &internal($x); @y = &internal($y);
+     $srem = $y[0];
+     $sr = (shift @x ne shift @y) ? '-' : '+';
+     $car = $bar = $prd = 0;
+     if (($dd = int(100000/($y[$#y]+1))) != 1) {
+ 	for $x (@x) {
+ 	    $x = $x * $dd + $car;
+ 	    $x -= ($car = int($x * (1/100000))) * 100000;
+ 	}
+ 	push(@x, $car); $car = 0;
+ 	for $y (@y) {
+ 	    $y = $y * $dd + $car;
+ 	    $y -= ($car = int($y * (1/100000))) * 100000;
+ 	}
+     }
+     else {
+ 	push(@x, 0);
+     }
+     @q = (); ($v2,$v1) = @y[$#y-1,$#y];
+     while ($#x > $#y) {
+ 	($u2,$u1,$u0) = @x[($#x-2)..$#x];
+ 	$q = (($u0 == $v1) ? 99999 : int(($u0*100000+$u1)/$v1));
+ 	--$q while ($v2*$q > ($u0*100000+$u1-$q*$v1)*100000+$u2);
+ 	if ($q) {
+ 	    ($car, $bar) = (0,0);
+ 	    for ($y = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) {
+ 		$prd = $q * $y[$y] + $car;
+ 		$prd -= ($car = int($prd * (1/100000))) * 100000;
+ 		$x[$x] += 100000 if ($bar = (($x[$x] -= $prd + $bar) < 0));
+ 	    }
+ 	    if ($x[$#x] < $car + $bar) {
+ 		$car = 0; --$q;
+ 		for ($y = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) {
+ 		    $x[$x] -= 100000
+ 			if ($car = (($x[$x] += $y[$y] + $car) > 100000));
+ 		}
+ 	    }   
+ 	}
+ 	pop(@x); unshift(@q, $q);
+     }
+     if (wantarray) {
+ 	@d = ();
+ 	if ($dd != 1) {
+ 	    $car = 0;
+ 	    for $x (reverse @x) {
+ 		$prd = $car * 100000 + $x;
+ 		$car = $prd - ($tmp = int($prd / $dd)) * $dd;
+ 		unshift(@d, $tmp);
+ 	    }
+ 	}
+ 	else {
+ 	    @d = @x;
+ 	}
+ 	(&external($sr, @q), &external($srem, @d, 0));
+     } else {
+ 	&external($sr, @q);
+     }
+ }
+ 1;

Index: lib/bigrat.pl
*** lib/bigrat.pl.old	Sat Nov 10 02:28:15 1990
--- lib/bigrat.pl	Sat Nov 10 02:28:19 1990
***************
*** 0 ****
--- 1,146 ----
+ package bigrat;
+ require "bigint.pl";
+ 
+ # Arbitrary size rational math package
+ #
+ # Input values to these routines consist of strings of the form 
+ #   m|^\s*[+-]?[\d\s]+(/[\d\s]+)?$|.
+ # Examples:
+ #   "+0/1"                          canonical zero value
+ #   "3"                             canonical value "+3/1"
+ #   "   -123/123 123"               canonical value "-1/1001"
+ #   "123 456/7890"                  canonical value "+20576/1315"
+ # Output values always include a sign and no leading zeros or
+ #   white space.
+ # This package makes use of the bigint package.
+ # The string 'NaN' is used to represent the result when input arguments 
+ #   that are not numbers, as well as the result of dividing by zero and
+ #       the sqrt of a negative number.
+ # Extreamly naive algorthims are used.
+ #
+ # Routines provided are:
+ #
+ #   rneg(RAT) return RAT                negation
+ #   rabs(RAT) return RAT                absolute value
+ #   rcmp(RAT,RAT) return CODE           compare numbers (undef,<0,=0,>0)
+ #   radd(RAT,RAT) return RAT            addition
+ #   rsub(RAT,RAT) return RAT            subtraction
+ #   rmul(RAT,RAT) return RAT            multiplication
+ #   rdiv(RAT,RAT) return RAT            division
+ #   rmod(RAT) return (RAT,RAT)          integer and fractional parts
+ #   rnorm(RAT) return RAT               normalization
+ #   rsqrt(RAT, cycles) return RAT       square root
+ 
+ # Convert a number to the canonical string form m|^[+-]\d+/\d+|.
+ sub main'rnorm { #(string) return rat_num
+     local($_) = @_;
+     s/\s+//g;
+     if (m#^([+-]?\d+)(/(\d*[1-9]0*))?$#) {
+ 	&norm($1, $3 ? $3 : '+1');
+     } else {
+ 	'NaN';
+     }
+ }
+ 
+ # Normalize by reducing to lowest terms
+ sub norm { #(bint, bint) return rat_num
+     local($num,$dom) = @_;
+     if ($num eq 'NaN') {
+ 	'NaN';
+     } elsif ($dom eq 'NaN') {
+ 	'NaN';
+     } elsif ($dom =~ /^[+-]?0+$/) {
+ 	'NaN';
+     } else {
+ 	local($gcd) = &'bgcd($num,$dom);
+ 	if ($gcd ne '+1') { 
+ 	    $num = &'bdiv($num,$gcd);
+ 	    $dom = &'bdiv($dom,$gcd);
+ 	} else {
+ 	    $num = &'bnorm($num);
+ 	    $dom = &'bnorm($dom);
+ 	}
+ 	substr($dom,0,1) = '';
+ 	"$num/$dom";
+     }
+ }
+ 
+ # negation
+ sub main'rneg { #(rat_num) return rat_num
+     local($_) = &'rnorm($_[0]);
+     tr/-+/+-/ if ($_ ne '+0/1');
+     $_;
+ }
+ 
+ # absolute value
+ sub main'rabs { #(rat_num) return $rat_num
+     local($_) = &'rnorm($_[0]);
+     substr($_,0,1) = '+';
+     $_;
+ }
+ 
+ # multipication
+ sub main'rmul { #(rat_num, rat_num) return rat_num
+     local($xn,$xd) = split('/',&'rnorm($_[0]));
+     local($yn,$yd) = split('/',&'rnorm($_[1]));
+     &norm(&'bmul($xn,$yn),&'bmul($xd,$yd));
+ }
+ 
+ # division
+ sub main'rdiv { #(rat_num, rat_num) return rat_num
+     local($xn,$xd) = split('/',&'rnorm($_[0]));
+     local($yn,$yd) = split('/',&'rnorm($_[1]));
+     &norm(&'bmul($xn,$yd),&'bmul($xd,$yn));
+ }
+ 
+ # addition
+ sub main'radd { #(rat_num, rat_num) return rat_num
+     local($xn,$xd) = split('/',&'rnorm($_[0]));
+     local($yn,$yd) = split('/',&'rnorm($_[1]));
+     &norm(&'badd(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
+ }
+ 
+ # subtraction
+ sub main'rsub { #(rat_num, rat_num) return rat_num
+     local($xn,$xd) = split('/',&'rnorm($_[0]));
+     local($yn,$yd) = split('/',&'rnorm($_[1]));
+     &norm(&'bsub(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
+ }
+ 
+ # comparison
+ sub main'rcmp { #(rat_num, rat_num) return cond_code
+     local($xn,$xd) = split('/',&'rnorm($_[0]));
+     local($yn,$yd) = split('/',&'rnorm($_[1]));
+     &bigint'cmp(&'bmul($xn,$yd),&'bmul($yn,$xd));
+ }
+ 
+ # int and frac parts
+ sub main'rmod { #(rat_num) return (rat_num,rat_num)
+     local($xn,$xd) = split('/',&'rnorm($_[0]));
+     local($i,$f) = &'bdiv($xn,$xd);
+     if (wantarray) {
+ 	("$i/1", "$f/$xd");
+     } else {
+ 	"$i/1";
+     }   
+ }
+ 
+ # square root by Newtons method.
+ #   cycles specifies the number of iterations default: 5
+ sub main'rsqrt { #(fnum_str[, cycles]) return fnum_str
+     local($x, $scale) = (&'rnorm($_[0]), $_[1]);
+     if ($x eq 'NaN') {
+ 	'NaN';
+     } elsif ($x =~ /^-/) {
+ 	'NaN';
+     } else {
+ 	local($gscale, $guess) = (0, '+1/1');
+ 	$scale = 5 if (!$scale);
+ 	while ($gscale++ < $scale) {
+ 	    $guess = &'rmul(&'radd($guess,&'rdiv($x,$guess)),"+1/2");
+ 	}
+ 	"$guess";          # quotes necessary due to perl bug
+     }
+ }
+ 
+ 1;

Index: cmd.c
Prereq: 3.0.1.10
No differences encountered

Index: t/comp.cpp
Prereq: 3.0.1.1
*** t/comp.cpp.old	Sat Nov 10 02:37:07 1990
--- t/comp.cpp	Sat Nov 10 02:37:09 1990
***************
*** 1,6 ****
  #!./perl -P
  
! # $Header: comp.cpp,v 3.0.1.1 90/08/09 05:25:34 lwall Locked $
  
  print "1..3\n";
  
--- 1,6 ----
  #!./perl -P
  
! # $Header: comp.cpp,v 3.0.1.2 90/11/10 02:10:17 lwall Locked $
  
  print "1..3\n";
  
***************
*** 15,35 ****
  	print "not ok 2\n";
  #endif
  
! open(try,">Comp.cpp.tmp") || die "Can't open temp perl file.";
! print try '$ok = "not ok 3\n";'; print try "\n";
! print try "#include <Comp.cpp.inc>\n";
! print try "#ifdef OK\n";
! print try '$ok = OK;'; print try "\n";
! print try "#endif\n";
! print try 'print $ok;'; print try "\n";
! close try;
  
! open(try,">Comp.cpp.inc") || (die "Can't open temp include file.");
! print try '#define OK "ok 3\n"'; print try "\n";
! close try;
  
  $pwd=`pwd`;
  $pwd =~ s/\n//;
! $x = `./perl -P -I$pwd Comp.cpp.tmp`;
  print $x;
  unlink "Comp.cpp.tmp", "Comp.cpp.inc";
--- 15,39 ----
  	print "not ok 2\n";
  #endif
  
! open(TRY,">Comp.cpp.tmp") || die "Can't open temp perl file.";
  
! ($prog = <<'END') =~ s/X//g;
! X$ok = "not ok 3\n";
! X#include "Comp.cpp.inc"
! X#ifdef OK
! X$ok = OK;
! X#endif
! Xprint $ok;
! END
! print TRY $prog;
! close TRY;
  
+ open(TRY,">Comp.cpp.inc") || (die "Can't open temp include file.");
+ print TRY '#define OK "ok 3\n"' . "\n";
+ close TRY;
+ 
  $pwd=`pwd`;
  $pwd =~ s/\n//;
! $x = `./perl -P Comp.cpp.tmp`;
  print $x;
  unlink "Comp.cpp.tmp", "Comp.cpp.inc";

Index: config_h.SH
No differences encountered

Index: cons.c
Prereq: 3.0.1.8
*** cons.c.old	Sat Nov 10 02:23:51 1990
--- cons.c	Sat Nov 10 02:23:59 1990
***************
*** 1,4 ****
! /* $Header: cons.c,v 3.0.1.8 90/10/15 15:41:09 lwall Locked $
   *
   *    Copyright (c) 1989, Larry Wall
   *
--- 1,4 ----
! /* $Header: cons.c,v 3.0.1.9 90/11/10 01:10:50 lwall Locked $
   *
   *    Copyright (c) 1989, Larry Wall
   *
***************
*** 6,11 ****
--- 6,14 ----
   *    as specified in the README file that comes with the perl 3.0 kit.
   *
   * $Log:	cons.c,v $
+  * Revision 3.0.1.9  90/11/10  01:10:50  lwall
+  * patch38: random cleanup
+  * 
   * Revision 3.0.1.8  90/10/15  15:41:09  lwall
   * patch29: added caller
   * patch29: scripts now run at almost full speed under the debugger
***************
*** 449,455 ****
  {
      register CMD *cmd;
      register CMD *head = cur->c_head;
-     register ARG *arg;
      STR *str;
  
      if (!head)
--- 452,457 ----

Index: os2/dir.h
*** os2/dir.h.old	Sat Nov 10 02:29:23 1990
--- os2/dir.h	Sat Nov 10 02:29:24 1990
***************
*** 7,17 ****
   *
   *  Enhanced and ported to OS/2 by Kai Uwe Rommel; added scandir() prototype
   *  December 1989, February 1990
   */
  
  
! #define MAXNAMLEN  12
! #define MAXPATHLEN 128
  
  #define A_RONLY    0x01
  #define A_HIDDEN   0x02
--- 7,18 ----
   *
   *  Enhanced and ported to OS/2 by Kai Uwe Rommel; added scandir() prototype
   *  December 1989, February 1990
+  *  Change of MAXPATHLEN for HPFS, October 1990
   */
  
  
! #define MAXNAMLEN  256
! #define MAXPATHLEN 256
  
  #define A_RONLY    0x01
  #define A_HIDDEN   0x02
***************
*** 23,34 ****
  
  struct direct
  {
!   ino_t d_ino;                   /* a bit of a farce */
!   int   d_reclen;                /* more farce */
!   int   d_namlen;                /* length of d_name */
!   char  d_name[MAXNAMLEN + 1];   /* null terminated */
!   long  d_size;                  /* size in bytes */
!   int   d_mode;                  /* DOS or OS/2 file attributes */
  };
  
  /* The fields d_size and d_mode are extensions by me (Kai Uwe Rommel).
--- 24,38 ----
  
  struct direct
  {
!   ino_t    d_ino;                   /* a bit of a farce */
!   int      d_reclen;                /* more farce */
!   int      d_namlen;                /* length of d_name */
!   char     d_name[MAXNAMLEN + 1];   /* null terminated */
!   /* nonstandard fields */
!   long     d_size;                  /* size in bytes */
!   unsigned d_mode;                  /* DOS or OS/2 file attributes */
!   unsigned d_time;
!   unsigned d_date;
  };
  
  /* The fields d_size and d_mode are extensions by me (Kai Uwe Rommel).
***************
*** 41,47 ****
  {
    char *_d_entry;
    long _d_size;
!   int _d_mode;
    struct _dircontents *_d_next;
  };
  
--- 45,51 ----
  {
    char *_d_entry;
    long _d_size;
!   unsigned _d_mode, _d_time, _d_date;
    struct _dircontents *_d_next;
  };
  
***************
*** 55,60 ****
--- 59,66 ----
  DIR;
  
  
+ extern int attributes;
+ 
  extern DIR *opendir(char *);
  extern struct direct *readdir(DIR *);
  extern void seekdir(DIR *, long);
***************
*** 68,163 ****
  
  extern int getfmode(char *);
  extern int setfmode(char *, unsigned);
- 
- /*
- NAME
-      opendir, readdir, telldir, seekdir, rewinddir, closedir -
-      directory operations
- 
- SYNTAX
-      #include <sys/types.h>
-      #include <sys/dir.h>
- 
-      DIR *opendir(filename)
-      char *filename;
- 
-      struct direct *readdir(dirp)
-      DIR *dirp;
- 
-      long telldir(dirp)
-      DIR *dirp;
- 
-      seekdir(dirp, loc)
-      DIR *dirp;
-      long loc;
- 
-      rewinddir(dirp)
-      DIR *dirp;
- 
-      int closedir(dirp)
-      DIR *dirp;
- 
- DESCRIPTION
-      The opendir library routine opens the directory named by
-      filename and associates a directory stream with it.  A
-      pointer is returned to identify the directory stream in sub-
-      sequent operations.  The pointer NULL is returned if the
-      specified filename can not be accessed, or if insufficient
-      memory is available to open the directory file.
- 
-      The readdir routine returns a pointer to the next directory
-      entry.  It returns NULL upon reaching the end of the direc-
-      tory or on detecting an invalid seekdir operation.  The
-      readdir routine uses the getdirentries system call to read
-      directories. Since the readdir routine returns NULL upon
-      reaching the end of the directory or on detecting an error,
-      an application which wishes to detect the difference must
-      set errno to 0 prior to calling readdir.
- 
-      The telldir routine returns the current location associated
-      with the named directory stream. Values returned by telldir
-      are good only for the lifetime of the DIR pointer from which
-      they are derived.  If the directory is closed and then reo-
-      pened, the telldir value may be invalidated due to
-      undetected directory compaction.
- 
-      The seekdir routine sets the position of the next readdir
-      operation on the directory stream. Only values returned by
-      telldir should be used with seekdir.
- 
-      The rewinddir routine resets the position of the named
-      directory stream to the beginning of the directory.
- 
-      The closedir routine closes the named directory stream and
-      returns a value of 0 if successful. Otherwise, a value of -1
-      is returned and errno is set to indicate the error.  All
-      resources associated with this directory stream are
-      released.
- 
- EXAMPLE
-      The following sample code searches a directory for the entry
-      name.
- 
-      len = strlen(name);
- 
-      dirp = opendir(".");
- 
-      for (dp = readdir(dirp); dp != NULL; dp = readdir(dirp))
- 
-      if (dp->d_namlen == len && !strcmp(dp->d_name, name)) {
- 
-                closedir(dirp);
- 
-                return FOUND;
- 
-           }
- 
-      closedir(dirp);
- 
-      return NOT_FOUND;
- 
- 
- SEE ALSO
-      close(2), getdirentries(2), lseek(2), open(2), read(2),
-      dir(5)
- */
--- 74,76 ----

*** End of Patch 38 ***



More information about the Comp.sources.bugs mailing list