Commit 1f85867d authored by Juergen Nickelsen's avatar Juergen Nickelsen

Bread (stdin or string); rename readob -> Read; tests 035

parent da91d47e
......@@ -20,6 +20,18 @@ use Interp;
# Builtins get their arguments directly as a Lisp list, have names
# beginning with 'B', and are defined here (except for, well, exceptions)
sub Bread {
my ($arglist) = @_;
my ($input) = checkargs($arglist, ':S');
if (is_nil($input)) {
return Read::Read();
} elsif (stringp ($input)) {
return Read::Read($input);
} else {
...
}
}
sub Brandom {
my ($arglist) = @_;
my ($limit) = checkargs($arglist, ':n');
......@@ -1034,7 +1046,9 @@ my @builtins = # [name, func, is_special, doc]
["sqrt", \&Bsqrt, 0, "return the square root of numeric ARG"],
["isqrt", \&Bsqrt, 0, "return the integer square root of numeric ARG"],
["random", \&Brandom, 0,
"return a random number a with 0 <= a < LIMIT (or 1)"]
"return a random number a with 0 <= a < LIMIT (or 1)"],
["read", \&Bread, 0,
"return an expression read from stdin or &optional INPUT (a string)"],
);
for my $b (@builtins) {
......
......@@ -32,11 +32,11 @@ sub repl {
if ($interactive) {
print("> ");
# this means we are counting conses including those
# needed by readob()
# needed by Read()
eval_count(0);
cons_count(0);
}
my $expr = readob($fh);
my $expr = Read($fh);
last unless defined($expr);
eval_level(0);
......@@ -66,7 +66,7 @@ sub load {
my ($fname, $noerror, $nomessage) = @_;
my $fh;
unless (open($fh, '<', $fname)) {
unless (open($fh, "<:encoding(UTF-8)", $fname)) {
unless ($noerror) {
say("cannot open file ($!): %s", $fname);
return $Nil;
......@@ -74,6 +74,7 @@ sub load {
return error("cannot open file ($!) %s", $fname);
}
print(";; loading file $fname ... ") unless $nomessage;
$| = 1;
my $result = repl($fh, 0);
close($fh);
if (defined($result) && !$nomessage) {
......
......@@ -17,7 +17,7 @@ use Exporter ();
BEGIN {
@ISA = qw(Exporter);
@EXPORT = qw( readob
@EXPORT = qw( Read
);
}
......@@ -25,9 +25,15 @@ my $default_input = \*STDIN;
my $sepchars = quotemeta("();\n");
sub readob {
sub Read {
my ($in) = @_;
$in //= $default_input;
if (stringp($in)) {
my $string = $in;
open(my $str_in, "<", \$string) or
error("read: cannot open string as filehandle: $!\n");
$in = $str_in;
}
my $t = next_token($in);
#warn("next token: $t");
......@@ -40,11 +46,11 @@ sub readob {
unless $closer eq ')';
return $list;
} elsif ($t eq '\'') {
$t = readob($in);
$t = Read($in);
return error("EOF in quote: %s", $in) unless defined($t);
return list(intern($Quote), $t);
} elsif ($t eq '#\'') {
$t = readob($in);
$t = Read($in);
return error("EOF in quote %s", $in) unless defined($t);
return list(intern($function), $t);
} elsif ($t eq '.') {
......@@ -53,6 +59,8 @@ sub readob {
return $t;
} elsif ($t =~ m{^\"}) {
return substr($t, 1);
} elsif ($t eq ')') {
return error("close paren unexpected");
} else {
return $t;
}
......@@ -72,7 +80,7 @@ sub read_list_elems {
return error("syntax: . at start of list: %s",
$in)
unless $end;
my $sexpr = readob($in);
my $sexpr = Read($in);
return undef unless defined($t);
$t = next_token($in);
return error("syntax: no ) after improper list: %s",
......@@ -83,7 +91,7 @@ sub read_list_elems {
return $list;
} else {
push_back_token($t);
my $sexpr = readob($in);
my $sexpr = Read($in);
return undef unless defined($sexpr);
my $newpair = cons($sexpr, $Nil);
if ($end) {
......
(testcmp "read simple" '(cons (read "tangeldadder") nil) "(tangeldadder)")
(testcmp "read defun" '(progn (eval (read "(defun q (n) (* n n))"))
(q 13)) "169")
(testcmp "read error 1" '(or (errset (progn
(eval (read "(defun q (n) (* n n)"))
(q 13)))
(car (split-string *last-error* ": ")))
"EOF while reading list elements")
(testcmp "read error 2" '(or (errset (progn
(eval (read ")(defun q (n) (* n n))"))
(q 13)))
(car (split-string *last-error* ": ")))
"close paren unexpected")
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