perl 3.0 patch #38 (combined patch)
authorLarry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Fri, 9 Nov 1990 13:39:17 +0000 (13:39 +0000)
committerLarry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Fri, 9 Nov 1990 13:39:17 +0000 (13:39 +0000)
Forget the description, it's too late at night...

16 files changed:
Configure
MANIFEST
Makefile.SH
README
arg.h
cons.c
lib/bigfloat.pl [new file with mode: 0644]
lib/bigint.pl [new file with mode: 0644]
lib/bigrat.pl [new file with mode: 0644]
os2/README.OS2
os2/a2p.cs
os2/dir.h
patchlevel.h
t/TEST
t/comp.cpp
x2p/Makefile.SH

index c1cdf6b..572659a 100755 (executable)
--- a/Configure
+++ b/Configure
@@ -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
index ecc18be..4b3b649 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -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.
index 3197d60..700f229 100644 (file)
@@ -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:
diff --git a/README b/README
index 1b96f88..9a3c7e2 100644 (file)
--- a/README
+++ b/README
@@ -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.
diff --git a/arg.h b/arg.h
index df139db..8947baa 100644 (file)
--- a/arg.h
+++ b/arg.h
@@ -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
 #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
diff --git a/cons.c b/cons.c
index 3938b99..638cb0a 100644 (file)
--- a/cons.c
+++ b/cons.c
@@ -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 (file)
index 0000000..feaaa6e
--- /dev/null
@@ -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
+\f
+# 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);
+    }
+}
+\f
+# 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);
+    }
+}
+\f
+# 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);
+       }
+    }
+}
+\f
+# 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
+       }
+    }
+}
+\f
+# 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 (file)
index 0000000..503c783
--- /dev/null
@@ -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
+#
+\f
+# 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/^-/+/;
+    $_;
+}
+\f
+# 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;
+    }
+}
+\f
+# 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];
+}
+\f
+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 (file)
index 0000000..3157cf8
--- /dev/null
@@ -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
+\f
+# 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));
+}
+\f
+# 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 99cd9a2..11ff14c 100644 (file)
@@ -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
index 1141c4f..c12e226 100644 (file)
@@ -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
index 92c6923..8ebfae9 100644 (file)
--- a/os2/dir.h
+++ b/os2/dir.h
@@ -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
 
 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)
-*/
index 1bff899..6f96c1e 100644 (file)
@@ -1 +1 @@
-#define PATCHLEVEL 37
+#define PATCHLEVEL 38
diff --git a/t/TEST b/t/TEST
index a554c34..0d91a47 100644 (file)
--- a/t/TEST
+++ b/t/TEST
@@ -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;
index 0464108..9e8b1d3 100644 (file)
@@ -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";
index 673a639..119a60d 100644 (file)
@@ -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.