Skip to content

L
lis.pl
Commit 07380576 authored by Juergen Nickelsen's avatar Juergen Nickelsen
Browse files
Options

checkargs call with $_[0] to save the expense of the arglist variable

parent 27a5037a
Hide whitespace changes
Inline Side-by-side
Showing with 63 additions and 126 deletions
Builtin.pm
View file @ 07380576
......@@ -21,8 +21,7 @@ use Interp;
# beginning with 'B', and are defined here (except for, well, exceptions)
sub Bread {
my ($arglist) = @_;
my ($input) = checkargs($arglist, ':S');
my ($input) = checkargs($_[0], ':S');
if (is_nil($input)) {
return Read::Read();
} elsif (stringp ($input)) {
......@@ -33,27 +32,23 @@ sub Bread {
}
sub Brandom {
my ($arglist) = @_;
my ($limit) = checkargs($arglist, ':n');
my ($limit) = checkargs($_[0], ':n');
$limit = 1 if is_nil($limit);
return rand($limit);
}
sub Bsqrt {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'n');
my ($arg) = checkargs($_[0], 'n');
return sqrt($arg);
}
sub Bisqrt {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'n');
my ($arg) = checkargs($_[0], 'n');
return int(sqrt($arg));
}
sub Bsplit_string {
my ($arglist) = @_;
my ($string, $sep, $nonulls) = checkargs($arglist, 'S:ee');
my ($string, $sep, $nonulls) = checkargs($_[0], 'S:ee');
my $re;
if (is_nil($sep)) {
$re = ' '; # special case: white space with nonull
......@@ -72,33 +67,28 @@ sub Bignore {
}
sub Bsymbol_plist {
my ($arglist) = @_;
my ($sym) = checkargs($arglist, 'y');
my ($sym) = checkargs($_[0], 'y');
return array2list(symbol_plist($sym));
}
sub Bget {
my ($arglist) = @_;
my ($sym, $ind, $default) = checkargs($arglist, 'yy:e');
my ($sym, $ind, $default) = checkargs($_[0], 'yy:e');
return get($sym, $ind, $default);
}
sub Bput {
my ($arglist) = @_;
my ($sym, $ind, $val) = checkargs($arglist, 'yye');
my ($sym, $ind, $val) = checkargs($_[0], 'yye');
return put($sym, $ind, $val);
}
sub Bremprop {
my ($arglist) = @_;
my ($sym, $ind) = checkargs($arglist, 'yy');
my ($sym, $ind) = checkargs($_[0], 'yy');
return tornil(remprop($sym, $ind));
}
# return list of OBJECT's type, name, value, function, and property list
sub Bdescribe {
my ($arglist) = @_;
my ($ob) = checkargs($arglist, 'e');
my ($ob) = checkargs($_[0], 'e');
my $type = Btype_of(cons($ob, $Nil));
if ($type == $t_Symbol) {
return array2list($type, symbol_name($ob),
......@@ -115,15 +105,13 @@ sub Bdescribe {
}
sub Bglob_filenames {
my ($arglist) = @_;
my ($pattern) = checkargs($arglist, 'S');
my ($pattern) = checkargs($_[0], 'S');
my @entries = glob($pattern);
return array2list(@entries);
}
sub Bexit {
my ($arglist) = @_;
my ($statusarg) = checkargs($arglist, 'e');
my ($statusarg) = checkargs($_[0], 'e');
my $status;
if (is_t($statusarg)) {
$status = 0;
......@@ -138,8 +126,7 @@ sub Bexit {
}
sub Bformat {
my ($arglist) = @_;
my ($direction, $format, @args) = checkargs($arglist, 'eSR');
my ($direction, $format, @args) = checkargs($_[0], 'eSR');
@args = map {princs($_)} @args;
if (is_nil($direction)) {
return sprintf($format, @args);
......@@ -152,8 +139,7 @@ sub Bformat {
}
sub Berrset {
my ($arglist) = @_;
my ($expr) = checkargs($arglist, 'e');
my ($expr) = checkargs($_[0], 'e');
my $result = eval { Eval($expr) };
if (defined($result)) {
return cons($result, $Nil);
......@@ -166,8 +152,7 @@ sub Berrset {
}
sub Bstring_less {
my ($arglist) = @_;
my ($prev, @rest) = checkargs($arglist, 'SR');
my ($prev, @rest) = checkargs($_[0], 'SR');
while (@rest) {
my $next = princs(shift(@rest));
return $Nil unless $prev lt $next;
......@@ -177,8 +162,7 @@ sub Bstring_less {
}
sub Bstring_equal {
my ($arglist) = @_;
my ($first, @rest) = checkargs($arglist, 'SR');
my ($first, @rest) = checkargs($_[0], 'SR');
while (@rest) {
return $Nil unless princs(shift(@rest)) eq $first;
}
......@@ -186,8 +170,7 @@ sub Bstring_equal {
}
sub Bre_match {
my ($arglist) = @_;
my ($re, $string) = checkargs($arglist, 'SS');
my ($re, $string) = checkargs($_[0], 'SS');
my @result = $string =~ /$re/;
#debug("$string =~ /$re/ result: @result");
return array2list(@result);
......@@ -204,15 +187,13 @@ sub Bconcat {
}
sub Berror {
my ($arglist) = @_;
my ($format, @args) = checkargs($arglist, 'SR');
my ($format, @args) = checkargs($_[0], 'SR');
error($format, @args);
return $Nil; # not reached
}
sub Bdoc {
my ($arglist) = @_;
my ($funob, $brief, $noprint) = checkargs($arglist, 'e:ee');
my ($funob, $brief, $noprint) = checkargs($_[0], 'e:ee');
my $func = evalfun($funob);
my $doc = function_documentation($func);
my $name = symbol_name(function_name($func));
......@@ -233,35 +214,30 @@ sub Bdoc {
}
sub Bprinc {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'e');
my ($arg) = checkargs($_[0], 'e');
princ($arg);
return $arg;
}
sub Bprincs {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'e');
my ($arg) = checkargs($_[0], 'e');
return princs($arg);
}
sub Bprin1 {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'e');
my ($arg) = checkargs($_[0], 'e');
prin1($arg);
return $arg;
}
sub Bprint {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'e');
my ($arg) = checkargs($_[0], 'e');
Lprint($arg);
return $arg;
}
sub Bterpri {
my ($arglist) = @_;
checkargs($arglist, '');
checkargs($_[0], '');
terpri();
return $Nil;
}
......@@ -406,14 +382,12 @@ sub Blet {
}
sub Bload {
my ($arglist) = @_;
my ($fname, $noerror, $nomessage) = checkargs($arglist, 'S:ee');
my ($fname, $noerror, $nomessage) = checkargs($_[0], 'S:ee');
return load($fname, $noerror, $nomessage);
}
sub Bapropos {
my ($arglist) = @_;
my ($re) = checkargs($arglist, ':S');
my ($re) = checkargs($_[0], ':S');
$re = '.' if is_nil($re);
my $result = $Nil;
my $end;
......@@ -432,8 +406,7 @@ sub Bapropos {
}
sub Beq {
my ($arglist) = @_;
my ($arg1, $arg2) = checkargs($arglist, 'ee');
my ($arg1, $arg2) = checkargs($_[0], 'ee');
my $type1 = ref($arg1);
my $type2 = ref($arg2);
......@@ -446,8 +419,7 @@ sub Beq {
}
sub Bif {
my ($arglist) = @_;
my ($condexpr, $thenclause, @elseclauses) = checkargs($arglist, 'eeR');
my ($condexpr, $thenclause, @elseclauses) = checkargs($_[0], 'eeR');
my $cond = eval { Eval($condexpr) };
unless (defined($cond)) {
say("if cond: ", princs($condexpr));
......@@ -476,14 +448,12 @@ sub Bif {
}
sub Blambda {
my ($arglist) = @_;
my ($params, $body) = checkargs($arglist, 'lr');
my ($params, $body) = checkargs($_[0], 'lr');
return make_lambda($params, $body, 0, $Lambda);
}
sub Bkappa {
my ($arglist) = @_;
my ($params, $body) = checkargs($arglist, 'lr');
my ($params, $body) = checkargs($_[0], 'lr');
return make_lambda($params, $body, 1, $Lambda);
}
......@@ -505,14 +475,12 @@ sub make_named_function {
}
sub Bdefspecial {
my ($arglist) = @_;
my ($name, $params, $body) = checkargs($arglist, 'ylr');
my ($name, $params, $body) = checkargs($_[0], 'ylr');
return make_named_function($name, $params, $body, 1);
}
sub Bdefun {
my ($arglist) = @_;
my ($name, $params, $body) = checkargs($arglist, 'ylr');
my ($name, $params, $body) = checkargs($_[0], 'ylr');
return make_named_function($name, $params, $body, 0);
}
......@@ -522,92 +490,77 @@ sub Blist {
}
sub Bcar {
my ($arglist) = @_;
my ($list) = checkargs($arglist, 'l');
my ($list) = checkargs($_[0], 'l');
return car($list);
}
sub Bcdr {
my ($arglist) = @_;
my ($list) = checkargs($arglist, 'l');
my ($list) = checkargs($_[0], 'l');
return cdr($list);
}
sub Bintern {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 's');
my ($arg) = checkargs($_[0], 's');
return intern($arg);
}
sub Bcons {
my ($arglist) = @_;
my ($car, $cdr) = checkargs($arglist, 'ee');
my ($car, $cdr) = checkargs($_[0], 'ee');
return cons($car, $cdr);
}
sub Blistp {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'e');
my ($arg) = checkargs($_[0], 'e');
return tornil(listp($arg));
}
sub Bsymbolp {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'e');
my ($arg) = checkargs($_[0], 'e');
return tornil(symbolp($arg));
}
sub Bnumberp {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'e');
my ($arg) = checkargs($_[0], 'e');
return tornil(numberp($arg));
}
sub Bstringp {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'e');
my ($arg) = checkargs($_[0], 'e');
return tornil(stringp($arg));
}
sub Bconsp {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'e');
my ($arg) = checkargs($_[0], 'e');
return tornil(consp($arg));
}
sub Bfunctionp {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'e');
my ($arg) = checkargs($_[0], 'e');
return tornil(functionp($arg));
}
sub Bsymbol_name {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'y');
my ($arg) = checkargs($_[0], 'y');
return symbol_name($arg);
}
sub Bsymbol_function {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'y');
my ($arg) = checkargs($_[0], 'y');
return symbol_function($arg);
}
sub Brplaca {
my ($arglist) = @_;
my ($arg1, $arg2) = checkargs($arglist, 'pe');
my ($arg1, $arg2) = checkargs($_[0], 'pe');
return rplaca($arg1, $arg2);
}
sub Brplacd {
my ($arglist) = @_;
my ($arg1, $arg2) = checkargs($arglist, 'pe');
my ($arg1, $arg2) = checkargs($_[0], 'pe');
return rplacd($arg1, $arg2);
}
sub Bfset {
my ($arglist) = @_;
my ($sym, $func) = checkargs($arglist, 'ye');
my ($sym, $func) = checkargs($_[0], 'ye');
return fset($sym, $func);
}
......@@ -724,20 +677,17 @@ sub Bor {
}
sub Bfunction {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'e');
my ($arg) = checkargs($_[0], 'e');
return evalfun($arg);
}
sub Bquote {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'e');
my ($arg) = checkargs($_[0], 'e');
return is_def($arg);
}
sub Bdump {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'e');
my ($arg) = checkargs($_[0], 'e');
return Dumper($arg);
}
......@@ -770,8 +720,7 @@ sub Bnum_less {
}
sub Bwhile {
my ($arglist) = @_;
my ($cond, $bodyforms) = checkargs($arglist, 'er');
my ($cond, $bodyforms) = checkargs($_[0], 'er');
while (1) {
my $cval = Eval($cond);
......@@ -795,14 +744,12 @@ sub Bwhile {
}
sub Bset {
my ($arglist) = @_;
my ($symbol, $value) = checkargs($arglist, 'ye');
my ($symbol, $value) = checkargs($_[0], 'ye');
return set($symbol, $value);
}
sub Bsetq {
my ($arglist) = @_;
my ($symbol, $value) = checkargs($arglist, 'ye');
my ($symbol, $value) = checkargs($_[0], 'ye');
my $evalue = Eval($value);
unless (defined($evalue)) {
say("setq value: ", princs($value));
......@@ -812,8 +759,7 @@ sub Bsetq {
}
sub Bfuncall {
my ($arglist) = @_;
my ($func, $args) = checkargs($arglist, 'er');
my ($func, $args) = checkargs($_[0], 'er');
return funcall(evalfun($func), $args);
}
......@@ -836,8 +782,7 @@ sub spread_arglist {
}
sub Bapply {
my ($arglist) = @_;
my ($func, $arg1, $args) = checkargs($arglist, 'eer');
my ($func, $arg1, $args) = checkargs($_[0], 'eer');
my $last; # last pair of args
my $last2; # 2nd but last
if (is_nil($args)) {
......@@ -850,8 +795,7 @@ sub Bapply {
}
sub Beval {
my ($arglist) = @_;
my ($expr) = checkargs($arglist, 'e');
my ($expr) = checkargs($_[0], 'e');
my $evalue = Eval($expr);
unless (defined($evalue)) {
say("lisp eval: ", princs($expr));
......@@ -861,15 +805,13 @@ sub Beval {
}
sub Bnull {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'e');
my ($arg) = checkargs($_[0], 'e');
return $T if is_nil($arg);
return $Nil;
}
sub Bdebug {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, ':e');
my ($arg) = checkargs($_[0], ':e');
unless (is_nil($arg)) {
if (numberp($arg)) {
debug_level($arg);
......@@ -883,34 +825,29 @@ sub Bdebug {
}
sub Bboundp {
my ($arglist) = @_;
my ($sym) = checkargs($arglist, 'y');
my ($sym) = checkargs($_[0], 'y');
return tornil(defined(symbol_value($sym)));
}
sub Bfboundp {
my ($arglist) = @_;
my ($sym) = checkargs($arglist, 'y');
my ($sym) = checkargs($_[0], 'y');
return tornil(defined(symbol_function($sym)));
}
sub Bmakunbound {
my ($arglist) = @_;
my ($sym) = checkargs($arglist, 'y');
my ($sym) = checkargs($_[0], 'y');
set($sym, undef);
return $sym;
}
sub Bfmakunbound {
my ($arglist) = @_;
my ($sym) = checkargs($arglist, 'y');
my ($sym) = checkargs($_[0], 'y');
fset($sym, undef);
return $sym;
}
sub Btype_of {
my ($arglist) = @_;
my ($ob) = checkargs($arglist, 'e');
my ($ob) = checkargs($_[0], 'e');
if (symbolp($ob)) {
return $t_Symbol;;
} elsif (consp($ob)) {
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment