Skip to content

GitLab

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

Merge branch 'master' of ssh://git.w21.org/home/git/lis.pl 

Conflicts:
	Fundamental.lisp (resolved manually)
parents b2f0e1a6 1f85867d
Hide whitespace changes
Inline Side-by-side
Showing with 89 additions and 41 deletions
Builtin.pm
View file @ d068acdf
......@@ -17,11 +17,28 @@ use Util;
use Eval;
use Interp;
# helper functions
# 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');
$limit = 1 if is_nil($limit);
return rand($limit);
}
sub Bsqrt {
my ($arglist) = @_;
my ($arg) = checkargs($arglist, 'n');
......@@ -1028,6 +1045,10 @@ my @builtins = # [name, func, is_special, doc]
"split STRING into parts SEPARATED by SEP and return the list"],
["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)"],
["read", \&Bread, 0,
"return an expression read from stdin or &optional INPUT (a string)"],
);
for my $b (@builtins) {
......
Fundamental.lisp
View file @ d068acdf
......@@ -277,11 +277,13 @@
(apply #'string/= (cons n (cddr args)))
(apply #'string/= (cdr args))))))
(defun length (l)
"return the length of list l"
(if (null l)
(defun length (sequence)
"return the length of SEQUENCE"
(if (stringp sequence)
(setq sequence (split-string sequence "")))
(if (null sequence)
0
(1+ (length (cdr l)))))
(1+ (length (cdr sequence)))))
(defun strlen (s)
"return the length of string S"
......@@ -378,29 +380,22 @@
(cons (car l2) (merge l1 (cdr l2)))))))))
(merge (sort-list l1 pred) (sort-list l2 pred)))))
(defun sort (l pred)
"sort list L with predicate PRED and return the resulting list"
(if (or (empty l) (empty (rest l)))
l
(let* ((len (length l))
(first (div len 2))
(l1 (subseq l 0 first))
(l2 (subseq l (- len first)))
(merge (lambda (l1 l2)
(if (empty l1)
l2
(if (empty l2)
l1
(if (pred (first l1) (first l2))
(prepend (first l1) (merge (rest l1) l2))
(prepend (first l2) (merge l1 (rest l2)))))))))
(merge (sort l1 pred) (sort l2 pred)))))
(defun sort (s pred)
"sort sequence S with predicate PRED and return the result"
(cond ((stringp s)
(apply #'string (sort-list (split-string s "") pred)))
((listp s) (sort-list s pred))
(t (error "sort: not a sequence: %s" sequence))))
(defun make-string (n el)
"return a string of N occurences of element EL"
"return a string of N occurences of element EL (may be a function)"
(if (zerop n)
""
(concat el (make-string (1- n) el))))
(concat (if (functionp el)
(el)
(string el))
(make-string (1- n) el))))
(defun join (sep &rest args)
"append all ARGS (or their elements) to a string, separated by SEP"
......@@ -421,9 +416,9 @@
(defun 2+ (n) (+ n 2))
(defun 2- (n) (- n 2))
(defspecial incf (var &optional incr)
(set var (eval (list '+ var (or incr 1))))))
(set var (eval (list '+ var (or incr 1)))))
(defspecial decf (var &optional decr)
(set var (eval (list '- var (or decr 1))))))
(set var (eval (list '- var (or decr 1)))))
(defun fib (n)
(if (< n 2)
......
Interp.pm
View file @ d068acdf
......@@ -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) {
......
Read.pm
View file @ d068acdf
......@@ -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) {
......
Util.pm
View file @ d068acdf
......@@ -22,7 +22,7 @@ BEGIN {
}
# check arguments; descriptor is string "xxx:xx" with mandatory args
# before the :, then# optional args; x is:
# before the :, then optional args; x is:
# e: any expression
# y: symbol
# p: pair
......@@ -39,7 +39,7 @@ sub checkargs {
my $argno = 0;
my $optional = 0;
for my $desc (split('', $descriptor)) {
#warn("checkargs: arglist ", &$Princs($arglist));
#warn("checkargs: desc $desc; arglist ", &$Princs($arglist));
if ($desc eq 'R') {
#warn("checkargs: set $desc to ", &$Princs($arglist));
push(@result, list2array($arglist));
......@@ -51,6 +51,7 @@ sub checkargs {
last;
}
if ($desc eq ':') {
#warn("checkargs: see :optional");
$optional = 1;
next;
}
......@@ -59,13 +60,18 @@ sub checkargs {
unless $optional || consp($arglist);
my $arg;
($arg, $arglist) = cxr($arglist);
#warn("\$arg: ", Dumper($arg));
my $optional_defaulted = 0;
if (defined($arg)) {
$argno++;
} else {
$arg = $Nil;
$optional_defaulted = 1;
}
if ($desc eq 'e') {
; # this is relatively frequent
if ($desc eq 'e' || $optional_defaulted) {
; # this is relatively frequent, and we do
# not need to check the argument type
# any more
} elsif ($desc eq 'S') {
$arg = &$Princs($arg);
} elsif ($desc eq 'y') {
......
tests/028-sort.lisp
View file @ d068acdf
......@@ -3,7 +3,10 @@
(testcmp "sort list 1" '(sort '(60) #'>) '(60))
(testcmp "sort list 2" '(sort '(60 94) #'>) '(94 60))
(testcmp "sort list 3" '(sort '(94 60) #'>) '(94 60))
(testcmp "sort list 4" '(sort '(66 43 42 68 6 15 9 30 51 81
(testcmp "sort list 4" '(sort '(94 60 23 24) #'>) '(94 60 24 23))
(testcmp "sort list 5" '(sort '(94 94 12 94) #'>) '(94 94 94 12))
(testcmp "sort list 6" '(sort '(94 12 94) #'>) '(94 94 12))
(testcmp "sort list 9" '(sort '(66 43 42 68 6 15 9 30 51 81
21 38 31 46 28 29 67 21 20 36) #'>)
'(81 68 67 66 51 46 43 42 38 36 31 30 29 28 21 21 20 15 9 6))
......
tests/035-read.lisp 0 → 100644
View file @ d068acdf
(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