From b8b7ff303c7ca893d9d5c09ec8e7cf86848d7434 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Sun, 30 Apr 2017 18:02:09 +0200
Subject: [PATCH 3/3] Remove ##sys#nodups, move {take,drop}-right into
 chicken.internal

The ##sys#nodups and corresponding ##sys#del procedures are just
differently named (and specialisable) versions of delete-duplicates
and delete from SRFI-1.  So, we load mini-srfi-1.scm into csi.scm, and
get rid of those definition in library.scm.

We also get rid of the optional arguments in the SRFI-1 "delete" and
"delete-duplicates" definitions because that's completely unnecessary
for a fast internal API.

Finally, ##sys#take-right and ##sys#drop-right (which are used
exclusively by syntax-rules) are moved into chicken.internal just
like we did for the helpers for the "time" macro.
---
 batch-driver.scm      |  2 +-
 chicken-status.scm    |  2 +-
 chicken-uninstall.scm |  2 +-
 core.scm              |  4 ++--
 csi.scm               |  4 +++-
 internal.scm          | 30 ++++++++++++++++++++++++++++++
 library.scm           | 41 -----------------------------------------
 mini-srfi-1.scm       |  8 ++++----
 optimizer.scm         |  2 +-
 rules.make            |  2 +-
 synrules.scm          |  4 ++--
 11 files changed, 46 insertions(+), 55 deletions(-)

diff --git a/batch-driver.scm b/batch-driver.scm
index 7cb8b51..0f920f5 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -447,7 +447,7 @@
 	   (when (not f) (quit-compiling "cannot load extension: ~a" e))
 	   (load f)))
        extends) )
-    (set! ##sys#features (delete #:compiler-extension ##sys#features))
+    (set! ##sys#features (delete #:compiler-extension ##sys#features eq?))
     (set! ##sys#features (cons '#:compiling ##sys#features))
     (set! upap (user-post-analysis-pass))
 
diff --git a/chicken-status.scm b/chicken-status.scm
index 2fb54c5..8b49a14 100644
--- a/chicken-status.scm
+++ b/chicken-status.scm
@@ -77,7 +77,7 @@
                             (lambda (egg)
                               (any (cut string=? <> egg) patterns))
                             eggs)))))
-      (delete-duplicates names)))
+      (delete-duplicates names string=?)))
 
   (define (gather-eggs)
     (delete-duplicates
diff --git a/chicken-uninstall.scm b/chicken-uninstall.scm
index d9c7925..4ade54a 100644
--- a/chicken-uninstall.scm
+++ b/chicken-uninstall.scm
@@ -69,7 +69,7 @@
                      (lambda (egg)
                        (any (cut string=? <> egg) patterns))
                      eggs))))
