[Guile-commits] 01/02: Single definition of (iota)

[Daniel Llorens]

lloda pushed a commit to branch wip-exception-truncate
in repository guile.

commit 98252bff643ac05b9fb53f28c25f216f090b2495
Author: Daniel Llorens <address@hidden>
Date:   Fri Dec 6 13:08:08 2019 +0100

    Single definition of (iota)
    
    * module/ice-9/boot-9.scm (iota): Fix to be SRFI-1 compatible.
    * module/srfi/srfi-1.scm: Re-export iota.
---
 module/ice-9/boot-9.scm | 53 +++++++++++++++++++++++++++----------------------
 module/srfi/srfi-1.scm  | 30 +++++++++++-----------------
 2 files changed, 41 insertions(+), 42 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index b5ce5f3..b602de2 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -6,12 +6,12 @@
 ;;;; modify it under the terms of the GNU Lesser General Public
 ;;;; License as published by the Free Software Foundation; either
 ;;;; version 3 of the License, or (at your option) any later version.
-;;;; 
+;;;;
 ;;;; This library is distributed in the hope that it will be useful,
 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 ;;;; Lesser General Public License for more details.
-;;;; 
+;;;;
 ;;;; You should have received a copy of the GNU Lesser General Public
 ;;;; License along with this library; if not, write to the Free Software
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
@@ -883,10 +883,15 @@ VALUE."
 ;;; {IOTA functions: generating lists of numbers}
 ;;;
 
