diff --git a/femtolisp/compiler.lsp b/femtolisp/compiler.lsp index 332b432..532f553 100644 --- a/femtolisp/compiler.lsp +++ b/femtolisp/compiler.lsp @@ -467,7 +467,7 @@ (set! i (+ i 1))) ((:loada :seta :call :tcall :list :+ :- :* :/ :vector - :argc :vargc :loadi8 :apply :tapply) + :argc :vargc :loadi8 :apply :tapply) (princ (number->string (aref code i))) (set! i (+ i 1))) diff --git a/femtolisp/flisp.boot b/femtolisp/flisp.boot index 18bcdf3..d6910b6 100644 --- a/femtolisp/flisp.boot +++ b/femtolisp/flisp.boot @@ -83,7 +83,7 @@ nreverse nreconc #function("n2e0e1f031f142;" [nconc nreverse]) nlist* -#function("o0f0N?6=0f0M;f0e0f0NQ2P;" [nlist*]) +#function("o0e0f041;" [apply-nlist*]) newline #function("n0e0e1312];" [princ *linefeed*]) nestlist @@ -143,7 +143,7 @@ list-head list->vector #function("n1e0f0t2;" [vector]) list* -#function("o0f0N?6=0f0M;f0Me0f0NQ2K;" [list*]) +#function("o0e0e1f03141;" [apply-nlist* copy-list]) length> #function("n2f1`X6<0f0;f1`W6N0f0F16M02f0;f0A6Y0f1`X;e0f0Nf1av42;" [length>]) length= @@ -204,8 +204,6 @@ count #function("n2c0^q42;" [#function("rc0mj02f0g00g01`43;" [#function("n3f1A6;0f2;g00f0f1Nf0f1M316T0f2au5V0f243;" [])])]) copy-tree #function("n1f0?6;0f0;e0f0M31e0f0N31K;" [copy-tree]) -copy-list -#function("n1f0?6;0f0;f0Me0f0N31K;" [copy-list]) const-to-idx-vec #function("n1c0e1f0b2[31q42;" [#function("re0c1mg00a[322f0;" [table.foreach #function("n2g00f1f0\\;" [])]) vector.alloc]) compile-while diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 96a6ff9..6813454 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -702,7 +702,8 @@ static value_t list(value_t *args, uint32_t nargs) // perform (apply list* L) // like the function list() above, but takes arguments from a list // rather than from an array (the stack) -static value_t apply_liststar(value_t L) +// if !star, then it performs copy-list +static value_t apply_liststar(value_t L, int star) { PUSH(NIL); PUSH(NIL); @@ -712,7 +713,7 @@ static value_t apply_liststar(value_t L) value_t *pL = &Stack[SP-1]; value_t c; while (iscons(*pL)) { - if (iscons(cdr_(*pL))) { + if (!star || iscons(cdr_(*pL))) { c = mk_cons(); car_(c) = car_(*pL); cdr_(c) = NIL; @@ -732,6 +733,27 @@ static value_t apply_liststar(value_t L) return POP(); } +value_t fl_copylist(value_t *args, u_int32_t nargs) +{ + argcount("copy-list", nargs, 1); + return apply_liststar(args[0], 0); +} + +value_t fl_apply_nliststar(value_t *args, u_int32_t nargs) +{ + argcount("apply-nlist*", nargs, 1); + value_t v = args[0]; + value_t *plastcdr = &args[0]; + while (iscons(v)) { + if (!iscons(cdr_(v))) + *plastcdr = car_(v); + else + plastcdr = &cdr_(v); + v = cdr_(v); + } + return args[0]; +} + static value_t do_trycatch() { uint32_t saveSP = SP; @@ -1020,7 +1042,7 @@ static value_t apply_cl(uint32_t nargs) apply_apply: v = POP(); // arglist if (n > MAX_ARGS) { - v = apply_liststar(v); + v = apply_liststar(v, 1); } n = SP-(n-2); // n-2 == # leading arguments not in the list while (iscons(v)) { @@ -1478,6 +1500,8 @@ static builtinspec_t core_builtin_info[] = { { "function:env", fl_function_env }, { "gensym", fl_gensym }, { "hash", fl_hash }, + { "copy-list", fl_copylist }, + { "apply-nlist*", fl_apply_nliststar }, { NULL, NULL } }; diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 9d9aaa5..ff59911 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -182,15 +182,9 @@ ((null? lst) (= n 0)) (else (length= (cdr lst) (- n 1))))) -(define (list* . l) - (if (atom? (cdr l)) - (car l) - (cons (car l) (apply list* (cdr l))))) +(define (list* . l) (apply-nlist* (copy-list l))) -(define (nlist* . l) - (if (atom? (cdr l)) - (car l) - (set-cdr! l (apply nlist* (cdr l))))) +(define (nlist* . l) (apply-nlist* l)) (define (lastcdr l) (if (atom? l) l @@ -255,10 +249,6 @@ (define (reverse lst) (foldl cons () lst)) -(define (copy-list l) - (if (atom? l) l - (cons (car l) - (copy-list (cdr l))))) (define (copy-tree l) (if (atom? l) l (cons (copy-tree (car l))