~ chicken-core (chicken-5) 56feb9b9222d125b865e961396efc7d712de0eba

commit 56feb9b9222d125b865e961396efc7d712de0eba
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Aug 7 14:12:07 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Sun Aug 7 14:12:07 2011 +0200

    added internal unsafe reverse proc; marked queue operations that happen to be thread safe; queue->list creates fresh list

diff --git a/data-structures.scm b/data-structures.scm
index 78ff7481..e05a8fd7 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -512,7 +512,7 @@ EOF
       (if (fx>= i len)
 	  (##sys#fragments->string
 	   total
-	   (reverse 
+	   (##sys#fast-reverse 
 	    (if (fx> i from) 
 		(cons (##sys#substring str from i) fs)
 		fs) ) )
@@ -798,11 +798,11 @@ EOF
 (define (make-queue) (##sys#make-structure 'queue '() '()))
 (define (queue? x) (##sys#structure? x 'queue))
 
-(define (queue-empty? q)
+(define (queue-empty? q)		; thread-safe
   (##sys#check-structure q 'queue 'queue-empty?)
   (eq? '() (##sys#slot q 1)) )
 
-(define queue-first
+(define queue-first			; thread-safe
   (lambda (q)
     (##sys#check-structure q 'queue 'queue-first)
     (let ((first-pair (##sys#slot q 1)))
@@ -810,7 +810,7 @@ EOF
 	(##sys#error 'queue-first "queue is empty" q))
       (##sys#slot first-pair 0) ) ) )
 
-(define queue-last
+(define queue-last			; thread-safe
   (lambda (q)
     (##sys#check-structure q 'queue 'queue-last)
     (let ((last-pair (##sys#slot q 2)))
@@ -818,7 +818,7 @@ EOF
 	(##sys#error 'queue-last "queue is empty" q))
       (##sys#slot last-pair 0) ) ) )
 
-(define (queue-add! q datum)
+(define (queue-add! q datum)		; thread-safe
   (##sys#check-structure q 'queue 'queue-add!)
   (let ((new-pair (cons datum '())))
     (cond ((eq? '() (##sys#slot q 1)) (##sys#setslot q 1 new-pair))
@@ -826,7 +826,7 @@ EOF
     (##sys#setslot q 2 new-pair) 
     (##core#undefined) ) )
 
-(define queue-remove!
+(define queue-remove!			; thread-safe
   (lambda (q)
     (##sys#check-structure q 'queue 'queue-remove!)
     (let ((first-pair (##sys#slot q 1)))
@@ -840,9 +840,12 @@ EOF
 
 (define (queue->list q)
   (##sys#check-structure q 'queue 'queue->list)
-  (##sys#slot q 1) )
+  (let loop ((lst (##sys#slot q 1)) (lst2 '()))
+    (if (null? lst)
+	(##sys#fast-reverse lst2)
+	(loop (##sys#slot lst 1) (cons (##sys#slot lst 0) lst2)))))
 
-(define (list->queue lst0)
+(define (list->queue lst0)		
   (##sys#check-list lst0 'list->queue)
   (##sys#make-structure 
    'queue lst0
@@ -858,7 +861,7 @@ EOF
 ; (queue-push-back! queue item)
 ; Pushes an item into the first position of a queue.
 
-(define (queue-push-back! q item)
+(define (queue-push-back! q item)	; thread-safe
   (##sys#check-structure q 'queue 'queue-push-back!)
   (let ((newlist (cons item (##sys#slot q 1))))
     (##sys#setslot q 1 newlist)
diff --git a/extras.scm b/extras.scm
index e790fff8..1d81e876 100644
--- a/extras.scm
+++ b/extras.scm
@@ -41,14 +41,13 @@
 
 (define read-file
   (let ([read read]
-	[reverse reverse] 
 	[call-with-input-file call-with-input-file] )
     (lambda (#!optional (port ##sys#standard-input) (reader read) max)
       (define (slurp port)
 	(do ((x (reader port) (reader port))
 	     (i 0 (fx+ i 1))
 	     (xs '() (cons x xs)) )
-	    ((or (eof-object? x) (and max (fx>= i max))) (reverse xs)) ) )
+	    ((or (eof-object? x) (and max (fx>= i max))) (##sys#fast-reverse xs)) ) )
       (if (port? port)
 	  (slurp port)
 	  (call-with-input-file port slurp) ) ) ) )
@@ -122,10 +121,10 @@
 	(let loop ((lns '())
 		   (n (or max 1000000000)) ) ; this is silly
 	  (if (eq? n 0)
-	      (reverse lns)
+	      (##sys#fast-reverse lns)
 	      (let ((ln (read-line port)))
 		(if (eof-object? ln)
-		    (reverse lns)
+		    (##sys#fast-reverse lns)
 		    (loop (cons ln lns) (fx- n 1)) ) ) ) ) )
       (if (string? port)
 	  (call-with-input-file port doread)
diff --git a/files.scm b/files.scm
index 3830c819..1ca5c3f5 100644
--- a/files.scm
+++ b/files.scm
@@ -368,7 +368,7 @@ EOF
 			     (##sys#string-append drive r)
 			     r))
 		       (let ((out (open-output-string))
-			     (parts (reverse parts)))
+			     (parts (##sys#fast-reverse parts)))
 			 (display (car parts) out)
 			 (for-each
 			  (lambda (p)
diff --git a/irregex.scm b/irregex.scm
index 4c521f64..1766d1ed 100644
--- a/irregex.scm
+++ b/irregex.scm
@@ -157,6 +157,10 @@
       #f                                 ; #3: chunka
       #f))))                             ; #4: fail
 
+(define-compiler-syntax reverse
+  (syntax-rules ()
+    ((_ lst) (##sys#fast-reverse lst))))
+
 (define-compiler-syntax bit-shl
   (syntax-rules ()
     ((_ n i) (fxshl n i))))
diff --git a/library.scm b/library.scm
index 6399e284..267bcb87 100644
--- a/library.scm
+++ b/library.scm
@@ -429,6 +429,12 @@ EOF
 	   (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest)) )
 	  (else (##sys#error-not-a-proper-list lst0 'reverse)) ) ))
 
+(define (##sys#fast-reverse lst0)
+  (let loop ((lst lst0) (rest '()))
+    (if (pair? lst)
+	(loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest))
+	rest)))
+
 (define (memq x lst) (##core#inline "C_i_memq" x lst))
 (define (memv x lst) (##core#inline "C_i_memv" x lst))
 (define (member x lst) (##core#inline "C_i_member" x lst))
@@ -2285,8 +2291,7 @@ EOF
        args) ) ) )
 
 (define ##sys#read
-  (let ((reverse reverse)
-	(string-append string-append)
+  (let ((string-append string-append)
 	(keyword-style keyword-style)
 	(case-sensitive case-sensitive)
 	(parantheses-synonyms parantheses-synonyms)
@@ -2577,7 +2582,7 @@ EOF
 			   (case (and sep c)
 			     ((#\|) 
 			      (let ((part (r-string #\|)))
-				(loop (append (reverse (##sys#string->list part)) lst)
+				(loop (append (##sys#fast-reverse (##sys#string->list part)) lst)
 				      #f)))
 			     ((#\newline)
 			      (##sys#read-warning
@@ -4297,7 +4302,6 @@ EOF
 
 (set! ##sys#user-read-hook
   (let ([old ##sys#user-read-hook]
-	[reverse reverse]
 	[read read]
 	[display display] )
     (define (readln port)
diff --git a/manual/Unit data-structures b/manual/Unit data-structures
index 9b46706b..e8388236 100644
--- a/manual/Unit data-structures	
+++ b/manual/Unit data-structures	
@@ -155,7 +155,7 @@ Returns {{#t}} if {{X}} is a queue, or {{#f}} otherwise.
 
 Returns {{QUEUE}} converted into a list, where the first element
 of the list is the same as the first element of the queue. The resulting
-list may share memory with the queue object and should not be modified.
+list is freshly allocated and does not share memory with the queue object.
 
 
 ==== queue-add!
diff --git a/modules.scm b/modules.scm
index 4e8f2d3d..5cd75a10 100644
--- a/modules.scm
+++ b/modules.scm
@@ -292,7 +292,7 @@
 	(mifs (module-meta-import-forms mod)))
     `(,@(if (pair? ifs) `((eval '(import ,@(##sys#strip-syntax ifs)))) '())
       ,@(if (pair? mifs) `((import ,@(##sys#strip-syntax mifs))) '())
-      ,@(reverse (map ##sys#strip-syntax (module-meta-expressions mod)))
+      ,@(##sys#fast-reverse (map ##sys#strip-syntax (module-meta-expressions mod)))
       (##sys#register-compiled-module
        ',(module-name mod)
        (list
diff --git a/ports.scm b/ports.scm
index eee54b6d..6e5275af 100644
--- a/ports.scm
+++ b/ports.scm
@@ -54,7 +54,7 @@
     (let loop ((xs '()))
       (let ((x (thunk)))
 	(if (eof-object? x)
-	    (reverse xs)
+	    (##sys#fast-reverse xs)
 	    (loop (cons (fn x) xs)))))))
 
 (define (port-fold fn acc thunk)
diff --git a/posixwin.scm b/posixwin.scm
index 28f8c5fa..45ca60af 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -1524,7 +1524,7 @@ EOF
 		      [else (loop (fx+ i 1))]))))])
 	  (let loop ([ilst lst] [olst '()])
 	    (if (null? ilst)
-		(reverse olst)
+		(##sys#fast-reverse olst)
 		(let ([str (car ilst)])
 		  (loop
 		   (cdr ilst)