adding support for optional arguments
error checking formal argument lists making filter preserve the order of elements in the input list
This commit is contained in:
JeffBezanson
parent
c61dc10002
commit
eceeddf6d2
File diff suppressed because it is too large
Load Diff
|
|
@ -26,6 +26,7 @@
|
|||
:add2 :sub2 :neg :largc :lvargc
|
||||
:loada0 :loada1 :loadc00 :loadc01 :call.l :tcall.l
|
||||
:brne :brne.l :cadr :brnn :brnn.l :brn :brn.l
|
||||
:optargs
|
||||
|
||||
dummy_t dummy_f dummy_nil]))
|
||||
(for 0 (1- (length keys))
|
||||
|
|
@ -171,7 +172,7 @@
|
|||
((number? nxt)
|
||||
(case vi
|
||||
((:loadv.l :loadg.l :setg.l :loada.l :seta.l
|
||||
:largc :lvargc :call.l :tcall.l)
|
||||
:largc :lvargc :call.l :tcall.l :optargs)
|
||||
(io.write bcode (int32 nxt))
|
||||
(set! i (+ i 1)))
|
||||
|
||||
|
|
@ -346,6 +347,7 @@
|
|||
(if (and (pair? head)
|
||||
(eq? (car head) 'lambda)
|
||||
(list? (cadr head))
|
||||
(every symbol? (cadr head))
|
||||
(not (length> (cadr head) 255)))
|
||||
(compile-let g env tail? x)
|
||||
(compile-call g env tail? x))))
|
||||
|
|
@ -505,6 +507,28 @@
|
|||
(else ())))))
|
||||
(lambda (expr) (delete-duplicates (get-defined-vars- expr)))))
|
||||
|
||||
(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))
|
||||
(error (string "compile error: invalid argument list "
|
||||
o ". optional arguments must come last."))))
|
||||
(error (string "compile error: invalid formal argument " (car l)
|
||||
" in list " o)))
|
||||
(check-formals (cdr l) o))
|
||||
(if (eq? l o)
|
||||
(error (string "compile error: invalid argument list " o))
|
||||
(error (string "compile error: invalid formal argument " l
|
||||
" in list " o)))))
|
||||
(check-formals l l)
|
||||
(map (lambda (s) (if (pair? s) (car s) s))
|
||||
(to-proper l)))
|
||||
|
||||
(define compile-f-
|
||||
(let ((*defines-processed-token* (gensym)))
|
||||
; to eval a top-level expression we need to avoid internal define
|
||||
|
|
@ -529,23 +553,34 @@
|
|||
|
||||
(let ((g (make-code-emitter))
|
||||
(args (cadr f))
|
||||
(vars (lambda-vars (cadr f)))
|
||||
(opta (filter pair? (cadr f)))
|
||||
(name (if (eq? (lastcdr f) *defines-processed-token*)
|
||||
'lambda
|
||||
(lastcdr f))))
|
||||
(cond ((not (null? let?)) (emit g :let))
|
||||
((length> args 255) (emit g (if (null? (lastcdr args))
|
||||
:largc :lvargc)
|
||||
(length args)))
|
||||
((null? (lastcdr args)) (emit g :argc (length args)))
|
||||
(else (emit g :vargc (if (atom? args) 0 (length args)))))
|
||||
(compile-in g (cons (to-proper args) env) #t
|
||||
(if (eq? (lastcdr f) *defines-processed-token*)
|
||||
(caddr f)
|
||||
(lambda-body f)))
|
||||
(emit g :ret)
|
||||
(values (function (encode-byte-code (bcode:code g))
|
||||
(const-to-idx-vec g) name)
|
||||
(aref g 3))))))
|
||||
(let ((nargs (if (atom? args) 0 (length args))))
|
||||
|
||||
; emit argument checking prologue
|
||||
(if (not (null? opta))
|
||||
(begin (bcode:indexfor g (list->vector (map cadr opta)))
|
||||
(emit g :optargs (- nargs (length opta)))))
|
||||
|
||||
(cond ((not (null? let?)) (emit g :let))
|
||||
((> nargs 255) (emit g (if (null? (lastcdr args))
|
||||
:largc :lvargc)
|
||||
nargs))
|
||||
((null? (lastcdr args)) (emit g :argc nargs))
|
||||
(else (emit g :vargc nargs)))
|
||||
|
||||
; compile body and return
|
||||
(compile-in g (cons vars env) #t
|
||||
(if (eq? (lastcdr f) *defines-processed-token*)
|
||||
(caddr f)
|
||||
(lambda-body f)))
|
||||
(emit g :ret)
|
||||
(values (function (encode-byte-code (bcode:code g))
|
||||
(const-to-idx-vec g) name)
|
||||
(aref g 3)))))))
|
||||
|
||||
(define (compile f) (compile-f () f))
|
||||
|
||||
|
|
@ -604,7 +639,7 @@
|
|||
(princ (number->string (aref code i)))
|
||||
(set! i (+ i 1)))
|
||||
|
||||
((:loada.l :seta.l :largc :lvargc :call.l :tcall.l)
|
||||
((:loada.l :seta.l :largc :lvargc :call.l :tcall.l :optargs)
|
||||
(princ (number->string (ref-int32-LE code i)))
|
||||
(set! i (+ i 4)))
|
||||
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
|
|
@ -931,6 +931,30 @@ static value_t apply_cl(uint32_t nargs)
|
|||
Stack[SP-1] = 0;
|
||||
curr_frame = SP;
|
||||
NEXT_OP;
|
||||
OP(OP_OPTARGS)
|
||||
n = GET_INT32(ip); ip+=4;
|
||||
v = fn_vals(Stack[bp-1]);
|
||||
v = vector_elt(v, 0);
|
||||
if (nargs >= n) { // if we have all required args
|
||||
s = vector_size(v);
|
||||
n += s;
|
||||
if (nargs < n) { // but not all optional args
|
||||
i = n - nargs;
|
||||
SP += i;
|
||||
Stack[SP-1] = Stack[SP-i-1];
|
||||
Stack[SP-2] = Stack[SP-i-2];
|
||||
Stack[SP-3] = Stack[SP-i-3];
|
||||
Stack[SP-4] = Stack[SP-i-4];
|
||||
Stack[SP-5] = Stack[SP-i-5];
|
||||
curr_frame = SP;
|
||||
s = s - i;
|
||||
for(n=0; n < i; n++) {
|
||||
Stack[bp+nargs+n] = vector_elt(v, s+n);
|
||||
}
|
||||
nargs += i;
|
||||
}
|
||||
}
|
||||
NEXT_OP;
|
||||
OP(OP_NOP) NEXT_OP;
|
||||
OP(OP_DUP) SP++; Stack[SP-1] = Stack[SP-2]; NEXT_OP;
|
||||
OP(OP_POP) POPN(1); NEXT_OP;
|
||||
|
|
@ -1662,7 +1686,7 @@ static value_t apply_cl(uint32_t nargs)
|
|||
#endif
|
||||
}
|
||||
|
||||
static uint32_t compute_maxstack(uint8_t *code, size_t len)
|
||||
static uint32_t compute_maxstack(uint8_t *code, size_t len, value_t vals)
|
||||
{
|
||||
uint8_t *ip = code+4, *end = code+len;
|
||||
uint8_t op;
|
||||
|
|
@ -1688,6 +1712,12 @@ static uint32_t compute_maxstack(uint8_t *code, size_t len)
|
|||
sp += (n+2);
|
||||
break;
|
||||
case OP_LET: break;
|
||||
case OP_OPTARGS:
|
||||
ip += 4;
|
||||
assert(isvector(vals));
|
||||
if (vector_size(vals) > 0)
|
||||
sp += vector_size(vector_elt(vals, 0));
|
||||
break;
|
||||
|
||||
case OP_TCALL: case OP_CALL:
|
||||
n = *ip++; // nargs
|
||||
|
|
@ -1824,7 +1854,7 @@ static value_t fl_function(value_t *args, uint32_t nargs)
|
|||
for(i=0; i < sz; i++)
|
||||
data[i] -= 48;
|
||||
}
|
||||
uint32_t ms = compute_maxstack((uint8_t*)data, cv_len(arr));
|
||||
uint32_t ms = compute_maxstack((uint8_t*)data, cv_len(arr), args[1]);
|
||||
PUT_INT32(data, ms);
|
||||
function_t *fn = (function_t*)alloc_words(4);
|
||||
value_t fv = tagptr(fn, TAG_FUNCTION);
|
||||
|
|
|
|||
|
|
@ -27,6 +27,7 @@ enum {
|
|||
OP_TAPPLY, OP_ADD2, OP_SUB2, OP_NEG, OP_LARGC, OP_LVARGC,
|
||||
OP_LOADA0, OP_LOADA1, OP_LOADC00, OP_LOADC01, OP_CALLL, OP_TCALLL,
|
||||
OP_BRNE, OP_BRNEL, OP_CADR, OP_BRNN, OP_BRNNL, OP_BRN, OP_BRNL,
|
||||
OP_OPTARGS,
|
||||
|
||||
OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST,
|
||||
|
||||
|
|
@ -69,7 +70,7 @@ enum {
|
|||
&&L_OP_LVARGC, \
|
||||
&&L_OP_LOADA0, &&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01, \
|
||||
&&L_OP_CALLL, &&L_OP_TCALLL, &&L_OP_BRNE, &&L_OP_BRNEL, &&L_OP_CADR,\
|
||||
&&L_OP_BRNN, &&L_OP_BRNNL, &&L_OP_BRN, &&L_OP_BRNL \
|
||||
&&L_OP_BRNN, &&L_OP_BRNNL, &&L_OP_BRN, &&L_OP_BRNL, &&L_OP_OPTARGS \
|
||||
}
|
||||
|
||||
#define VM_APPLY_LABELS \
|
||||
|
|
|
|||
|
|
@ -224,15 +224,16 @@
|
|||
(set-car! lst (f (car lst)))
|
||||
(set! lst (cdr lst)))))
|
||||
|
||||
(define filter
|
||||
(letrec ((filter-
|
||||
(lambda (pred lst accum)
|
||||
(cond ((null? lst) accum)
|
||||
((pred (car lst))
|
||||
(filter- pred (cdr lst) (cons (car lst) accum)))
|
||||
(#t
|
||||
(filter- pred (cdr lst) accum))))))
|
||||
(lambda (pred lst) (filter- pred lst ()))))
|
||||
(define (filter pred lst)
|
||||
(define (filter- f lst acc)
|
||||
(cdr
|
||||
(prog1 acc
|
||||
(while (pair? lst)
|
||||
(begin (if (pred (car lst))
|
||||
(set! acc
|
||||
(cdr (set-cdr! acc (cons (car lst) ())))))
|
||||
(set! lst (cdr lst)))))))
|
||||
(filter- pred lst (list ())))
|
||||
|
||||
(define separate
|
||||
(letrec ((separate-
|
||||
|
|
|
|||
|
|
@ -159,7 +159,7 @@ bugs:
|
|||
. write a function to evaluate directly from list to list, use it for
|
||||
Nth arg and for user function rest args
|
||||
. modify vararg builtins accordingly
|
||||
- filter should be stable. right now it reverses.
|
||||
* filter should be stable. right now it reverses.
|
||||
|
||||
|
||||
femtoLisp3...with symbolic C interface
|
||||
|
|
@ -975,7 +975,8 @@ consolidated todo list as of 7/8:
|
|||
- remaining c types
|
||||
- remaining cvalues functions
|
||||
- finish ios
|
||||
- optional and keyword arguments
|
||||
* optional arguments
|
||||
- keyword arguments
|
||||
- some kind of record, struct, or object system
|
||||
|
||||
- special efficient reader for #array
|
||||
|
|
@ -1042,6 +1043,8 @@ new evaluator todo:
|
|||
* try removing MAX_ARGS trickery
|
||||
- apply optimization, avoid redundant list copying calling vararg fns
|
||||
- let eversion
|
||||
- variable analysis - avoid holding references to values in frames
|
||||
captured by closures but not used inside them
|
||||
* lambda lifting
|
||||
* let optimization
|
||||
* fix equal? on functions
|
||||
|
|
|
|||
|
|
@ -116,6 +116,14 @@
|
|||
(assert (equal? (apply f (iota 995)) '(994)))
|
||||
(assert (equal? (apply f (iota 1000)) '(994 995 996 997 998 999)))
|
||||
|
||||
; optional arguments
|
||||
(assert (equal? ((lambda ((b 0)) b)) 0))
|
||||
(assert (equal? ((lambda (a (b 2)) (list a b)) 1) '(1 2)))
|
||||
(assert (equal? ((lambda (a (b 2)) (list a b)) 1 3) '(1 3)))
|
||||
(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1) '(1 2 3)))
|
||||
(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8) '(1 8 3)))
|
||||
(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8 9) '(1 8 9)))
|
||||
|
||||
; ok, a couple end-to-end tests as well
|
||||
(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
|
||||
(assert (equal? (fib 20) 6765))
|
||||
|
|
|
|||
Loading…
Reference in New Issue