ref: c6a977063e97d4d1a9b4c07d2e0c7d0ceb02a6c0
parent: 15c8cb327d542607b6faaa90498cdef29a321110
author: JeffBezanson <[email protected]>
date: Mon Aug 3 01:00:44 EDT 2009
better error checking for formal argument lists some cosmetic error improvements adding more tests
--- a/femtolisp/compiler.lsp
+++ b/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)
- (or
- (null? l) (symbol? l)
- (and
- (pair? l)
- (or (symbol? (car l))
- (and (pair? (car l))
- (or (every pair? (cdr l))
+ (define (check-formals l o opt kw)
+ (cond ((or (null? l) (symbol? l)) #t)
+ ((and (pair? l) (symbol? (car l)))
+ (if (or opt kw)
+ (error "compile error: invalid argument list "
+ o ". optional arguments must come after required.")
+ (check-formals (cdr l) o opt kw)))
+ ((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."))
- (if (keyword? (caar l))
- (or (every keyword-arg? (cdr l))
- (error "compile error: invalid argument list "
- o ". keyword arguments must come last."))
- #t))
- (error "compile error: invalid formal argument " (car l)
- " in list " o))
- (check-formals (cdr l) o))
- (if (eq? l o)
- (error "compile error: invalid argument list " o)
- (error "compile error: invalid formal argument " l " in list " o))))
- (check-formals l l)
+ o ". keyword arguments must come last.")
+ (check-formals (cdr l) o #t kw))))
+ ((pair? l)
+ (error "compile error: invalid formal argument " (car l)
+ " in list " o))
+ (else
+ (if (eq? l o)
+ (error "compile error: invalid argument list " o)
+ (error "compile error: invalid formal argument " l
+ " in list " o)))))
+ (check-formals l l #f #f)
(map! (lambda (s) (if (pair? s) (keyword->symbol (car s)) s))
(to-proper l)))
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -202,7 +202,7 @@
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 --------------------------------------------------------
--- a/femtolisp/system.lsp
+++ b/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)
- " has no value"))
+ (eprinc "eval: variable " (cadr e) " has no value"))
((and (pair? e)
(eq? (car e) 'error))
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -1150,3 +1150,22 @@
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
--- a/femtolisp/unittest.lsp
+++ b/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)))))