-    (delete-duplicates pats)))
+    (delete-duplicates pats string=?)))
 
 (define (fini code)
   (print "aborted.")
diff --git a/core.scm b/core.scm
index a9c2510..41a7814 100644
--- a/core.scm
+++ b/core.scm
@@ -997,7 +997,7 @@
 							     ;; Remove from list to avoid error
 							     (when (pair? il)
 							       (set! import-libraries
-								 (delete il import-libraries)))
+								 (delete il import-libraries equal?)))
 							     (values (reverse xs) '())))
 						       ((not enable-module-registration)
 							(values (reverse xs) '()))
@@ -2423,7 +2423,7 @@
 	   (when (pair? (cdr params)) (bomb "let-node has invalid format" params))
 	   (let ((c (gather (first subs) here locals))
 		 (var (first params)))
-	     (append c (delete var (gather (second subs) here (cons var locals))))))
+	     (append c (delete var (gather (second subs) here (cons var locals)) eq?))))
 
 	  ((set!)
 	   (let ((var (first params))
diff --git a/csi.scm b/csi.scm
index 468a14d..e6890d4 100644
--- a/csi.scm
+++ b/csi.scm
@@ -58,6 +58,7 @@ EOF
 	chicken.repl)
 
 (include "banner.scm")
+(include "mini-srfi-1.scm")
 
 ;;; Parameters:
 
@@ -959,6 +960,7 @@ EOF
 (define-constant complex-options
   '("-D" "-feature" "-I" "-include-path" "-K" "-keyword-style" "-no-feature") )
 
+
 (define (run)
   (let* ([extraopts (parse-option-string (or (get-environment-variable "CSI_OPTIONS") ""))]
 	 [args (canonicalize-args (command-line-arguments))]
@@ -1031,7 +1033,7 @@ EOF
       (for-each register-feature! (collect-options "-D"))
       (for-each unregister-feature! (collect-options "-no-feature"))
       (set! ##sys#include-pathnames 
-	(##sys#nodups
+	(delete-duplicates
 	 (append (map chop-separator (collect-options "-include-path"))
 		 (map chop-separator (collect-options "-I"))
 		 ##sys#include-pathnames
diff --git a/internal.scm b/internal.scm
index 6ef7628..ea6490c 100644
--- a/internal.scm
+++ b/internal.scm
@@ -34,6 +34,9 @@
 ;; particular.
 (module chicken.internal
    (
+    ;; SRFI-1 workalikes, as support for "syntax-rules" macro
+    take-right drop-right
+
     ;; Timing information (support for "time" macro)
     start-timer stop-timer display-timer-statistics
 
@@ -55,6 +58,33 @@
 (include "common-declarations.scm")
 (include "mini-srfi-1.scm")
 
+;; SRFI-1 workalikes, as support for "syntax-rules" macro:
+;;
+;; NOTE: these are not part of mini-srfi-1.scm because they're not
+;; inlineable since they're used in the expansion, rather than in the
+;; syntax-rules macro processor itself.  We don't put it in
+;; mini-srfi-1, because everything that uses internal *and*
+;; mini-srfi-1 would start to complain about redefinitions of already
+;; imported procedures.
+(define (drop-right input temp)
+  ;;XXX use unsafe accessors
+  (let loop ((len (length input))
+	     (input input))
+    (cond
+     ((> len temp)
+      (cons (car input)
+	    (loop (- len 1) (cdr input))))
+     (else '()))))
+
+(define (take-right input temp)
+  ;;XXX use unsafe accessors
+  (let loop ((len (length input))
+	     (input input))
+    (cond
+     ((> len temp)
+      (loop (- len 1) (cdr input)))
+     (else input))))
+
 ;;; Timing information (support for "time" macro):
 
 (define (start-timer)
diff --git a/library.scm b/library.scm
index 0b324db..199157f 100644
--- a/library.scm
+++ b/library.scm
@@ -5650,47 +5650,6 @@ EOF
 	(f (##sys#slot lst 0) (loop (##sys#slot lst 1))))))
 
 
-;; Some list-operations, used by the syntax-rules implementation, inside module
-;; implementation and in csi
-
-(define (##sys#del x lst tst)
-  (let loop ((lst lst))
-    (if (null? lst)
-	'()
-	(let ((y (car lst)))
-	  (if (tst x y)
-	      (cdr lst)
-	      (cons y (loop (cdr lst))) ) ) ) ) )
-
-(define (##sys#nodups lis elt=)
-  (let recur ((lis lis))
-    (if (null? lis) lis
-	(let* ((x (car lis))
-	       (tail (cdr lis))
-	       (new-tail (recur (##sys#del x tail elt=))))
-	  (if (eq? tail new-tail) lis (cons x new-tail))))))
-
-;; contributed by Peter Bex
-(define (##sys#drop-right input temp)
-  ;;XXX use unsafe accessors
-  (let loop ((len (length input))
-	     (input input))
-    (cond
-     ((> len temp)
-      (cons (car input)
-	    (loop (- len 1) (cdr input))))
-     (else '()))))
-
-(define (##sys#take-right input temp)
-  ;;XXX use unsafe accessors
-  (let loop ((len (length input))
-	     (input input))
-    (cond
-     ((> len temp)
-      (loop (- len 1) (cdr input)))
-     (else input))))
-
-
 ;;; Platform configuration inquiry:
 
 (module chicken.platform
diff --git a/mini-srfi-1.scm b/mini-srfi-1.scm
index cd74dbe..627aa0f 100644
--- a/mini-srfi-1.scm
+++ b/mini-srfi-1.scm
@@ -26,8 +26,8 @@
 
 
 (declare 
-  (unused take span drop partition split-at append-map every any cons* concatenate delete
-	  first second third fourth alist-cons delete-duplicates fifth remove
+  (unused take span drop partition split-at append-map every any cons* concatenate
+	  first second third fourth alist-cons fifth remove
 	  filter filter-map unzip1 last list-index lset-adjoin/eq? lset-difference/eq?
 	  lset-union/eq? lset-intersection/eq? list-tabulate lset<=/eq? lset=/eq? length+
 	  find find-tail iota make-list posq posv)
@@ -100,7 +100,7 @@
 	'()
 	(append (car lst) (loop (cdr lst))))))
 
-(define (delete x lst #!optional (test equal?))
+(define (delete x lst test)
   (let loop ((lst lst))
     (cond ((null? lst) lst)
 	  ((test x (car lst))
@@ -114,7 +114,7 @@
 (define (fourth x) (cadddr x))
 (define (fifth x) (car (cddddr x)))
 
-(define (delete-duplicates lst #!optional (test equal?))
+(define (delete-duplicates lst test)
   (let loop ((lst lst))
     (if (null? lst)
 	lst
diff --git a/optimizer.scm b/optimizer.scm
index 6c88196..9fb5c48 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -126,7 +126,7 @@
     (debugging 'p "scanning toplevel assignments...")
     (scan node '())
     (when (pair? safe)
-      (debugging 'o "safe globals" (delete-duplicates safe)))
+      (debugging 'o "safe globals" (delete-duplicates safe eq?)))
     (for-each (cut mark-variable <> '##compiler#always-bound) safe)))
 
 
diff --git a/rules.make b/rules.make
index 7557b07..336a5b5 100644
--- a/rules.make
+++ b/rules.make
@@ -856,7 +856,7 @@ endef
 $(foreach obj, $(COMPILER_OBJECTS_1),\
           $(eval $(call declare-bootstrap-compiler-object,$(obj))))
 
-csi.c: $(SRCDIR)csi.scm $(SRCDIR)banner.scm
+csi.c: $(SRCDIR)csi.scm $(SRCDIR)banner.scm $(SRCDIR)mini-srfi-1.scm
 	$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
 chicken-profile.c: $(SRCDIR)chicken-profile.scm $(SRCDIR)mini-srfi-1.scm
 	$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@ 
diff --git a/synrules.scm b/synrules.scm
index cf8912e..df89404 100644
--- a/synrules.scm
+++ b/synrules.scm
@@ -176,7 +176,7 @@
            (let* ((tail-length (length (cddr pattern)))
                   (%match (if (zero? tail-length) ; Simple segment?
                               path  ; No list traversing overhead at runtime!
-                              `(##sys#drop-right ,path ,tail-length))))
+                              `(chicken.internal#drop-right ,path ,tail-length))))
              (append
               (process-pattern (car pattern)
                                %temp
@@ -187,7 +187,7 @@
                                       `(,%map1 (,%lambda (,%temp) ,x) ,%match))))
                                #f)
               (process-pattern (cddr pattern)
-                               `(##sys#take-right ,path ,tail-length) mapit #t))))
+                               `(chicken.internal#take-right ,path ,tail-length) mapit #t))))
 	  ((pair? pattern)
 	   (append (process-pattern (car pattern) `(,%car ,path) mapit #f)
 		   (process-pattern (cdr pattern) `(,%cdr ,path) mapit #f)))
-- 
2.1.4