Xref: utzoo comp.sources.bugs:2651 comp.lang.perl:2922 Path: utzoo!attcan!uunet!bu.edu!xylogics!samsung!usc!elroy.jpl.nasa.gov!jpl-devvax!lwall From: lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) Newsgroups: comp.sources.bugs,comp.lang.perl Subject: perl 3.0 patch #38 Summary: This is an official patch for perl 3.0. Please apply it. Message-ID: <10315@jpl-devvax.JPL.NASA.GOV> Date: 10 Nov 90 11:25:59 GMT Organization: Jet Propulsion Laboratory, Pasadena, CA Lines: 1523 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 #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.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.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 <Makefile <Makefile <Makefile <) { 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 () { 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 \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 - #include - - 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 ***