Commit 85b52a05 authored by Juergen Nickelsen's avatar Juergen Nickelsen

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

parents 803ab188 e318584c
......@@ -25,6 +25,11 @@ sub Bbindings_depth {
return bindings_depth();
}
sub Btruncate {
my ($number) = checkargs($_[0], 'n');
return int($number);
}
sub Bshell {
my ($command, $return_output) = checkargs($_[0], 'S:e');
my $result;
......@@ -58,11 +63,6 @@ sub Bsqrt {
return sqrt($arg);
}
sub Bisqrt {
my ($arg) = checkargs($_[0], 'n');
return int(sqrt($arg));
}
sub Bsplit_string {
my ($string, $sep, $nonulls) = checkargs($_[0], 'S:ee');
my $re;
......@@ -395,23 +395,9 @@ sub Bload {
return load($fname, $noerror, $nomessage);
}
sub Bapropos {
my ($re) = checkargs($_[0], ':S');
$re = '.' if is_nil($re);
my $result = $Nil;
my $end;
for my $sym (sort {symbol_name($a) cmp symbol_name($b)} all_symbols()) {
if (symbol_name($sym) =~ /$re/) {
my $newpair = cons($sym, $Nil);
if ($end) {
rplacd($end, $newpair);
$end = $newpair;
} else {
$end = $result = $newpair;
}
}
}
return $result;
sub Bsymbols {
checkargs($_[0], '');
return array2list(all_symbols);
}
sub Beq {
......@@ -858,6 +844,8 @@ sub Btype_of {
my @builtins = # [name, func, is_special, doc]
(
["truncate", \&Btruncate, 0,
"return NUMBER truncated to integer towards zero"],
["div", \&Bdiv, 0, "integer divide the first arg by all others"],
["let*", \&Blet_star, 1,
"evaluate body with local bindings: (let* ((var value) ...) body)"],
......@@ -933,7 +921,7 @@ my @builtins = # [name, func, is_special, doc]
"define an anonymous special form from ARGS and &rest BODY"],
["eq", \&Beq, 0,
"return t if ARG1 and ARG2 are the same object, nil else"],
["apropos", \&Bapropos, 0, "return a list of symbols matching ARG"],
["symbols", \&Bsymbols, 0, "return a list of all symbols"],
["princ", \&Bprinc, 0, "print ARG to standard output without quoting"],
["princs", \&Bprincs, 0, "princ ARG to a string and return the string"],
["prin1", \&Bprin1, 0, "print ARG suitable for read"],
......@@ -976,7 +964,6 @@ my @builtins = # [name, func, is_special, doc]
["split-string", \&Bsplit_string, 0,
"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,
......
;; fundamental predefined Lisp functions
;(debug t)
(defun symbols ()
"return a sorted list of all symbols"
(apropos "."))
(defun max (&rest numargs)
"return the biggest of all (numeric) arguments"
(if (null (cdr numargs))
(car numargs)
(let ((a (car numargs))
(b (apply #'max (cdr numargs))))
(if (< a b)
b
a))))
(defun min (&rest numargs)
"return the smallest of all (numeric) arguments"
(if (null (cdr numargs))
(car numargs)
(let ((a (car numargs))
(b (apply #'min (cdr numargs))))
(if (< a b)
a
b))))
(defun apropos (match)
(sort (filter #'(lambda (sym) (re-match match (symbol-name sym)))
(symbols))
#'string<))
(defun isqrt (num)
"return the integer square root of NUM ARG"
(truncate (sqrt num)))
(defun caar (pair)
"return the car of the car of PAIR"
......
......@@ -19,9 +19,8 @@ BEGIN {
@EXPORT = qw( intern cons list car cdr listp symbolp numberp stringp
consp symbol_name symbol_function functionp cxr type_of
rplaca rplacd fset function put get symbol_plist
specialp caar cadr cdar cddr caaar caadr cadar caddr cdaar
cdadr cddar cdddr function_type function_code symbol_value
set function_name is_nil all_symbols remprop
specialp cadr cddr function_type function_code
symbol_value set function_name is_nil all_symbols remprop
function_documentation is_t cons_count function_args
);
}
......@@ -161,66 +160,16 @@ sub list {
return cons($car, list(@obs));
}
sub caar {
my ($ob) = @_;
return $ob->{car}->{car} // $Nil;
}
sub cadr {
my ($ob) = @_;
return $ob->{cdr}->{car} // $Nil;
}
sub cdar {
my ($ob) = @_;
return $ob->{car}->{cdr} // $Nil;
}
sub cddr {
my ($ob) = @_;
return $ob->{cdr}->{cdr} // $Nil;
}
sub caaar {
my ($ob) = @_;
return $ob->{car}->{car}->{car} // $Nil;
}
sub caadr {
my ($ob) = @_;
return $ob->{cdr}->{car}->{car} // $Nil;
}
sub cadar {
my ($ob) = @_;
return $ob->{car}->{cdr}->{car} // $Nil;
}
sub caddr {
my ($ob) = @_;
return $ob->{cdr}->{cdr}->{car} // $Nil;
}
sub cdaar {
my ($ob) = @_;
return $ob->{car}->{car}->{cdr} // $Nil;
}
sub cdadr {
my ($ob) = @_;
return $ob->{cdr}->{car}->{cdr} // $Nil;
}
sub cddar {
my ($ob) = @_;
return $ob->{car}->{cdr}->{cdr} // $Nil;
}
sub cdddr {
my ($ob) = @_;
return $ob->{cdr}->{cdr}->{cdr} // $Nil;
}
sub car {
my ($ob) = @_;
return $ob->{car} // $Nil;
......
......@@ -2,9 +2,21 @@
*: to do; @: in progress; #: blocked; +: done; -: rejected
* do something sensible with (describe) for functions
* environments and lexical scope
* 031 and read errors
* more of alists
* floor, ceiling, round
+ min, max
+ "isqrt", "return the integer square root of numeric ARG"
+ truncate
+ do something sensible with (describe) for functions
+ 031 and read errors
+ command line options like lingo's -e -h -l -q
......
(testcmp "truncate positive float" '(truncate (1+ 3.4)) 4)
(testcmp "truncate positive int" '(truncate 3) 3)
(testcmp "truncate negative float" '(truncate -3.4) -3)
(testcmp "truncate negative int" '(truncate -3) -3)
(testcmp "max 1" '(max) nil)
(testcmp "max 2" '(max 3) 3)
(testcmp "max 3" '(max 3 4 5 2 54 6 9 3 5 7) 54)
(testcmp "max 4" '(max 3 -4 5 -2 54 -6 9 -3 5 -7) 54)
(testcmp "min 1" '(min) nil)
(testcmp "min 2" '(min 3) 3)
(testcmp "min 3" '(min 3 4 5 2 54 6 9 3 5 7) 2)
(testcmp "min 4" '(min 3 -4 5 -2 54 -6 9 -3 5 -7) -7)
(testcmp "min 5" '(min 4 2 4 2 4 2 7 1 19) 1)
(testcmp "scope" '(let ((a 'lexical))
(let ((f (lambda () (print a))))
(let ((a 'dynamic))
(funcall f))))
'dynamic)
(gubber . b c d)
......@@ -33,7 +33,7 @@ the evaluation of FORM and VALUE are equal."
(format t "%d tests, %d FAILS" ntests (length fails))
(dolist (err (reverse fails))
(format t " \"%s:%s\"" (cdr err) (car err)))
(format t "\n FAIL \"%s:%s\"" (cdr err) (car err)))
(terpri)
(when fails
(exit 1))
......
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