See patch #20.
--- /dev/null
+#
+# gemdos/xbios/bios interface on the atari
+#
+# ++jrb bammi@cadence.com
+#
+
+# camel book pp204
+sub enum {
+ local($_) = @_;
+ local(@specs) = split(/,/);
+ local($val);
+ for(@specs) {
+ if(/=/) {
+ $val = eval $_;
+ } else {
+ eval $_ . ' = ++$val';
+ }
+ }
+}
+
+# these must match the defines in atarist.c
+
+&enum(<<'EOL');
+$_trap_1_w=1, $_trap_1_ww, $_trap_1_wl, $_trap_1_wlw, $_trap_1_www,
+$_trap_1_wll, $_trap_1_wwll, $_trap_1_wlww, $_trap_1_wwlll, $_trap_13_w,
+$_trap_13_ww, $_trap_13_wl, $_trap_13_www, $_trap_13_wwl, $_trap_13_wwlwww,
+$_trap_14_w, $_trap_14_ww, $_trap_14_wl, $_trap_14_www, $_trap_14_wwl,
+$_trap_14_wwll, $_trap_14_wllw, $_trap_14_wlll, $_trap_14_wwwl,
+$_trap_14_wwwwl, $_trap_14_wllww, $_trap_14_wwwwwww, $_trap_14_wllwwwww,
+$_trap_14_wllwwwwlw, $_trap_14_wllwwwwwlw
+EOL
+
+sub Pterm0 {
+ syscall($_trap_1_w, 0x00);
+}
+sub Cconin {
+ syscall($_trap_1_w, 0x01);
+}
+sub Cconout {
+ syscall($_trap_1_ww, 0x02, @_);
+}
+sub Cauxin {
+ syscall($_trap_1_w, 0x03);
+}
+sub Cauxout {
+ syscall($_trap_1_ww, 0x04, @_);
+}
+sub Cprnout {
+ syscall($_trap_1_ww, 0x05, @_);
+}
+sub Crawio {
+ syscall($_trap_1_ww, 0x06, @_);
+}
+sub Crawcin {
+ syscall($_trap_1_w, 0x07);
+}
+sub Cnecin {
+ syscall($_trap_1_w, 0x08);
+}
+sub Cconws {
+ syscall($_trap_1_wl, 0x09, @_);
+}
+sub Cconrs {
+ syscall($_trap_1_wl, 0x0A, @_);
+}
+sub Cconis {
+ syscall($_trap_1_w, 0x0B);
+}
+sub Dsetdrv {
+ syscall($_trap_1_ww, 0x0E, @_);
+}
+sub Cconos {
+ syscall($_trap_1_w, 0x10);
+}
+sub Cprnos {
+ syscall($_trap_1_w, 0x11);
+}
+sub Cauxis {
+ syscall($_trap_1_w, 0x12);
+}
+sub Cauxos {
+ syscall($_trap_1_w, 0x13);
+}
+sub Dgetdrv {
+ syscall($_trap_1_w, 0x19);
+}
+sub Fsetdta {
+ syscall($_trap_1_wl, 0x1A, @_);
+}
+sub Super {
+ syscall($_trap_1_wl, 0x20, @_);
+}
+sub Tgetdate {
+ syscall($_trap_1_w, 0x2A);
+}
+sub Tsetdate {
+ syscall($_trap_1_ww, 0x2B, @_);
+}
+sub Tgettime {
+ syscall($_trap_1_w, 0x2C);
+}
+sub Tsettime {
+ syscall($_trap_1_ww, 0x2D, @_);
+}
+sub Fgetdta {
+ syscall($_trap_1_w, 0x2F);
+}
+sub Sversion {
+ syscall($_trap_1_w, 0x30);
+}
+sub Ptermres {
+ syscall($_trap_1_wlw, 0x31, @_);
+}
+sub Dfree {
+ syscall($_trap_1_wlw, 0x36, @_);
+}
+sub Dcreate {
+ syscall($_trap_1_wl, 0x39, @_);
+}
+sub Ddelete {
+ syscall($_trap_1_wl, 0x3A, @_);
+}
+sub Dsetpath {
+ syscall($_trap_1_wl, 0x3B, @_);
+}
+sub Fcreate {
+ syscall($_trap_1_wlw, 0x3C, @_);
+}
+sub Fopen {
+ syscall($_trap_1_wlw, 0x3D, @_);
+}
+sub Fclose {
+ syscall($_trap_1_ww, 0x3E, @_);
+}
+sub Fread {
+ syscall($_trap_1_wwll, 0x3F, @_);
+}
+sub Fwrite {
+ syscall($_trap_1_wwll, 0x40, @_);
+}
+sub Fdelete {
+ syscall($_trap_1_wl, 0x41, @_);
+}
+sub Fseek {
+ syscall($_trap_1_wlww, 0x42, @_);
+}
+sub Fattrib {
+ syscall($_trap_1_wlww, 0x43, @_);
+}
+sub Fdup {
+ syscall($_trap_1_ww, 0x45, @_);
+}
+sub Fforce {
+ syscall($_trap_1_www, 0x46, @_);
+}
+sub Dgetpath {
+ syscall($_trap_1_wlw, 0x47, @_);
+}
+sub Malloc {
+ syscall($_trap_1_wl, 0x48, @_);
+}
+sub Mfree {
+ syscall($_trap_1_wl, 0x49, @_);
+}
+sub Mshrink {
+ syscall($_trap_1_wwll, 0x4A, @_);
+}
+sub Pexec {
+ syscall($_trap_1_wwlll, 0x4B, @_);
+}
+sub Pterm {
+ syscall($_trap_1_ww, 0x4C, @_);
+}
+sub Fsfirst {
+ syscall($_trap_1_wlw, 0x4E, @_);
+}
+sub Fsnext {
+ syscall($_trap_1_w, 0x4F);
+}
+sub Frename {
+ syscall($_trap_1_wwll, 0x56, @_);
+}
+sub Fdatime {
+ syscall($_trap_1_wlww, 0x57, @_);
+}
+sub Getmpb {
+ syscall($_trap_13_wl, 0x00, @_);
+}
+sub Bconstat {
+ syscall($_trap_13_ww, 0x01, @_);
+}
+sub Bconin {
+ syscall($_trap_13_ww, 0x02, @_);
+}
+sub Bconout {
+ syscall($_trap_13_www, 0x03, @_);
+}
+sub Rwabs {
+ syscall($_trap_13_wwlwww, 0x04, @_);
+}
+sub Setexc {
+ syscall($_trap_13_wwl, 0x05, @_);
+}
+sub Tickcal {
+ syscall($_trap_13_w, 0x06);
+}
+sub Getbpb {
+ syscall($_trap_13_ww, 0x07, @_);
+}
+sub Bcostat {
+ syscall($_trap_13_ww, 0x08, @_);
+}
+sub Mediach {
+ syscall($_trap_13_ww, 0x09, @_);
+}
+sub Drvmap {
+ syscall($_trap_13_w, 0x0A);
+}
+sub Kbshift {
+ syscall($_trap_13_ww, 0x0B, @_);
+}
+sub Getshift {
+ &Kbshift(-1);
+}
+sub Initmous {
+ syscall($_trap_14_wwll, 0x00, @_);
+}
+sub Ssbrk {
+ syscall($_trap_14_ww, 0x01, @_);
+}
+sub Physbase {
+ syscall($_trap_14_w, 0x02);
+}
+sub Logbase {
+ syscall($_trap_14_w, 0x03);
+}
+sub Getrez {
+ syscall($_trap_14_w, 0x04);
+}
+sub Setscreen {
+ syscall($_trap_14_wllw, 0x05, @_);
+}
+sub Setpallete {
+ syscall($_trap_14_wl, 0x06, @_);
+}
+sub Setcolor {
+ syscall($_trap_14_www, 0x07, @_);
+}
+sub Floprd {
+ syscall($_trap_14_wllwwwww, 0x08, @_);
+}
+sub Flopwr {
+ syscall($_trap_14_wllwwwww, 0x09, @_);
+}
+sub Flopfmt {
+ syscall($_trap_14_wllwwwwwlw, 0x0A, @_);
+}
+sub Midiws {
+ syscall($_trap_14_wwl, 0x0C, @_);
+}
+sub Mfpint {
+ syscall($_trap_14_wwl, 0x0D, @_);
+}
+sub Iorec {
+ syscall($_trap_14_ww, 0x0E, @_);
+}
+sub Rsconf {
+ syscall($_trap_14_wwwwwww, 0x0F, @_);
+}
+sub Keytbl {
+ syscall($_trap_14_wlll, 0x10, @_);
+}
+sub Random {
+ syscall($_trap_14_w, 0x11);
+}
+sub Protobt {
+ syscall($_trap_14_wllww, 0x12, @_);
+}
+sub Flopver {
+ syscall($_trap_14_wllwwwww, 0x13, @_);
+}
+sub Scrdmp {
+ syscall($_trap_14_w, 0x14);
+}
+sub Cursconf {
+ syscall($_trap_14_www, 0x15, @_);
+}
+sub Settime {
+ syscall($_trap_14_wl, 0x16, @_);
+}
+sub Gettime {
+ syscall($_trap_14_w, 0x17);
+}
+sub Bioskeys {
+ syscall($_trap_14_w, 0x18);
+}
+sub Ikbdws {
+ syscall($_trap_14_wwl, 0x19, @_);
+}
+sub Jdisint {
+ syscall($_trap_14_ww, 0x1A, @_);
+}
+sub Jenabint {
+ syscall($_trap_14_ww, 0x1B, @_);
+}
+sub Giaccess {
+ syscall($_trap_14_www, 0x1C, @_);
+}
+sub Offgibit {
+ syscall($_trap_14_ww, 0x1D, @_);
+}
+sub Ongibit {
+ syscall($_trap_14_ww, 0x1E, @_);
+}
+sub Xbtimer {
+ syscall($_trap_14_wwwwl, 0x1E, @_);
+}
+sub Dosound {
+ syscall($_trap_14_wl, 0x20, @_);
+}
+sub Setprt {
+ syscall($_trap_14_ww, 0x21, @_);
+}
+sub Kbdvbase {
+ syscall($_trap_14_w, 0x22);
+}
+sub Kbrate {
+ syscall($_trap_14_www, 0x23, @_);
+}
+sub Prtblk {
+ syscall($_trap_14_wl, 0x24, @_);
+}
+sub Vsync {
+ syscall($_trap_14_w, 0x25);
+}
+sub Supexec {
+ syscall($_trap_14_wl, 0x26, @_);
+}
+sub Blitmode {
+ syscall($_trap_14_ww, 0x40, @_);
+}
+sub Mxalloc {
+ syscall($_trap_1_wlw, 0x44, @_);
+}
+sub Maddalt {
+ syscall($_trap_1_wll, 0x14, @_);
+}
+sub Setpalette {
+ syscall($_trap_14_wl, 0x06, @_);
+}
+sub EsetShift {
+ syscall($_trap_14_ww, 80, @_);
+}
+sub EgetShift {
+ syscall($_trap_14_w, 81);
+}
+sub EsetBank {
+ syscall($_trap_14_ww, 82, @_);
+}
+sub EsetColor {
+ syscall($_trap_14_www, 83, @_);
+}
+sub EsetPalette {
+ syscall($_trap_14_wwwl, 84, @_);
+}
+sub EgetPalette {
+ syscall($_trap_14_wwwl, 85, @_);
+}
+sub EsetGray {
+ syscall($_trap_14_ww, 86, @_);
+}
+sub EsetSmear {
+ syscall($_trap_14_ww, 87, @_);
+}
+sub Bconmap {
+ syscall($_trap_14_ww, 0x2b, @_);
+}
+sub Bconctl {
+ syscall($_trap_14_wwl, 0x2d, @_);
+}
+
+1;
--- /dev/null
+ccflags="$ccflags -Olimit 2900"
+libswanted=m
+tmp=`(uname -a) 2>/dev/null`
+case "$tmp" in
+OSF1*)
+ case "$tmp" in
+ *mips)
+ d_volatile=define
+ ;;
+ *)
+ cat <<EOFM
+You are not supposed to know about that machine...
+EOFM
+ ;;
+ esac
+ ;;
+esac
+#eval_cflags='optimize="-g"'
+#teval_cflags='optimize="-g"'
+#toke_cflags='optimize="-g"'
+#ttoke_cflags='optimize="-g"'
+regcomp_cflags='optimize="-g -O0"'
+tregcomp_cflags='optimize="-g -O0"'
+regexec_cflags='optimize="-g -O0"'
+tregexec_cflags='optimize="-g -O0"'
# newgetopt.pl -- new options parsing
-# SCCS Status : @(#)@ newgetopt.pl 1.8
+# SCCS Status : @(#)@ newgetopt.pl 1.13
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
-# Last Modified On: Thu Sep 26 20:10:41 1991
-# Update Count : 35
+# Last Modified On: Tue Jun 2 11:24:03 1992
+# Update Count : 75
# Status : Okay
# This package implements a new getopt function. This function adheres
# for mandatory arguments or ":" for optional arguments) and an
# argument type specifier: "n" or "i" for integer numbers, "f" for
# real (fix) numbers or "s" for strings.
+# If an "@" sign is appended, the option is treated as an array.
+# Value(s) are not set, but pushed.
#
# - if the first option of the list consists of non-alphanumeric
# characters only, it is interpreted as a generic option starter.
# will be considered an option.
# Likewise, a double occurrence (e.g. "--") signals end of
# the options list.
-# The default value for the starter is "-".
+# The default value for the starter is "-", "--" or "+".
#
# Upon return, the option variables, prefixed with "opt_", are defined
# and set to the respective option arguments, if any.
# -foo -bar -> $opt_foo = '-bar'
# -foo -- -> $opt_foo = '--'
#
-
# HISTORY
+# 2-Jun-1992 Johan Vromans
+# Do not use //o to allow multiple NGetOpt calls with different delimeters.
+# Prevent typeless option from using previous $array state.
+# Prevent empty option from being eaten as a (negative) number.
+
+# 25-May-1992 Johan Vromans
+# Add array options. "foo=s@" will return an array @opt_foo that
+# contains all values that were supplied. E.g. "-foo one -foo -two" will
+# return @opt_foo = ("one", "-two");
+# Correct bug in handling options that allow for a argument when followed
+# by another option.
+
+# 4-May-1992 Johan Vromans
+# Add $ignorecase to match options in either case.
+# Allow '' option.
+
+# 19-Mar-1992 Johan Vromans
+# Allow require from packages.
+# NGetOpt is now defined in the package that requires it.
+# @ARGV and $opt_... are taken from the package that calls it.
+# Use standard (?) option prefixes: -, -- and +.
+
# 20-Sep-1990 Johan Vromans
# Set options w/o argument to 1.
# Correct the dreadful semicolon/require bug.
-package newgetopt;
+{ package newgetopt;
+ $debug = 0; # for debugging
+ $ignorecase = 1; # ignore case when matching options
+}
+
+sub NGetOpt {
+
+ @newgetopt'optionlist = @_;
+ *newgetopt'ARGV = *ARGV;
-$debug = 0; # for debugging
+ package newgetopt;
-sub main'NGetOpt {
- local (@optionlist) = @_;
local ($[) = 0;
- local ($genprefix) = "-";
+ local ($genprefix) = "(--|-|\\+)";
+ local ($argend) = "--";
local ($error) = 0;
- local ($opt, $optx, $arg, $type, $mand, @hits);
+ local ($opt, $optx, $arg, $type, $mand, %opctl);
+ local ($pkg) = (caller)[0];
+
+ print STDERR "NGetOpt 1.13 -- called from $pkg\n" if $debug;
# See if the first element of the optionlist contains option
# starter characters.
- $genprefix = shift (@optionlist) if $optionlist[0] =~ /^\W+$/;
-
- # Turn into regexp.
- $genprefix =~ s/(\W)/\\\1/g;
- $genprefix = "[" . $genprefix . "]";
+ if ( $optionlist[0] =~ /^\W+$/ ) {
+ $genprefix = shift (@optionlist);
+ # Turn into regexp.
+ $genprefix =~ s/(\W)/\\\1/g;
+ $genprefix = "[" . $genprefix . "]";
+ undef $argend;
+ }
# Verify correctness of optionlist.
- @hits = grep ($_ !~ /^\w+([=:][infse])?$/, @optionlist);
- if ( $#hits >= 0 ) {
- foreach $opt ( @hits ) {
+ %opctl = ();
+ foreach $opt ( @optionlist ) {
+ $opt =~ tr/A-Z/a-z/ if $ignorecase;
+ if ( $opt !~ /^(\w*)([=:][infse]@?)?$/ ) {
print STDERR ("Error in option spec: \"", $opt, "\"\n");
$error++;
+ next;
+ }
+ $opctl{$1} = defined $2 ? $2 : "";
+ }
+
+ return 0 if $error;
+
+ if ( $debug ) {
+ local ($arrow, $k, $v);
+ $arrow = "=> ";
+ while ( ($k,$v) = each(%opctl) ) {
+ print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
+ $arrow = " ";
}
- return 0;
}
# Process argument list
- while ( $#main'ARGV >= 0 ) { #'){
+ while ( $#ARGV >= 0 ) {
# >>> See also the continue block <<<
# Get next argument
- $opt = shift (@main'ARGV); #');
+ $opt = shift (@ARGV);
print STDERR ("=> option \"", $opt, "\"\n") if $debug;
$arg = undef;
# Check for exhausted list.
- if ( $opt =~ /^$genprefix/o ) {
+ if ( $opt =~ /^$genprefix/ ) {
# Double occurrence is terminator
- return ($error == 0) if $opt eq "$+$+";
+ return ($error == 0)
+ if ($opt eq "$+$+") || ((defined $argend) && $opt eq $argend);
$opt = $'; # option name (w/o prefix)
}
else {
# Apparently not an option - push back and exit.
- unshift (@main'ARGV, $opt); #');
+ unshift (@ARGV, $opt);
return ($error == 0);
}
- # Grep in option list. Hide regexp chars from option.
- ($optx = $opt) =~ s/(\W)/\\\1/g;
- @hits = grep (/^$optx([=:].+)?$/, @optionlist);
- if ( $#hits != 0 ) {
+ # Look it up.
+ $opt =~ tr/A-Z/a-z/ if $ignorecase;
+ unless ( defined ( $type = $opctl{$opt} ) ) {
print STDERR ("Unknown option: ", $opt, "\n");
$error++;
next;
}
# Determine argument status.
- undef $type;
- $type = $+ if $hits[0] =~ /[=:].+$/;
- print STDERR ("=> found \"$hits[0]\" for ", $opt, "\n") if $debug;
+ print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
# If it is an option w/o argument, we're almost finished with it.
- if ( ! defined $type ) {
+ if ( $type eq "" ) {
$arg = 1; # supply explicit value
+ $array = 0;
next;
}
# Get mandatory status and type info.
- ($mand, $type) = $type =~ /^(.)(.)$/;
+ ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
# Check if the argument list is exhausted.
- if ( $#main'ARGV < 0 ) { #'){
+ if ( $#ARGV < 0 ) {
# Complain if this option needs an argument.
if ( $mand eq "=" ) {
}
# Get (possibly optional) argument.
- $arg = shift (@main'ARGV); #');
+ $arg = shift (@ARGV);
# Check if it is a valid argument. A mandatory string takes
- # anything.
- if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/o ) {
+ # anything.
+ if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/ ) {
# Check for option list terminator.
- if ( $arg eq "$+$+" ) {
+ if ( $arg eq "$+$+" ||
+ ((defined $argend) && $arg eq $argend)) {
+ # Push back so the outer loop will terminate.
+ unshift (@ARGV, $arg);
# Complain if an argument is required.
if ($mand eq "=") {
print STDERR ("Option ", $opt, " requires an argument\n");
$error++;
+ undef $arg; # don't assign it
+ }
+ else {
+ # Supply empty value.
+ $arg = $type eq "s" ? "" : 0;
}
- # Push back so the outer loop will terminate.
- unshift (@main'ARGV, $arg); #');
- $arg = ""; # don't assign it
next;
}
# Maybe the optional argument is the next option?
- if ( $mand eq ":" && $' =~ /[a-zA-Z_]/ ) {
+ if ( $mand eq ":" && ($' eq "" || $' =~ /[a-zA-Z_]/) ) {
# Yep. Push back.
- unshift (@main'ARGV, $arg); #');
- $arg = ""; # don't assign it
+ unshift (@ARGV, $arg);
+ $arg = $type eq "s" ? "" : 0;
next;
}
}
if ( $type eq "n" || $type eq "i" ) { # numeric/integer
if ( $arg !~ /^-?[0-9]+$/ ) {
print STDERR ("Value \"", $arg, "\" invalid for option ",
- $opt, " (numeric required)\n");
+ $opt, " (number expected)\n");
$error++;
+ undef $arg; # don't assign it
}
next;
}
if ( $type eq "f" ) { # fixed real number, int is also ok
if ( $arg !~ /^-?[0-9.]+$/ ) {
print STDERR ("Value \"", $arg, "\" invalid for option ",
- $opt, " (real number required)\n");
+ $opt, " (real number expected)\n");
$error++;
+ undef $arg; # don't assign it
}
next;
}
}
continue {
- print STDERR ("=> \$main'opt_$opt = $arg\n") if $debug;
- eval ("\$main'opt_$opt = \$arg");
+ if ( defined $arg ) {
+ if ( $array ) {
+ print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
+ if $debug;
+ eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
+ }
+ else {
+ print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
+ if $debug;
+ eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
+ }
+ }
}
return ($error == 0);
--- /dev/null
+# &open2: tom christiansen, <tchrist@convex.com>
+#
+# usage: $pid = &open2('rdr', 'wtr', 'some cmd and args');
+# or $pid = &open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
+#
+# spawn the given $cmd and connect $rdr for
+# reading and $wtr for writing. return pid
+# of child, or 0 on failure.
+#
+# WARNING: this is dangerous, as you may block forever
+# unless you are very careful.
+#
+# $wtr is left unbuffered.
+#
+# abort program if
+# rdr or wtr are null
+# pipe or fork or exec fails
+
+package open2;
+$fh = 'FHOPEN000'; # package static in case called more than once
+
+sub main'open2 {
+ local($kidpid);
+ local($dad_rdr, $dad_wtr, @cmd) = @_;
+
+ $dad_rdr ne '' || die "open2: rdr should not be null";
+ $dad_wtr ne '' || die "open2: wtr should not be null";
+
+ # force unqualified filehandles into callers' package
+ local($package) = caller;
+ $dad_rdr =~ s/^[^']+$/$package'$&/;
+ $dad_wtr =~ s/^[^']+$/$package'$&/;
+
+ local($kid_rdr) = ++$fh;
+ local($kid_wtr) = ++$fh;
+
+ pipe($dad_rdr, $kid_wtr) || die "open2: pipe 1 failed: $!";
+ pipe($kid_rdr, $dad_wtr) || die "open2: pipe 2 failed: $!";
+
+ if (($kidpid = fork) < 0) {
+ die "open2: fork failed: $!";
+ } elsif ($kidpid == 0) {
+ close $dad_rdr; close $dad_wtr;
+ open(STDIN, "<&$kid_rdr");
+ open(STDOUT, ">&$kid_wtr");
+ warn "execing @cmd\n" if $debug;
+ exec @cmd;
+ die "open2: exec of @cmd failed";
+ }
+ close $kid_rdr; close $kid_wtr;
+ select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
+ $kidpid;
+}
+1; # so require is happy
-/* $RCSfile: malloc.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 17:57:40 $
+/* $RCSfile: malloc.c,v $$Revision: 4.0.1.4 $$Date: 92/06/08 14:28:38 $
*
* $Log: malloc.c,v $
+ * Revision 4.0.1.4 92/06/08 14:28:38 lwall
+ * patch20: removed implicit int declarations on functions
+ * patch20: hash tables now split only if the memory is available to do so
+ * patch20: realloc(0, size) now does malloc in case library routines call it
+ *
* Revision 4.0.1.3 91/11/05 17:57:40 lwall
* patch11: safe malloc code now integrated into Perl's malloc when possible
*
#ifdef debug
#define ASSERT(p) if (!(p)) botch("p"); else
-static
+static void
botch(s)
char *s;
{
MALLOCPTRTYPE *
malloc(nbytes)
- register unsigned nbytes;
+ register MEM_SIZE nbytes;
{
register union overhead *p;
register int bucket = 0;
- register unsigned shiftr;
+ register MEM_SIZE shiftr;
#ifdef safemalloc
#ifdef DEBUGGING
- int size = nbytes;
+ MEM_SIZE size = nbytes;
#endif
#ifdef MSDOS
if (nbytes > 0xffff) {
- fprintf(stderr, "Allocation too large: %lx\n", nbytes);
+ fprintf(stderr, "Allocation too large: %lx\n", (long)nbytes);
exit(1);
}
#endif /* MSDOS */
morecore(bucket);
if ((p = (union overhead *)nextf[bucket]) == NULL) {
#ifdef safemalloc
- fputs("Out of memory!\n", stderr);
- exit(1);
+ if (!nomemok) {
+ fputs("Out of memory!\n", stderr);
+ exit(1);
+ }
#else
return (NULL);
#endif
#ifdef safemalloc
#ifdef DEBUGGING
-# ifndef I286
+# if !(defined(I286) || defined(atarist))
if (debug & 128)
- fprintf(stderr,"0x%x: (%05d) malloc %d bytes\n",p+1,an++,size);
+ fprintf(stderr,"0x%x: (%05d) malloc %ld bytes\n",p+1,an++,(long)size);
# else
if (debug & 128)
- fprintf(stderr,"0x%lx: (%05d) malloc %d bytes\n",p+1,an++,size);
+ fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",p+1,an++,(long)size);
# endif
#endif
#endif /* safemalloc */
/* remove from linked list */
#ifdef RCHECK
if (*((int*)p) & (sizeof(union overhead) - 1))
-#ifndef I286
+#if !(defined(I286) || defined(atarist))
fprintf(stderr,"Corrupt malloc ptr 0x%x at 0x%x\n",*((int*)p),p);
#else
fprintf(stderr,"Corrupt malloc ptr 0x%lx at 0x%lx\n",*((int*)p),p);
register union overhead *op;
register int rnu; /* 2^rnu bytes will be requested */
register int nblks; /* become nblks blocks of the desired size */
- register int siz;
+ register MEM_SIZE siz;
if (nextf[bucket])
return;
* on a page boundary. Should
* make getpageize call?
*/
+#ifndef atarist /* on the atari we dont have to worry about this */
op = (union overhead *)sbrk(0);
#ifndef I286
if ((int)op & 0x3ff)
#else
/* The sbrk(0) call on the I286 always returns the next segment */
#endif
+#endif /* atarist */
-#ifndef I286
+#if !(defined(I286) || defined(atarist))
/* take 2k unless the block is bigger than that */
rnu = (bucket <= 8) ? 11 : bucket + 3;
#else
/* take 16k unless the block is bigger than that
- (80286s like large segments!) */
+ (80286s like large segments!), probably good on the atari too */
rnu = (bucket <= 11) ? 14 : bucket + 3;
#endif
nblks = 1 << (rnu - (bucket + 3)); /* how many blocks to get */
if (rnu < bucket)
rnu = bucket;
- op = (union overhead *)sbrk(1 << rnu);
+ op = (union overhead *)sbrk(1L << rnu);
/* no more room! */
if ((int)op == -1)
return;
*/
#ifndef I286
if ((int)op & 7) {
- op = (union overhead *)(((int)op + 8) &~ 7);
+ op = (union overhead *)(((MEM_SIZE)op + 8) &~ 7);
nblks--;
}
#else
free(mp)
MALLOCPTRTYPE *mp;
{
- register int size;
+ register MEM_SIZE size;
register union overhead *op;
char *cp = (char*)mp;
#ifdef safemalloc
#ifdef DEBUGGING
-# ifndef I286
+# if !(defined(I286) || defined(atarist))
if (debug & 128)
fprintf(stderr,"0x%x: (%05d) free\n",cp,an++);
# else
MALLOCPTRTYPE *
realloc(mp, nbytes)
MALLOCPTRTYPE *mp;
- unsigned nbytes;
+ MEM_SIZE nbytes;
{
- register u_int onb;
+ register MEM_SIZE onb;
union overhead *op;
char *res;
register int i;
#ifdef safemalloc
#ifdef DEBUGGING
- int size = nbytes;
+ MEM_SIZE size = nbytes;
#endif
#ifdef MSDOS
}
#endif /* MSDOS */
if (!cp)
- fatal("Null realloc");
+ return malloc(nbytes);
#ifdef DEBUGGING
if ((long)nbytes < 0)
fatal("panic: realloc");
#endif
#endif /* safemalloc */
- if (cp == NULL)
- return (malloc(nbytes));
op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
if (op->ov_magic == MAGIC) {
was_alloced++;
(i = findbucket(op, reall_srchlen)) < 0)
i = 0;
}
- onb = (1 << (i + 3)) - sizeof (*op) - RSLOP;
+ onb = (1L << (i + 3)) - sizeof (*op) - RSLOP;
/* avoid the copy if same size block */
if (was_alloced &&
nbytes <= onb && nbytes > (onb >> 1) - sizeof(*op) - RSLOP) {
if ((res = (char*)malloc(nbytes)) == NULL)
return (NULL);
if (cp != res) /* common optimization */
- bcopy(cp, res, (int)(nbytes < onb ? nbytes : onb));
+ Copy(cp, res, (MEM_SIZE)(nbytes<onb?nbytes:onb), char);
if (was_alloced)
free(cp);
}
#ifdef safemalloc
#ifdef DEBUGGING
-# ifndef I286
+# if !(defined(I286) || defined(atarist))
if (debug & 128) {
fprintf(stderr,"0x%x: (%05d) rfree\n",res,an++);
- fprintf(stderr,"0x%x: (%05d) realloc %d bytes\n",res,an++,size);
+ fprintf(stderr,"0x%x: (%05d) realloc %ld bytes\n",res,an++,(long)size);
}
# else
if (debug & 128) {
fprintf(stderr,"0x%lx: (%05d) rfree\n",res,an++);
- fprintf(stderr,"0x%lx: (%05d) realloc %d bytes\n",res,an++,size);
+ fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n",res,an++,(long)size);
}
# endif
#endif
* header starts at ``freep''. If srchlen is -1 search the whole list.
* Return bucket number, or -1 if not found.
*/
-static
+static int
findbucket(freep, srchlen)
union overhead *freep;
int srchlen;
* for each size category, the second showing the number of mallocs -
* frees for each size category.
*/
+void
mstats(s)
char *s;
{
-/* $RCSfile: os2.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:23:06 $
+/* $RCSfile: os2.c,v $$Revision: 4.0.1.2 $$Date: 92/06/08 14:32:30 $
*
* (C) Copyright 1989, 1990 Diomidis Spinellis.
*
* License or the Artistic License, as specified in the README file.
*
* $Log: os2.c,v $
+ * Revision 4.0.1.2 92/06/08 14:32:30 lwall
+ * patch20: new OS/2 support
+ *
* Revision 4.0.1.1 91/06/07 11:23:06 lwall
* patch4: new copyright notice
*
{ return -1; }
-/* extendd chdir() */
+/* extended chdir() */
int chdir(char *path)
{
if ( path[0] != 0 && path[1] == ':' )
- DosSelectDisk(toupper(path[0]) - '@');
+ if ( DosSelectDisk(toupper(path[0]) - '@') )
+ return -1;
- DosChDir(path, 0L);
+ return DosChDir(path, 0L);
}
}
+/* wait for specific pid */
+int wait4pid(int pid, int *status, int flags)
+{
+ RESULTCODES res;
+ int endpid, rc;
+ if ( DosCwait(DCWA_PROCESS, flags ? DCWW_NOWAIT : DCWW_WAIT,
+ &res, &endpid, pid) )
+ return -1;
+ *status = res.codeResult;
+ return endpid;
+}
/* kill */
int kill(int pid, int sig)
usage(char *myname)
{
#ifdef MSDOS
- printf("\nUsage: %s [-acdnpsSvw] [-0[octal]] [-Dnumber] [-i[extension]] [-Idirectory]"
+ printf("\nUsage: %s [-acdnpPsSvw] [-0[octal]] [-Dnumber] [-i[extension]] [-Idirectory]"
#else
printf("\nUsage: %s [-acdnpPsSuUvw] [-Dnumber] [-i[extension]] [-Idirectory]"
#endif
"\n -d run scripts under debugger"
"\n -n assume 'while (<>) { ...script... }' loop arround your script"
"\n -p assume loop like -n but print line also like sed"
-#ifndef MSDOS
"\n -P run script through C preprocessor befor compilation"
-#endif
"\n -s enable some switch parsing for switches after script name"
"\n -S look for the script using PATH environment variable");
#ifndef MSDOS
(-W1 -Od -Olt -DDEBUGGING -Gt2048
array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c form.c
-hash.c perl.c perly.c regcomp.c regexec.c stab.c str.c util.c
+hash.c perl.c regcomp.c regexec.c stab.c str.c util.c
)
-(-W1 -Od -Olt -B2C2L -B3C3L -DDEBUGGING eval.c{evalargs.xc} toke.c)
+(-W1 -Od -Olt -DDEBUGGING -Gt2048 (-d perly.y))
+(-W1 -Od -Olt -B2C2L -B3C3L -DDEBUGGING eval.c toke.c)
(-W1 -Od -Olt -I. -Ios2
-os2\os2.c os2\popen.c os2\mktemp.c os2\director.c os2\suffix.c os2\alarm.c
+os2\os2.c os2\popen.c os2\suffix.c
+os2\director.c os2\alarm.c os2\crypt.c
)
; link with this library if you have GNU gdbm for OS/2
-; remember to enable the NDBM symbol in config.h before compiling
-lgdbm.lib
+; remember to enable the GDBM symbol in config.h before compiling
+llibgdbm.lib
+
setargv.obj
os2\perl.def
os2\perl.bad
-NAME PERL WINDOWCOMPAT NEWFILES
-DESCRIPTION 'PERL 3.0 - for MS-DOS and OS/2'
+NAME WINDOWCOMPAT NEWFILES
+DESCRIPTION 'PERL 4.0 - for MS-DOS and OS/2'
-*** lib/perldb.pl Tue Oct 23 23:14:20 1990
---- os2/perldb.pl Tue Nov 06 21:13:42 1990
-***************
-*** 36,43 ****
- #
- #
-
-! open(IN, "</dev/tty") || open(IN, "<&STDIN"); # so we don't dingle stdin
-! open(OUT,">/dev/tty") || open(OUT, ">&STDOUT"); # so we don't dongle stdout
- select(OUT);
- $| = 1; # for DB'OUT
- select(STDOUT);
---- 36,43 ----
- #
- #
-
-! open(IN, "<con") || open(IN, "<&STDIN"); # so we don't dingle stdin
-! open(OUT,">con") || open(OUT, ">&STDOUT"); # so we don't dongle stdout
- select(OUT);
- $| = 1; # for DB'OUT
- select(STDOUT);
-***************
-*** 517,530 ****
- s/(.*)/'$1'/ unless /^-?[\d.]+$/;
- }
-
-! if (-f '.perldb') {
-! do './.perldb';
- }
-! elsif (-f "$ENV{'LOGDIR'}/.perldb") {
-! do "$ENV{'LOGDIR'}/.perldb";
- }
-! elsif (-f "$ENV{'HOME'}/.perldb") {
-! do "$ENV{'HOME'}/.perldb";
- }
-
- 1;
---- 517,530 ----
- s/(.*)/'$1'/ unless /^-?[\d.]+$/;
- }
-
-! if (-f 'perldb.ini') {
-! do './perldb.ini';
- }
-! elsif (-f "$ENV{'INIT'}/perldb.ini") {
-! do "$ENV{'INIT'}/perldb.ini";
- }
-! elsif (-f "$ENV{'HOME'}/perldb.ini") {
-! do "$ENV{'HOME'}/perldb.ini";
- }
-
- 1;
-DOSQFSATTACH
+(deprecated)
-#define PATCHLEVEL 27
+#define PATCHLEVEL 28
-/* $RCSfile: perl.h,v $$Revision: 4.0.1.5 $$Date: 91/11/11 16:41:07 $
+/* $RCSfile: perl.h,v $$Revision: 4.0.1.6 $$Date: 92/06/08 14:55:10 $
*
* Copyright (c) 1991, Larry Wall
*
* License or the Artistic License, as specified in the README file.
*
* $Log: perl.h,v $
+ * Revision 4.0.1.6 92/06/08 14:55:10 lwall
+ * patch20: added Atari ST portability
+ * patch20: bcopy() and memcpy() now tested for overlap safety
+ * patch20: Perl now distinguishes overlapped copies from non-overlapped
+ * patch20: removed implicit int declarations on functions
+ *
* Revision 4.0.1.5 91/11/11 16:41:07 lwall
* patch19: uts wrongly defines S_ISDIR() et al
* patch19: too many preprocessors can't expand a macro right in #if
char Error[1];
#endif
-#ifdef MSDOS
+/* define this once if either system, instead of cluttering up the src */
+#if defined(MSDOS) || defined(atarist)
+#define DOSISH 1
+#endif
+
+#ifdef DOSISH
/* This stuff now in the MS-DOS config.h file. */
#else /* !MSDOS */
/* Use all the "standard" definitions */
#include <stdlib.h>
#include <string.h>
+#define MEM_SIZE size_t
+#else
+typedef unsigned int MEM_SIZE;
#endif /* STANDARD_C */
-#if defined(HAS_MEMCMP) && defined(mips) && BYTEORDER == 0x1234
+#if defined(HAS_MEMCMP) && defined(mips) && defined(ultrix)
#undef HAS_MEMCMP
#endif
#ifdef HAS_MEMCPY
-
# ifndef STANDARD_C
# ifndef memcpy
-extern char * memcpy(), *memset();
-extern int memcmp();
-# endif /* ndef memcpy */
-# endif /* ndef STANDARD_C */
+ extern char * memcpy();
+# endif
+# endif
+#else
+# ifndef memcpy
+# ifdef HAS_BCOPY
+# define memcpy(d,s,l) bcopy(s,d,l)
+# else
+# define memcpy(d,s,l) my_bcopy(s,d,l)
+# endif
+# endif
+#endif /* HAS_MEMCPY */
-# ifndef bcopy
-# define bcopy(s1,s2,l) memcpy(s2,s1,l)
+#ifdef HAS_MEMSET
+# ifndef STANDARD_C
+# ifndef memset
+ extern char *memset();
+# endif
+# endif
+# define memzero(d,l) memset(d,0,l)
+#else
+# ifndef memzero
+# ifdef HAS_BZERO
+# define memzero(d,l) bzero(d,l)
+# else
+# define memzero(d,l) my_bzero(d,l)
+# endif
# endif
-# ifndef bzero
-# define bzero(s,l) memset(s,0,l)
+#endif /* HAS_MEMSET */
+
+#ifdef HAS_MEMCMP
+# ifndef STANDARD_C
+# ifndef memcmp
+ extern int memcmp();
+# endif
+# endif
+#else
+# ifndef memcmp
+# define memcmp(s1,s2,l) my_memcmp(s1,s2,l)
# endif
-#endif /* HAS_MEMCPY */
+#endif /* HAS_MEMCMP */
-#ifndef HAS_BCMP /* prefer bcmp slightly 'cuz it doesn't order */
+/* we prefer bcmp slightly for comparisons that don't care about ordering */
+#ifndef HAS_BCMP
# ifndef bcmp
# define bcmp(s1,s2,l) memcmp(s1,s2,l)
# endif
+#endif /* HAS_BCMP */
+
+#ifndef HAS_MEMMOVE
+#if defined(HAS_BCOPY) && defined(SAFE_BCOPY)
+#define memmove(d,s,l) bcopy(s,d,l)
+#else
+#if defined(HAS_MEMCPY) && defined(SAFE_MEMCPY)
+#define memmove(d,s,l) memcpy(d,s,l)
+#else
+#define memmove(d,s,l) my_bcopy(s,d,l)
+#endif
+#endif
#endif
#ifndef _TYPES_ /* If types.h defines this it's easy. */
#endif
#include <sys/stat.h>
-#ifdef uts
+#if defined(uts) || defined(UTekV)
#undef S_ISDIR
#undef S_ISCHR
#undef S_ISBLK
#define S_ISBLK(P) (((P)&S_IFMT)==S_IFBLK)
#define S_ISREG(P) (((P)&S_IFMT)==S_IFREG)
#define S_ISFIFO(P) (((P)&S_IFMT)==S_IFIFO)
+#ifdef S_IFLNK
#define S_ISLNK(P) (((P)&S_IFMT)==S_IFLNK)
#endif
+#endif
#ifdef I_TIME
# include <time.h>
#endif
#endif
-#if defined(mc300) || defined(mc500) || defined(mc700) /* MASSCOMP */
+#if defined(mc300) || defined(mc500) || defined(mc700) || defined(mc6000)
#ifdef HAS_SOCKETPAIR
#undef HAS_SOCKETPAIR
#endif
#undef f_next
#endif
-#if defined(cray) || defined(gould)
+#if defined(cray) || defined(gould) || defined(i860)
# define SLOPPYDIVIDE
#endif
# endif
#endif
-typedef unsigned int STRLEN;
+typedef MEM_SIZE STRLEN;
typedef struct arg ARG;
typedef struct cmd CMD;
#define GROWSTR(pp,lp,len) if (*(lp) < (len)) growstr(pp,lp,len)
-#ifndef MSDOS
+#ifndef DOSISH
#define STR_GROW(str,len) if ((str)->str_len < (len)) str_grow(str,len)
#define Str_Grow str_grow
#else
#define STR_GROW(str,len) if ((str)->str_len < (unsigned long)len) \
str_grow(str,(unsigned long)len)
#define Str_Grow(str,len) str_grow(str,(unsigned long)(len))
-#endif /* MSDOS */
+#endif /* DOSISH */
#ifndef BYTEORDER
#define BYTEORDER 0x1234
STR *str_new();
STR *stab_str();
+int apply();
int do_each();
int do_subr();
int do_match();
int do_subst();
int cando();
int ingroup();
+int whichsig();
+int userinit();
+#ifdef CRYPTSCRIPT
+void cryptswitch();
+#endif
void str_replace();
void str_inc();
void str_dec();
void str_free();
+void cmd_free();
+void arg_free();
+void spat_free();
+void regfree();
void stab_clear();
+void do_chop();
+void do_vop();
+void do_write();
void do_join();
void do_sprintf();
void do_accept();
void savehptr();
void restorelist();
void repeatcpy();
+void make_form();
+void dehoist();
+void format();
+void my_unexec();
+void fatal();
+void warn();
+#ifdef DEBUGGING
+void dump_all();
+void dump_cmd();
+void dump_arg();
+void dump_flags();
+void dump_stab();
+void dump_spat();
+#endif
+#ifdef MSTATS
+void mstats();
+#endif
+
HASH *savehash();
ARRAY *saveary();
EXT STR *DBsingle INIT(Nullstr);
EXT STR *DBtrace INIT(Nullstr);
EXT STR *DBsignal INIT(Nullstr);
+EXT STR *formfeed INIT(Nullstr);
EXT int lastspbase;
EXT int lastsize;
EXT char *rs INIT("\n");
EXT int rschar INIT('\n'); /* final char of rs, or 0777 if none */
EXT int rslen INIT(1);
+EXT bool rspara INIT(FALSE);
EXT char *ofs INIT(Nullch);
EXT int ofslen INIT(0);
EXT char *ors INIT(Nullch);
EXT int maxsysfd INIT(MAXSYSFD); /* top fd to pass to subprocesses */
#ifdef CSH
-char *cshname INIT(CSH);
-int cshlen INIT(0);
+EXT char *cshname INIT(CSH);
+EXT int cshlen INIT(0);
#endif /* CSH */
#ifdef TAINT
EXT bool tainted INIT(FALSE); /* using variables controlled by $< */
+EXT bool taintanyway INIT(FALSE); /* force taint checks when !set?id */
#endif
-#ifndef MSDOS
+EXT bool nomemok INIT(FALSE); /* let malloc context handle nomem */
+
+#ifndef DOSISH
#define TMPPATH "/tmp/perl-eXXXXXX"
#else
#define TMPPATH "plXXXXXX"
EXT struct stat statbuf;
EXT struct stat statcache;
-STAB *statstab INIT(Nullstab);
-STR *statname;
+EXT STAB *statstab INIT(Nullstab);
+EXT STR *statname;
#ifndef MSDOS
EXT struct tms timesbuf;
#endif
EXT short *ds;
/* Fix these up for __STDC__ */
-EXT long basetime INIT(0);
+EXT time_t basetime INIT(0);
char *mktemp();
#ifndef STANDARD_C
/* All of these are in stdlib.h or time.h for ANSI C */
#define HAS_SETREGID
#endif
#endif
+
+#define SCAN_DEF 0
+#define SCAN_TR 1
+#define SCAN_REPL 2
projects / p5sagit/p5-mst-13.2.git / commitdiff