From bbcc68cfdf84fd2bd2f804f555c64d808a1c54d5 Mon Sep 17 00:00:00 2001
From: JeffBezanson <jeff.bezanson@gmail.com>
Date: Sat, 30 May 2009 17:54:27 +0000
Subject: [PATCH] making copy-list a builtin, since the functionality was there
 anyway. adding builtin primitive apply-nlist*, to speed up list* and nlist*

---
 femtolisp/compiler.lsp |  2 +-
 femtolisp/flisp.boot   |  6 ++----
 femtolisp/flisp.c      | 30 +++++++++++++++++++++++++++---
 femtolisp/system.lsp   | 14 ++------------
 4 files changed, 32 insertions(+), 20 deletions(-)

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))