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 { ...@@ -25,6 +25,11 @@ sub Bbindings_depth {
return bindings_depth(); return bindings_depth();
} }
sub Btruncate {
my ($number) = checkargs($_[0], 'n');
return int($number);
}
sub Bshell { sub Bshell {
my ($command, $return_output) = checkargs($_[0], 'S:e'); my ($command, $return_output) = checkargs($_[0], 'S:e');
my $result; my $result;
...@@ -58,11 +63,6 @@ sub Bsqrt { ...@@ -58,11 +63,6 @@ sub Bsqrt {
return sqrt($arg); return sqrt($arg);
} }
sub Bisqrt {
my ($arg) = checkargs($_[0], 'n');
return int(sqrt($arg));
}
sub Bsplit_string { sub Bsplit_string {
my ($string, $sep, $nonulls) = checkargs($_[0], 'S:ee'); my ($string, $sep, $nonulls) = checkargs($_[0], 'S:ee');
my $re; my $re;
...@@ -395,23 +395,9 @@ sub Bload { ...@@ -395,23 +395,9 @@ sub Bload {
return load($fname, $noerror, $nomessage); return load($fname, $noerror, $nomessage);
} }
sub Bapropos { sub Bsymbols {
my ($re) = checkargs($_[0], ':S'); checkargs($_[0], '');
$re = '.' if is_nil($re); return array2list(all_symbols);
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 Beq { sub Beq {
...@@ -858,6 +844,8 @@ sub Btype_of { ...@@ -858,6 +844,8 @@ sub Btype_of {
my @builtins = # [name, func, is_special, doc] 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"], ["div", \&Bdiv, 0, "integer divide the first arg by all others"],
["let*", \&Blet_star, 1, ["let*", \&Blet_star, 1,
"evaluate body with local bindings: (let* ((var value) ...) body)"], "evaluate body with local bindings: (let* ((var value) ...) body)"],
...@@ -933,7 +921,7 @@ my @builtins = # [name, func, is_special, doc] ...@@ -933,7 +921,7 @@ my @builtins = # [name, func, is_special, doc]
"define an anonymous special form from ARGS and &rest BODY"], "define an anonymous special form from ARGS and &rest BODY"],
["eq", \&Beq, 0, ["eq", \&Beq, 0,
"return t if ARG1 and ARG2 are the same object, nil else"], "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"], ["princ", \&Bprinc, 0, "print ARG to standard output without quoting"],
["princs", \&Bprincs, 0, "princ ARG to a string and return the string"], ["princs", \&Bprincs, 0, "princ ARG to a string and return the string"],
["prin1", \&Bprin1, 0, "print ARG suitable for read"], ["prin1", \&Bprin1, 0, "print ARG suitable for read"],
...@@ -976,7 +964,6 @@ my @builtins = # [name, func, is_special, doc] ...@@ -976,7 +964,6 @@ my @builtins = # [name, func, is_special, doc]
["split-string", \&Bsplit_string, 0, ["split-string", \&Bsplit_string, 0,
"split STRING into parts SEPARATED by SEP and return the list"], "split STRING into parts SEPARATED by SEP and return the list"],
["sqrt", \&Bsqrt, 0, "return the square root of numeric ARG"], ["sqrt", \&Bsqrt, 0, "return the square root of numeric ARG"],
["isqrt", \&Bsqrt, 0, "return the integer square root of numeric ARG"],
["random", \&Brandom, 0, ["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, ["read", \&Bread, 0,
......
;; fundamental predefined Lisp functions ;; fundamental predefined Lisp functions
;(debug t) ;(debug t)
(defun symbols () (defun max (&rest numargs)
"return a sorted list of all symbols" "return the biggest of all (numeric) arguments"
(apropos ".")) (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) (defun caar (pair)
"return the car of the car of PAIR" "return the car of the car of PAIR"
......
...@@ -19,9 +19,8 @@ BEGIN { ...@@ -19,9 +19,8 @@ BEGIN {
@EXPORT = qw( intern cons list car cdr listp symbolp numberp stringp @EXPORT = qw( intern cons list car cdr listp symbolp numberp stringp
consp symbol_name symbol_function functionp cxr type_of consp symbol_name symbol_function functionp cxr type_of
rplaca rplacd fset function put get symbol_plist rplaca rplacd fset function put get symbol_plist
specialp caar cadr cdar cddr caaar caadr cadar caddr cdaar specialp cadr cddr function_type function_code
cdadr cddar cdddr function_type function_code symbol_value symbol_value set function_name is_nil all_symbols remprop
set function_name is_nil all_symbols remprop
function_documentation is_t cons_count function_args function_documentation is_t cons_count function_args
); );
} }
...@@ -161,66 +160,16 @@ sub list { ...@@ -161,66 +160,16 @@ sub list {
return cons($car, list(@obs)); return cons($car, list(@obs));
} }
sub caar {
my ($ob) = @_;
return $ob->{car}->{car} // $Nil;
}
sub cadr { sub cadr {
my ($ob) = @_; my ($ob) = @_;
return $ob->{cdr}->{car} // $Nil; return $ob->{cdr}->{car} // $Nil;
} }
sub cdar {
my ($ob) = @_;
return $ob->{car}->{cdr} // $Nil;
}
sub cddr { sub cddr {
my ($ob) = @_; my ($ob) = @_;
return $ob->{cdr}->{cdr} // $Nil; 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 { sub car {
my ($ob) = @_; my ($ob) = @_;
return $ob->{car} // $Nil; return $ob->{car} // $Nil;
......
...@@ -2,9 +2,21 @@ ...@@ -2,9 +2,21 @@
*: to do; @: in progress; #: blocked; +: done; -: rejected *: 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 + 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." ...@@ -33,7 +33,7 @@ the evaluation of FORM and VALUE are equal."
(format t "%d tests, %d FAILS" ntests (length fails)) (format t "%d tests, %d FAILS" ntests (length fails))
(dolist (err (reverse fails)) (dolist (err (reverse fails))
(format t " \"%s:%s\"" (cdr err) (car err))) (format t "\n FAIL \"%s:%s\"" (cdr err) (car err)))
(terpri) (terpri)
(when fails (when fails
(exit 1)) (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