diff options
| -rwxr-xr-x | Configure | 7 | ||||
| -rw-r--r-- | MANIFEST | 6 | ||||
| -rw-r--r-- | Makefile.SH | 7 | ||||
| -rw-r--r-- | README | 6 | ||||
| -rw-r--r-- | arg.h | 23 | ||||
| -rw-r--r-- | cons.c | 6 | ||||
| -rw-r--r-- | lib/bigfloat.pl | 236 | ||||
| -rw-r--r-- | lib/bigint.pl | 275 | ||||
| -rw-r--r-- | lib/bigrat.pl | 146 | ||||
| -rw-r--r-- | os2/README.OS2 | 27 | ||||
| -rw-r--r-- | os2/a2p.cs | 2 | ||||
| -rw-r--r-- | os2/dir.h | 117 | ||||
| -rw-r--r-- | patchlevel.h | 2 | ||||
| -rw-r--r-- | t/TEST | 8 | ||||
| -rw-r--r-- | t/comp.cpp | 30 | ||||
| -rw-r--r-- | x2p/Makefile.SH | 9 |
16 files changed, 767 insertions, 140 deletions
@@ -8,7 +8,7 @@ # 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 $ +# $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,6 +1404,9 @@ if test -f "$1"; then 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,7 +1452,7 @@ echo " " 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 +$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 @@ -85,6 +85,9 @@ hash.c Associative arrays 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,6 +135,7 @@ os2/os2.c Unix compatibility functions 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,6 +188,7 @@ t/io.inplace See if inplace editing works 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,3 +262,4 @@ x2p/str.h Public declarations for the above 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. diff --git a/Makefile.SH b/Makefile.SH index 3197d60c9e..700f229249 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -25,9 +25,12 @@ esac 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 $ +# $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,7 +380,7 @@ depend: makedepend cd x2p; $(MAKE) depend test: perl - - chmod +x t/TEST t/base.* t/comp.* t/cmd.* t/io.* t/op.*; \ + - 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: @@ -102,13 +102,17 @@ Installation 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 -Sm10000 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. @@ -1,4 +1,4 @@ -/* $Header: arg.h,v 3.0.1.7 90/10/15 14:53:59 lwall Locked $ +/* $Header: arg.h,v 3.0.1.8 90/11/10 01:04:36 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,10 @@ * 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,7 +314,8 @@ #define O_FTATIME 264 #define O_FTCTIME 265 #define O_WAITPID 266 -#define MAXO 267 +#define O_ALARM 267 +#define MAXO 268 #ifndef DOINIT extern char *opname[]; @@ -583,7 +588,8 @@ char *opname[] = { "FTATIME", "FTCTIME", "WAITPID", - "264" + "ALARM", + "268" }; #endif @@ -889,15 +895,15 @@ unsigned short opargs[MAXO+1] = { A(0,0,0), /* DUMP */ A(0,3,0), /* REVERSE */ A(1,0,0), /* ADDROF */ - A(1,1,1), /* SOCKET */ + 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 */ - A(1,1,3), /* RECV */ - A(1,1,1), /* SSELECT */ - A(1,1,1), /* SOCKPAIR */ + 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,7 +958,7 @@ unsigned short opargs[MAXO+1] = { A(0,0,0), /* GETLOGIN */ A(1,3,0), /* SYSCALL */ A(1,1,1), /* GSOCKOPT */ - A(1,1,1), /* SSOCKOPT */ + A5(1,1,1,1,0), /* SSOCKOPT */ A(1,0,0), /* GETSOCKNAME */ A(1,0,0), /* GETPEERNAME */ A(0,3,3), /* LSLICE */ @@ -981,6 +987,7 @@ unsigned short opargs[MAXO+1] = { A(1,0,0), /* FTATIME */ A(1,0,0), /* FTCTIME */ A(1,1,0), /* WAITPID */ + A(1,0,0), /* ALARM */ 0 }; #undef A @@ -1,4 +1,4 @@ -/* $Header: cons.c,v 3.0.1.8 90/10/15 15:41:09 lwall Locked $ +/* $Header: cons.c,v 3.0.1.9 90/11/10 01:10:50 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,9 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: 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,7 +452,6 @@ CMD *cur; { register CMD *cmd; register CMD *head = cur->c_head; - register ARG *arg; STR *str; if (!head) diff --git a/lib/bigfloat.pl b/lib/bigfloat.pl new file mode 100644 index 0000000000..feaaa6e494 --- /dev/null +++ b/lib/bigfloat.pl @@ -0,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; diff --git a/lib/bigint.pl b/lib/bigint.pl new file mode 100644 index 0000000000..503c7837c2 --- /dev/null +++ b/lib/bigint.pl @@ -0,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; diff --git a/lib/bigrat.pl b/lib/bigrat.pl new file mode 100644 index 0000000000..3157cf8244 --- /dev/null +++ b/lib/bigrat.pl @@ -0,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; diff --git a/os2/README.OS2 b/os2/README.OS2 index 99cd9a24c1..11ff14c4d4 100644 --- a/os2/README.OS2 +++ b/os2/README.OS2 @@ -336,6 +336,7 @@ a2p.def linker definition file for a2p 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,4 +354,28 @@ especially not with -DDEBUGGING rommel@lan.informatik.tu-muenchen.dbp.de Breslauer Str. 25 D-8756 Kahl/Main - West (yes, still!) Germany + ++ 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@lan.informatik.tu-muenchen.dbp.de diff --git a/os2/a2p.cs b/os2/a2p.cs index 1141c4ff17..c12e226efa 100644 --- a/os2/a2p.cs +++ b/os2/a2p.cs @@ -2,7 +2,7 @@ (-W1 -Od -Ocgelt hash.c str.c util.c walk.c) setargv.obj -a2p.def +..\os2\a2p.def a2p.exe -AL -LB -S0xA000 @@ -7,11 +7,12 @@ * * 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 12 -#define MAXPATHLEN 128 +#define MAXNAMLEN 256 +#define MAXPATHLEN 256 #define A_RONLY 0x01 #define A_HIDDEN 0x02 @@ -23,12 +24,15 @@ 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 */ + 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,7 +45,7 @@ struct _dircontents { char *_d_entry; long _d_size; - int _d_mode; + unsigned _d_mode, _d_time, _d_date; struct _dircontents *_d_next; }; @@ -55,6 +59,8 @@ typedef struct _dirdesc DIR; +extern int attributes; + extern DIR *opendir(char *); extern struct direct *readdir(DIR *); extern void seekdir(DIR *, long); @@ -68,96 +74,3 @@ extern int scandir(char *, struct direct ***, 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) -*/ diff --git a/patchlevel.h b/patchlevel.h index 1bff899020..6f96c1efde 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 37 +#define PATCHLEVEL 38 @@ -1,6 +1,6 @@ #!./perl -# $Header: TEST,v 3.0.1.1 89/11/11 04:58:01 lwall Locked $ +# $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,11 +15,11 @@ if ($ARGV[0] eq '-v') { chdir 't' if -f 't/TEST'; if ($ARGV[0] eq '') { - @ARGV = split(/[ \n]/,`echo base.* comp.* cmd.* io.* op.*`); + @ARGV = split(/[ \n]/,`echo base.* comp.* cmd.* io.* op.* lib.*`); } -open(config,"../config.sh"); -while (<config>) { +open(CONFIG,"../config.sh"); +while (<CONFIG>) { if (/sharpbang='(.*)'/) { $sharpbang = ($1 eq '#!'); last; diff --git a/t/comp.cpp b/t/comp.cpp index 0464108d9e..9e8b1d3378 100644 --- a/t/comp.cpp +++ b/t/comp.cpp @@ -1,6 +1,6 @@ #!./perl -P -# $Header: comp.cpp,v 3.0.1.1 90/08/09 05:25:34 lwall Locked $ +# $Header: comp.cpp,v 3.0.1.2 90/11/10 02:10:17 lwall Locked $ print "1..3\n"; @@ -15,21 +15,25 @@ print MESS; 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.tmp") || die "Can't open temp perl file."; -open(try,">Comp.cpp.inc") || (die "Can't open temp include file."); -print try '#define OK "ok 3\n"'; print try "\n"; -close try; +($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 -I$pwd Comp.cpp.tmp`; +$x = `./perl -P Comp.cpp.tmp`; print $x; unlink "Comp.cpp.tmp", "Comp.cpp.inc"; diff --git a/x2p/Makefile.SH b/x2p/Makefile.SH index 673a639727..119a60dae2 100644 --- a/x2p/Makefile.SH +++ b/x2p/Makefile.SH @@ -18,9 +18,12 @@ case "$mallocsrc" in 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 $ +# $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,10 +141,10 @@ done; \ fi clean: - rm -f *.o + rm -f a2p *.o realclean: clean - rm -f a2p *.orig */*.orig core $(addedbyconf) a2p.c s2p all + 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. |