Skip to content

GitLab

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

changed debug to format, args style; commented calls out, tho

parent 17a5d9d6
Hide whitespace changes
Inline Side-by-side
Showing with 36 additions and 74 deletions
Builtin.pm
View file @ 27a5037a
......@@ -189,7 +189,7 @@ sub Bre_match {
my ($arglist) = @_;
my ($re, $string) = checkargs($arglist, 'SS');
my @result = $string =~ /$re/;
debug("\"$string\" =~ /$re/ result: ", @result);
#debug("$string =~ /$re/ result: @result");
return array2list(@result);
}
......@@ -286,7 +286,7 @@ sub Blabels {
push(@saved_funcs, symbol_function($var));
fset($var, $func);
debug("bind symbol", $var, "to function", $func);
#debug("bind symbol %s to function %s", $var, $func);
$defs = cdr($defs);
}
my $result;
......@@ -298,7 +298,7 @@ sub Blabels {
# restore bindings before throwing error
for my $sym (@bind_symbols) {
my $func = shift(@saved_funcs);
debug("restore symbol", $sym, "to function", $func);
#debug("restore symbol %s to function %s", $sym, $func);
set($sym, $func);
}
unless (defined($result)) {
......@@ -330,7 +330,7 @@ sub Blet_star {
push(@bind_symbols, $var);
push(@saved_values, symbol_value($var));
set($var, $value);
debug("bind symbol", $var, "to", $value);
#debug("bind symbol %s to %s", $var, $value);
$defs = cdr($defs);
}
my $result;
......@@ -342,7 +342,7 @@ sub Blet_star {
# restore bindings before throwing error
for my $sym (@bind_symbols) {
my $value = shift(@saved_values);
debug("restore symbol", $sym, "to", $value);
#debug("restore symbol %s to %s", $sym, $value);
set($sym, $value);
}
unless (defined($result)) {
......@@ -380,7 +380,7 @@ sub Blet {
push(@bind_symbols, $var);
push(@saved_values, symbol_value($var));
push(@new_values, $value);
debug("bind symbol", $var, "to", $value);
#debug("bind symbol %s to %s", $var, $value);
$defs = cdr($defs);
}
for my $sym (@bind_symbols) {
......@@ -395,7 +395,7 @@ sub Blet {
# restore bindings before throwing error
for my $sym (@bind_symbols) {
my $value = shift(@saved_values);
debug("restore symbol", $sym, "to", $value);
#debug("restore symbol %s to %s", $sym, $value);
set($sym, $value);
}
unless (defined($result)) {
......@@ -458,16 +458,16 @@ sub Bif {
my $clause;
if (!is_nil($cond)) {
$clause = $thenclause;
#debug("if evals then clause", $thenclause);
#debug("if evals then clause %s", $thenclause);
$result = eval { Eval($thenclause) };
} else {
for $clause (@elseclauses) {
#debug("if evals else clause", $clause);
#debug("if evals else clause %s", $clause);
$result = eval { Eval($clause) };
last unless defined($result);
}
}
#debug("if returns", $result);
#debug("if returns %s", $result);
unless (defined($result)) {
say("if clause: ", princs($clause));
return error($@);
......@@ -744,12 +744,12 @@ sub Bdump {
sub Bnum_equal {
my ($arglist) = @_;
my $val1 = is_num(car($arglist));
#debug("val1 is", $val1);
#debug("val1 is %s", $val1);
$arglist = cdr($arglist);
while (consp($arglist)) {
my $val2 = is_num(car($arglist));
#debug("val1 is", $val1);
#debug("val2 is", $val2, "arglist", $arglist);
#debug("val1 is %s", $val1);
#debug("val2 is %s arglist %s", $val2, $arglist);
return $Nil unless $val1 == $val2;
$arglist = cdr($arglist);
}
......
Debug.pm
View file @ 27a5037a
......@@ -26,11 +26,10 @@ sub debug_level {
sub debug {
if ($debug_level) {
for (@_) {
princ($_);
princ(" ");
}
terpri();
my ($format, @args) = @_;
chomp($format);
$format .= "\n";
printf($format, map { princs($_); } @args);
}
}
......
Eval.pm
View file @ 27a5037a
......@@ -44,7 +44,7 @@ sub eval_args {
my $new = $Nil;
my $end;
debugl("eval_args on", $arglist);
#debugl("eval_args on %s", $arglist);
while (consp($arglist)) {
my $newpair = cons(Eval(car($arglist)), $Nil);
if ($end) {
......@@ -55,7 +55,7 @@ sub eval_args {
}
$arglist = cdr($arglist);
}
debugl("eval_args returns", $new);
#debugl("eval_args returns %s", $new);
return $new;
}
......@@ -85,10 +85,10 @@ sub call_form {
}
my $value = symbol_value($param);
# debugl("save", $param, "as", $value);
# debugl("save %s as %s", $param, $value);
$save{$param} = $value;
if ($inrest) {
debugl("bind rest (set", $param, $args, ")");
#debugl("bind rest (set %s %s)", $param, $args);
set($param, $args);
$args = $Nil;
return error("too many parameters after &rest: %s",
......@@ -99,7 +99,7 @@ sub call_form {
return error("too few arguments for function %s",
function_name($func))
unless $optional || consp($args);
debugl("bind param (set", $param, car($args), ")");
#debugl("bind param (set %s %s)", $param, car($args));
set($param, car($args));
$args = cdr($args);
}
......@@ -122,7 +122,7 @@ sub call_form {
$params = cdr($params);
next if $sym == $andRest;
my $value = $save{$sym};
debugl("restore: (set", $sym, $value, ")");
#debugl("restore: (set %s %s)", $sym, $value);
set($sym, $value);
}
# return error after restoring bindungs
......@@ -135,7 +135,7 @@ sub call_form {
sub funcall {
my ($func, $args) = @_;
debugl("funcall", $func, $args);
#debugl("funcall %s %s", $func, $args);
my $type = function_type($func);
my $result;
if ($type eq 'subr') {
......@@ -155,7 +155,7 @@ sub evalfun {
my $result;
while (--$max) {
if (functionp($ob)) {
debugl("evalfun function:", $ob);
#debugl("evalfun function: %s", $ob);
$result = $ob;
last;
} elsif (is_nil($ob)) {
......@@ -164,12 +164,12 @@ sub evalfun {
my $symbol = $ob;
if (my $func = symbol_function($ob)) {
$ob = $func;
debugl("evalfun symbol", $symbol,
"yields function cell:", $ob);
#debugl("evalfun symbol %s yields "
# ."function cell: %s", $symbol, $ob);
} else {
$ob = symbol_value($ob);
debugl("evalfun symbol", $symbol,
"yields value:", $ob);
#debugl("evalfun symbol %s yields value:",
# $symbol, $ob);
}
return error("undefined function %s",
symbol_name($symbol))
......@@ -177,7 +177,7 @@ sub evalfun {
} elsif (consp($ob)) {
my $form = $ob;
$ob = Eval($ob);
debugl("evalfun form", $form, "returns", $ob);
#debugl("evalfun form %s returns %s", $form, $ob);
return error("function form yields undefined: %s",
$form)
unless defined($ob);
......@@ -200,18 +200,18 @@ sub eval_count {
sub Eval {
my ($ob) = @_;
debugl("eval expr:", $ob);
#debugl("eval expr: %s", $ob);
$level++;
$eval_counter++;
my $result;
if (symbolp($ob)) {
debugl("expr is sym:", $ob);
#debugl("expr is sym: %s", $ob);
$result = symbol_value($ob);
return error("unbound variable %s", symbol_name($ob))
unless defined($result);
} elsif (consp($ob)) {
debugl("expr is cons:", $ob);
#debugl("expr is cons: %s", $ob);
my $func = evalfun(car($ob));
my $args = cdr($ob);
$args = eval_args($args) unless specialp($func);
......@@ -222,7 +222,7 @@ sub Eval {
$result = $ob;
}
$level--;
debugl("eval expr:", $ob, ", returns", $result);
#debugl("eval expr: %s, returns %s", $ob, $result);
return $result;
}
......
Read.pm
View file @ 27a5037a
......@@ -188,12 +188,12 @@ sub error_or_eof {
sub read_macro {
my ($in) = @_;
debug("read macro");
#debug("read macro");
my $c = next_nonwhite($in);
return error("unexpected EOF line $.: %s", $in) unless defined($c);
if ($c eq '\'') {
my $result = '#\'';
debug("read macro returns", $result);
#debug("read macro returns %s", $result);
return $result;
# and possibly more
} else {
......
tests/notyet/030-assoc.lisp deleted 100644 → 0
View file @ 17a5d9d6
(defvar the-alist '((3 . 4)
(7 . 5)
(lala . humdi)
(10 . 11)
((1 2 3) . 12)
("hudi" . :rudi)))
(testcmp "assoc 0" '(assoc 'lala nil) nil)
(testcmp "assoc 1" '(errset (assoc 'lala '(4))) nil)
(testcmp "assoc 2" '(assoc 'lala the-alist) '(lala . humdi))
(testcmp "assoc 3" '(assoc '(1 2 3) the-alist) '((1 2 3) . 12))
(testcmp "assoc 4" '(assoc '(1 2 5) the-alist) nil)
(testcmp "assoc 5" '(assoc 10 the-alist) '(10 . 11))
(testcmp "assq 0" '(assq 'lala nil) nil)
(testcmp "assq 1" '(errset (assq 'lala '(4))) nil)
(testcmp "assq 2" '(assq 'lala the-alist) '(lala . humdi))
(testcmp "assq 3" '(assq '(1 2 3) the-alist) nil)
(testcmp "assq 4" '(assq '(1 2 5) the-alist) nil)
(defun default () 'this)
(defvar the-function 'default)
(testcmp "sassoc 0" '(sassoc 'lala nil #'default) 'this)
(testcmp "sassoc 1" '(errset (sassoc 'lala '(4) #'default)) nil)
(testcmp "sassoc 2" '(sassoc 'lala the-alist #'default) '(lala . humdi))
(testcmp "sassoc 3" '(sassoc '(1 2 3) the-alist #'default) '((1 2 3) . 12))
(testcmp "sassoc 4" '(sassoc '(1 2 5) the-alist #'default) 'this)
(testcmp "sassoc 5" '(sassoc 10 the-alist 'default) '(10 . 11))
(testcmp "sassq 0" '(sassq 'lala nil #'default) 'this)
(testcmp "sassq 1" '(errset (sassq 'lala '(4) #'default)) nil)
(testcmp "sassq 2" '(sassq 'lala the-alist #'default) '(lala . humdi))
(testcmp "sassq 3" '(sassq '(1 2 3) the-alist #'default) 'this)
(testcmp "sassq 4" '(sassq '(1 2 5) the-alist the-function) 'this)
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