From b0046ba3929c513a399fd1ebb84dee1712c55a02 Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Fri, 22 Apr 2011 00:58:05 +0000
Subject: 	* boot/utility.boot (copyList): Define. 	(append!):
 Likewise. 	* boot/tokens.boot: Do not translate nconc.

---
 src/boot/ast.boot            |  2 +-
 src/boot/strap/ast.clisp     |  2 +-
 src/boot/strap/tokens.clisp  |  7 +++----
 src/boot/strap/utility.clisp | 22 +++++++++++++++++++++-
 src/boot/tokens.boot         |  3 +--
 src/boot/utility.boot        | 23 ++++++++++++++++++++++-
 6 files changed, 49 insertions(+), 10 deletions(-)

(limited to 'src/boot')

diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index e58179a2..0f09668b 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -1079,7 +1079,7 @@ bfWhere (context,expr)==
   a:=[[first d,second d,bfSUBLIS(opassoc,third d)]
                for d in defs]
   $wheredefs:=append(a,$wheredefs)
-  bfMKPROGN bfSUBLIS(opassoc,nconc(nondefs,[expr]))
+  bfMKPROGN bfSUBLIS(opassoc,append!(nondefs,[expr]))
  
 --shoeReadLispString(s,n)==
 --    n>= # s => nil
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index b903d432..36d45495 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -1975,7 +1975,7 @@
                   (SETQ |bfVar#124| (CDR |bfVar#124|)))))
         (SETQ |$wheredefs| (APPEND |a| |$wheredefs|))
         (|bfMKPROGN|
-            (|bfSUBLIS| |opassoc| (NCONC |nondefs| (LIST |expr|))))))))
+            (|bfSUBLIS| |opassoc| (|append!| |nondefs| (LIST |expr|))))))))
 
 (DEFUN |bfCompHash| (|op| |argl| |body|)
   (PROG (|computeFunction| |auxfn|)
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index 0de0c434..d19d76d8 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -183,9 +183,9 @@
                   (LIST 'CONCAT "") (LIST 'MAX (- 999999))
                   (LIST 'MIN 999999) (LIST '* 1) (LIST '|times| 1)
                   (LIST 'CONS NIL) (LIST 'APPEND NIL)
-                  (LIST '|append| NIL) (LIST 'UNION NIL)
-                  (LIST 'UNIONQ NIL) (LIST '|union| NIL)
-                  (LIST 'NCONC NIL) (LIST '|and| T) (LIST '|or| NIL)
+                  (LIST '|append| NIL) (LIST '|append!| NIL)
+                  (LIST 'UNION NIL) (LIST 'UNIONQ NIL)
+                  (LIST '|union| NIL) (LIST '|and| T) (LIST '|or| NIL)
                   (LIST 'AND T) (LIST 'OR NIL)))
         (|i| NIL))
     (LOOP
@@ -224,7 +224,6 @@
                   (LIST '|lowerCase?| 'LOWER-CASE-P)
                   (LIST '|makeSymbol| 'INTERN)
                   (LIST '|maxIndex| 'MAXINDEX) (LIST '|mkpf| 'MKPF)
-                  (LIST '|nconc| 'NCONC)
                   (LIST '|newString| 'MAKE-STRING)
                   (LIST '|newVector| 'MAKE-ARRAY) (LIST '|nil| NIL)
                   (LIST '|not| 'NOT) (LIST '|null| 'NULL)
diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp
index 9b7dbef4..5e6003fc 100644
--- a/src/boot/strap/utility.clisp
+++ b/src/boot/strap/utility.clisp
@@ -7,7 +7,7 @@
 
 (EXPORT '(|objectMember?| |symbolMember?| |stringMember?| |charMember?|
              |scalarMember?| |listMember?| |reverse| |reverse!|
-             |lastNode|))
+             |lastNode| |append!| |copyList|))
 
 (DEFUN |objectMember?| (|x| |l|)
   (LOOP
@@ -99,3 +99,23 @@
             (T (SETQ |l| |l'|))))
         |l|))))
 
+(DEFUN |copyList| (|l|)
+  (PROG (|l'| |t|)
+    (RETURN
+      (COND
+        ((NOT (CONSP |l|)) |l|)
+        (T (SETQ |l'| (SETQ |t| (LIST (CAR |l|))))
+           (LOOP
+             (PROGN
+               (SETQ |l| (CDR |l|))
+               (COND
+                 ((CONSP |l|) (RPLACD |t| (LIST (CAR |l|)))
+                  (SETQ |t| (CDR |t|)))
+                 (T (RPLACD |t| |l|) (RETURN |l'|))))))))))
+
+(DEFUN |append!| (|x| |y|)
+  (COND
+    ((NULL |x|) |y|)
+    ((NULL |y|) |x|)
+    (T (RPLACD (|lastNode| |x|) |y|) |x|)))
+
diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot
index b89a2b67..3843b785 100644
--- a/src/boot/tokens.boot
+++ b/src/boot/tokens.boot
@@ -225,10 +225,10 @@ for i in [ _
       ["CONS",    nil] , _
       ["APPEND",  nil] , _
       ["append",  nil] , _
+      ["append!", nil] , _
       ["UNION",   nil] , _
       ["UNIONQ",  nil] , _
       ["union",   nil] , _
-      ["NCONC",   nil] , _
       ["and",    true] , _
       ["or",    false] , _
       ["AND",    true] , _
@@ -279,7 +279,6 @@ for i in [ _
   ["makeSymbol", "INTERN"] , _
   ["maxIndex", "MAXINDEX"] , _
   ["mkpf",        "MKPF"]  , _
-  ["nconc",      "NCONC"]  , _
   ["newString", "MAKE-STRING"], _
   ["newVector", "MAKE-ARRAY"], _
   ["nil"           ,NIL ]  , _
diff --git a/src/boot/utility.boot b/src/boot/utility.boot
index 8b1f242f..bde1090b 100644
--- a/src/boot/utility.boot
+++ b/src/boot/utility.boot
@@ -33,7 +33,8 @@
 import initial_-env
 namespace BOOTTRAN
 module utility (objectMember?, symbolMember?, stringMember?,
-  charMember?, scalarMember?, listMember?, reverse, reverse!, lastNode)
+  charMember?, scalarMember?, listMember?, reverse, reverse!,
+  lastNode, append!, copyList)
 
 --% membership operators
 
@@ -112,3 +113,23 @@ lastNode l ==
   while l is [.,:l'] and cons? l' repeat
     l := l'
   l
+
+--% list copying
+copyList l ==
+  not cons? l => l
+  l' := t := [first l]
+  repeat
+    l := rest l
+    cons? l =>
+      t.rest := [first l]
+      t := rest t
+    t.rest := l
+    return l'
+
+--% append
+
+append!(x,y) ==
+  x = nil => y
+  y = nil => x
+  lastNode(x).rest := y
+  x
-- 
cgit v1.2.3