ref: bbcc68cfdf84fd2bd2f804f555c64d808a1c54d5
parent: a23bee041f11b50fe0208a81e7b3690c9661c7ff
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Sat May 30 13:54:27 EDT 2009
making copy-list a builtin, since the functionality was there anyway. adding builtin primitive apply-nlist*, to speed up list* and nlist*
--- 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)))
--- a/femtolisp/flisp.boot
+++ b/femtolisp/flisp.boot
@@ -83,7 +83,7 @@
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->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 @@
#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
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -702,7 +702,8 @@
// 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 @@
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 @@
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 @@
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 @@
{ "function:env", fl_function_env },
{ "gensym", fl_gensym },
{ "hash", fl_hash },
+ { "copy-list", fl_copylist },
+ { "apply-nlist*", fl_apply_nliststar },
{ NULL, NULL }
};
--- 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))