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

Builtin.pm

@@ -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.lisp

 ;; 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"

Sexp.pm

@@ -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;

TODO

@@ -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
 

tests/036-truncate.lisp

+(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)

tests/037-minmax.lisp

+(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)

tests/038-scope.lisp

+(testcmp "scope" '(let ((a 'lexical))
+                    (let ((f (lambda () (print a))))
+                      (let ((a 'dynamic))
+                        (funcall f))))
+         'dynamic)

tests/error.lisp

+(gubber . b c d)

tests/run-tests.lisp

@@ -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))