-(define (iota n)
-  (let loop ((count (1- n)) (result '()))
-    (if (< count 0) result
-        (loop (1- count) (cons count result)))))
+;;;  Compatible with srfi-1 so it can just be reused there.
+
+(define* (iota count #:optional (start 0) (step 1))
+  (unless (and (integer? count) (>= count 0))
+    (throw 'wrong-type-arg count))
+  (let loop ((n (- count 1)) (result '()))
+    (if (negative? n)
+      result
+      (loop (- n 1) (cons (+ start (* n step)) result)))))
 
 
 
@@ -989,7 +994,7 @@ VALUE."
         (let lp ((i 0))
           (if (< i n)
               (cons (datum->syntax
-                     x 
+                     x
                      (string->symbol
                       (string (integer->char (+ (char->integer #\a) i)))))
                     (lp (1+ i)))
@@ -2326,7 +2331,7 @@ name extensions listed in %load-extensions."
                                  (map (lambda (x)
                                         (if (symbol? x) x (syntax->datum x)))
                                       fragments))))
-         
+
          (define (getter rtd type-name field slot)
            (define id (make-id rtd type-name '- field))
            #`(define #,id
@@ -3219,7 +3224,7 @@ deterministic."
   (let ((f (module-filename m)))
     (if f
         (save-module-excursion
-         (lambda () 
+         (lambda ()
            ;; Re-set the initial environment, as in try-module-autoload.
            (set-current-module (make-fresh-user-module))
            (primitive-load-path f)
@@ -3342,7 +3347,7 @@ error if selected binding does not exist in the used 
module."
     (or (symbol? x) (and (pair? x) (symbol? (car x)) (symbol? (cdr x)))))
   (define (valid-autoload? x)
     (and (pair? x) (list-of symbol? (car x)) (list-of symbol? (cdr x))))
-  
+
   ;; We could add a #:no-check arg, set by the define-module macro, if
   ;; these checks are taking too much time.
   ;;
@@ -3397,7 +3402,7 @@ error if selected binding does not exist in the used 
module."
       (let ((iface (resolve-interface transformer))
             (sym (car (last-pair transformer))))
         (set-module-transformer! module (module-ref iface sym))))
-    
+
     (run-hook module-defined-hook module)
     module))
 
@@ -3723,7 +3728,7 @@ but it fails to load."
               (let lp ()
                 (call-with-prompt
                  continue-tag
-                 (lambda () 
+                 (lambda ()
                    (define-syntax #,(datum->syntax #'while 'continue)
                      (lambda (x)
                        (syntax-case x ()
@@ -3765,7 +3770,7 @@ but it fails to load."
              (eqv? (string-ref (symbol->string dat) 0) #\:))))
     (define (->keyword sym)
       (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
-    
+
     (define (parse-iface args)
       (let loop ((in args) (out '()))
         (syntax-case in ()
@@ -3850,7 +3855,7 @@ but it fails to load."
         ((kw val . args)
          (syntax-violation 'define-module "unknown keyword or bad argument"
                            #'kw #'val))))
-    
+
     (syntax-case x ()
       ((_ (name name* ...) arg ...)
        (and-map symbol? (syntax->datum #'(name name* ...)))
@@ -3892,7 +3897,7 @@ but it fails to load."
              (eqv? (string-ref (symbol->string dat) 0) #\:))))
     (define (->keyword sym)
       (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
-    
+
     (define (quotify-iface args)
       (let loop ((in args) (out '()))
         (syntax-case in ()
@@ -3919,7 +3924,7 @@ but it fails to load."
            (with-syntax (((quoted-arg ...) (quotify-iface #'(arg ...))))
              (lp #'in (cons #`(list '(name name* ...) quoted-arg ...)
                             out)))))))
-    
+
     (syntax-case x ()
       ((_ spec ...)
        (with-syntax (((quoted-args ...) (quotify #'(spec ...))))
@@ -4064,7 +4069,7 @@ but it fails to load."
 
 (define duplicate-handlers
   (let ((m (make-module)))
-    
+
     (define (check module name int1 val1 int2 val2 var val)
       (scm-error 'misc-error
                  #f
@@ -4074,7 +4079,7 @@ but it fails to load."
                        (module-name int1)
                        (module-name int2))
                  #f))
-    
+
     (define (warn module name int1 val1 int2 val2 var val)
       (format (current-warning-port)
               "WARNING: ~A: `~A' imported from both ~A and ~A\n"
@@ -4083,7 +4088,7 @@ but it fails to load."
               (module-name int1)
               (module-name int2))
       #f)
-     
+
     (define (replace module name int1 val1 int2 val2 var val)
       (let* ((replace1 (hashq-ref (module-replacements int1) name))
              (replace2 (hashq-ref (module-replacements int2) name))
@@ -4094,7 +4099,7 @@ but it fails to load."
             (and (or (eq? old new) (not replace2))
                  old)
             (and replace2 new))))
-    
+
     (define (warn-override-core module name int1 val1 int2 val2 var val)
       (and (eq? int1 the-scm-module)
            (begin
@@ -4104,16 +4109,16 @@ but it fails to load."
                      (module-name int2)
                      name)
              (module-local-variable int2 name))))
-     
+
     (define (first module name int1 val1 int2 val2 var val)
       (or var (module-local-variable int1 name)))
-     
+
     (define (last module name int1 val1 int2 val2 var val)
       (module-local-variable int2 name))
-     
+
     (define (noop module name int1 val1 int2 val2 var val)
       #f)
-    
+
     (set-module-name! m 'duplicate-handlers)
     (set-module-kind! m 'interface)
     (module-define! m 'check check)
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 0806e73..c0ee535 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -6,12 +6,12 @@
 ;; modify it under the terms of the GNU Lesser General Public
 ;; License as published by the Free Software Foundation; either
 ;; version 3 of the License, or (at your option) any later version.
-;; 
+;;
 ;; This library is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 ;; Lesser General Public License for more details.
-;; 
+;;
 ;; You should have received a copy of the GNU Lesser General Public
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
@@ -48,7 +48,7 @@
  list-tabulate
  list-copy
  circular-list
- ;; iota                               ; Extended.
+ ;; iota                               <= in the core
 
 ;;; Predicates
  proper-list?
@@ -216,8 +216,9 @@
              caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
              cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
              list-ref last-pair length append append! reverse reverse!
-             filter filter! memq memv assq assv set-car! set-cdr!)
-  :replace (iota map for-each map-in-order list-copy list-index member
+             filter filter! memq memv assq assv set-car! set-cdr!
+              iota)
+  :replace (map for-each map-in-order list-copy list-index member
            delete delete! assoc)
   )
 
@@ -266,13 +267,6 @@ INIT-PROC is applied to the indices is not specified."
   (set-cdr! (last-pair elts) elts)
   elts)
 
-(define* (iota count #:optional (start 0) (step 1))
-  (check-arg non-negative-integer? count iota)
-  (let lp ((n 0) (acc '()))
-    (if (= n count)
-       (reverse! acc)
-       (lp (+ n 1) (cons (+ start (* n step)) acc)))))
-
 ;;; Predicates
 
 (define (proper-list? x)
@@ -363,7 +357,7 @@ end-of-list checking in contexts where dotted lists are 
allowed."
 (define take list-head)
 (define drop list-tail)
 
-;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, 
+;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list,
 ;;; off by K, then chasing down the list until the lead pointer falls off
 ;;; the end.  Note that they diverge for circular lists.
 
@@ -591,7 +585,7 @@ has just one element then that's the return value."
        (if (pair? l)
            (cons (f (car l)) (map1 (cdr l)))
            '())))
-    
+
     ((f l1 l2)
      (check-arg procedure? f map)
      (let* ((len1 (length+ l1))
@@ -677,7 +671,7 @@ has just one element then that's the return value."
 
 (define (append-map f clist1 . rest)
   (concatenate (apply map f clist1 rest)))
-  
+
 (define (append-map! f clist1 . rest)
   (concatenate! (apply map f clist1 rest)))
 
@@ -913,7 +907,7 @@ and those making the associations."
    ;; relying on memq/memv to check that = is a procedure.
    ((eq? = eq?) (memq x ls))
    ((eq? = eqv?) (memv x ls))
-   (else 
+   (else
     (check-arg procedure? = member)
     (find-tail (lambda (y) (= x y)) ls))))
 
@@ -961,7 +955,7 @@ given REST parameters."
         (begin
           (check-arg procedure? = lset-adjoin)
           (lambda (x y) (= y x)))))
-  
+
   (let lp ((ans list) (rest rest))
     (if (null? rest)
         ans
@@ -978,7 +972,7 @@ given REST parameters."
         (begin
           (check-arg procedure? = lset-union)
           (lambda (x y) (= y x)))))
-  
+
   (fold (lambda (lis ans)              ; Compute ANS + LIS.
           (cond ((null? lis) ans)      ; Don't copy any lists
                 ((null? ans) lis)      ; if we don't have to.