better error checking for formal argument lists

some cosmetic error improvements
adding more tests

femtolisp/compiler.lsp

@@ -348,9 +348,6 @@
 	     " argument."
 	     " arguments.")))
 
-(define (compile-app g env tail? x)
-  (compile-call g env tail? x))
-
 (define builtin->instruction
   (let ((b2i (table number? 'number?  cons 'cons
 		    fixnum? 'fixnum?  equal? 'equal?
@@ -395,7 +392,7 @@
 		    (emit g (if tail? 'tapply 'apply) nargs)))
       (else      (emit g b)))))
 
-(define (compile-call g env tail? x)
+(define (compile-app g env tail? x)
   (let ((head  (car x)))
     (let ((head
 	   (if (and (symbol? head)
@@ -502,28 +499,33 @@
       k))
 
 (define (lambda-vars l)
-  (define (check-formals l o)
+  (define (check-formals l o opt kw)
-    (or
+    (cond ((or (null? l) (symbol? l)) #t)
-     (null? l) (symbol? l)
+	  ((and (pair? l) (symbol? (car l)))
-     (and
+	   (if (or opt kw)
-      (pair? l)
+	       (error "compile error: invalid argument list "
-      (or (symbol? (car l))
+		      o ". optional arguments must come after required.")
-	  (and (pair? (car l))
+	       (check-formals (cdr l) o opt kw)))
-	       (or (every pair? (cdr l))
+	  ((and (pair? l) (pair? (car l)))
+	   (unless (and (length= (car l) 2)
+			(symbol? (caar l)))
+		   (error "compile error: invalid optional argument " (car l)
+			  " in list " o))
+	   (if (keyword? (caar l))
+	       (check-formals (cdr l) o opt #t)
+	       (if kw
 		   (error "compile error: invalid argument list "
-			  o ". optional arguments must come after required."))
+			  o ". keyword arguments must come last.")
-	       (if (keyword? (caar l))
+		   (check-formals (cdr l) o #t kw))))
-		   (or (every keyword-arg? (cdr l))
+	  ((pair? l)
-		       (error "compile error: invalid argument list "
+	   (error "compile error: invalid formal argument " (car l)
-			      o ". keyword arguments must come last."))
+		  " in list " o))
-		   #t))
+	  (else
-	  (error "compile error: invalid formal argument " (car l)
+	   (if (eq? l o)
-		 " in list " o))
+	       (error "compile error: invalid argument list " o)
-      (check-formals (cdr l) o))
+	       (error "compile error: invalid formal argument " l
-     (if (eq? l o)
+		      " in list " o)))))
-	 (error "compile error: invalid argument list " o)
+  (check-formals l l #f #f)
-	 (error "compile error: invalid formal argument " l " in list " o))))
-  (check-formals l l)
   (map! (lambda (s) (if (pair? s) (keyword->symbol (car s)) s))
 	(to-proper l)))
 

femtolisp/flisp.c

@@ -202,7 +202,7 @@ void type_error(char *fname, char *expected, value_t got)
 
 void bounds_error(char *fname, value_t arr, value_t ind)
 {
-    lerrorf(listn(3, BoundsError, arr, ind), "%s: index out of bounds", fname);
+    raise(listn(4, BoundsError, symbol(fname), arr, ind));
 }
 
 // safe cast operators --------------------------------------------------------

femtolisp/system.lsp

@@ -755,14 +755,19 @@
   (cond ((and (pair? e)
 	      (eq? (car e) 'type-error)
 	      (length= e 4))
-	 (eprinc "type-error: " (cadr e) ": expected " (caddr e) ", got ")
+	 (eprinc "type error: " (cadr e) ": expected " (caddr e) ", got ")
 	 (eprint (cadddr e)))
 
+	((and (pair? e)
+	      (eq? (car e) 'bounds-error)
+	      (length= e 4))
+	 (eprinc (cadr e) ": index " (cadddr e) " out of bounds for ")
+	 (eprint (caddr e)))
+
 	((and (pair? e)
 	      (eq? (car e) 'unbound-error)
 	      (pair? (cdr e)))
-	 (eprinc "unbound-error: eval: variable " (cadr e)
+	 (eprinc "eval: variable " (cadr e) " has no value"))
-		 " has no value"))
 
 	((and (pair? e)
 	      (eq? (car e) 'error))

femtolisp/todo

@@ -1150,3 +1150,22 @@ brbound 2 L2
 loada 1
 seta 2
 L2:
+
+-----------------------------------------------------------------------------
+
+what needs more test coverage:
+
+- more error cases, lerrorf() cases
+- printing gensyms
+- gensyms with bindings
+- listn(), isnumber(), list*, boolean?, function?, add2+ovf, >2arg add,div
+- large functions, requiring long versions of branch opcodes
+- setal, loadvl, (long arglist and lots of vals cases)
+- aref/aset on c array
+- printing everything
+- reading floats, escaped symbols, multiline comment, octal chars in strs
+- equal? on functions
+- all cvalue ctors, string_from_cstrn()
+- typeof, copy, podp, builtin()
+- bitwise and logical ops
+- making a closure in a default value expression for an optional arg

femtolisp/unittest.lsp

@@ -1,4 +1,9 @@
 ; -*- scheme -*-
+(define-macro (assert-fail expr . what)
+  `(assert (trycatch (begin ,expr #f)
+		     (lambda (e) ,(if (null? what) #t
+				      `(eq? (car e) ',(car what)))))))
+
 (define (every-int n)
   (list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n)
         (int64 n) (uint64 n)))
@@ -95,8 +100,20 @@
 ; this crashed once
 (for 1 10 (lambda (i) 0))
 
+; failing applications
+(assert-fail ((lambda (x) x) 1 2))
+(assert-fail ((lambda (x) x)))
+(assert-fail ((lambda (x y . z) z) 1))
+(assert-fail (car 'x) type-error)
+(assert-fail gjegherqpfdf___trejif unbound-error)
+
 ; long argument lists
 (assert (= (apply + (iota 100000)) 4999950000))
+(define ones (map (lambda (x) 1) (iota 80000)))
+(assert (= (eval `(if (< 2 1)
+		      (+ ,@ones)
+		      (+ ,@(cdr ones))))
+	   79999))
 
 (define MAX_ARGS 255)
 
@@ -106,6 +123,14 @@
 (assert (equal? (apply f (iota (+ MAX_ARGS 1))) `(,MAX_ARGS)))
 (assert (equal? (apply f (iota (+ MAX_ARGS 2))) `(,MAX_ARGS ,(+ MAX_ARGS 1))))
 
+(define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 100))))
+(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
+			     ,(car (last-pair as)))))
+(assert (equal? (apply ff (iota (+ MAX_ARGS 100))) 42))
+(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
+			     (lambda () ,(car (last-pair as))))))
+(assert (equal? ((apply ff (iota (+ MAX_ARGS 100)))) 42))
+
 (define as (map-int (lambda (x) (gensym)) 1000))
 (define f (compile `(lambda ,as ,(car (last-pair as)))))
 (assert (equal? (apply f (iota 1000)) 999))
@@ -136,6 +161,15 @@
 (assert (equal? (keys4 b: 10) '(8 10 7 6)))
 (assert (equal? (keys4 c: 10) '(8 3 10 6)))
 (assert (equal? (keys4 d: 10) '(8 3 7 10)))
+(assert-fail (keys4 e: 10))   ; unsupported keyword
+(assert-fail (keys4 a: 1 b:)) ; keyword with no argument
+
+; cvalues and arrays
+(assert (equal? (typeof "") '(array byte)))
+(assert-fail (aref #(1) 3) bounds-error)
+(define iarr (array 'int64 32 16 8 7 1))
+(assert (equal? (aref iarr 0) 32))
+(assert (equal? (aref iarr #int8(3)) 7))
 
 ; ok, a couple end-to-end tests as well
 (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))