unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
From: Kevin Ryde <user42@zip.com.au>
Subject: srfi-1 count
Date: Tue, 25 Nov 2003 08:09:18 +1000	[thread overview]
Message-ID: <87oev1v2pd.fsf@zip.com.au> (raw)

[-- Attachment #1: Type: text/plain, Size: 102 bytes --]

        * srfi-1.c, srfi-1.h, srfi-1.scm (count): Rewrite in C, avoiding
        non-tail recursion.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: count.c --]
[-- Type: text/x-csrc, Size: 3352 bytes --]

SCM scm_srfi1_count (SCM pred, SCM lst1, SCM rest);


SCM_DEFINE (scm_srfi1_count, "count", 2, 0, 1,
            (SCM pred, SCM lst1, SCM rest),
	    "Return a count of the number of times @var{pred} returns true\n"
	    "when called on elements from the given lists.\n"
	    "\n"
	    "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
	    "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
	    "corresponding @var{lst1} @dots{} @var{lstN}.  The first call is\n"
	    "with the first element of each list, the second with the second\n"
	    "element from each, and so on.\n"
	    "\n"
	    "Counting stops when the end of the shortest list is reached.\n"
	    "At least one list must be non-circular.")
#define FUNC_NAME s_scm_srfi1_count
{
  long  count;
  SCM_VALIDATE_REST_ARGUMENT (rest);

  count = 0;

  if (SCM_NULLP (rest))
    {
      /* one list */
      scm_t_trampoline_1 pred_tramp;
      pred_tramp = scm_trampoline_1 (pred);
      SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);

      for ( ; SCM_CONSP (lst1); lst1 = SCM_CDR (lst1))
        count += ! SCM_FALSEP (pred_tramp (pred, SCM_CAR (lst1)));

    end_lst1:
      SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst1), lst1, SCM_ARG2, FUNC_NAME,
                       "list");
    }
  else if (SCM_CONSP (rest) && SCM_NULLP (SCM_CDR (rest)))
    {
      /* two lists */
      scm_t_trampoline_2 pred_tramp;
      SCM lst2;

      pred_tramp = scm_trampoline_2 (pred);
      SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);

      lst2 = SCM_CAR (rest);
      for (;;)
        {
          if (! SCM_CONSP (lst1))
            goto end_lst1;
          if (! SCM_CONSP (lst2))
            {
              SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst2), lst2, SCM_ARG3,
                               FUNC_NAME, "list");
              break;
            }
          count += ! SCM_FALSEP (pred_tramp
                                 (pred, SCM_CAR (lst1), SCM_CAR (lst2)));
          lst1 = SCM_CDR (lst1);
          lst2 = SCM_CDR (lst2);
        }
    }
  else
    {
      /* three or more lists */
      SCM  lstlst, args, l, a, lst;
      int  argnum;

      /* lstlst is a list of the list arguments */
      lstlst = scm_cons (lst1, rest);

      /* args is the argument list to pass to pred, same length as lstlst,
         re-used for each call */
      args = SCM_EOL;
      for (l = lstlst; SCM_CONSP (l); l = SCM_CDR (l))
        args = scm_cons (SCM_BOOL_F, args);

      for (;;)
        {
          /* first elem of each list in lstlst into args, and step those
             lstlst entries onto their next element */
          for (l = lstlst, a = args, argnum = 2;
               SCM_CONSP (l);
               l = SCM_CDR (l), a = SCM_CDR (a), argnum++)
            {
              lst = SCM_CAR (l);  /* list argument */
              if (! SCM_CONSP (lst))
                {
                  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst,
                                   argnum, FUNC_NAME, "list");
                  goto done;
                }
              SCM_SETCAR (a, SCM_CAR (lst));  /* arg for pred */
              SCM_SETCAR (l, SCM_CDR (lst));  /* keep rest of lst */
            }

          count += ! SCM_FALSEP (scm_apply (pred, args, SCM_EOL));
        }
    }
 done:
  return SCM_MAKINUM (count);
}
#undef FUNC_NAME



[-- Attachment #3: count.tes --]
[-- Type: application/octet-stream, Size: 6280 bytes --]

(define-module (x y)
  #:use-module (srfi srfi-1)
  #:use-module (test-suite lib))

;;
;; count
;;

(with-test-prefix "count"
  (pass-if-exception "no args" exception:wrong-num-args
    (count))
  
  (pass-if-exception "one arg" exception:wrong-num-args
    (count noop))
  
  (with-test-prefix "one list"
    (define (or1 x)
      x)
    
    (pass-if "empty list" (= 0 (count or1 '())))
    
    (pass-if-exception "pred arg count 0" exception:wrong-type-arg
      (count (lambda () x) '(1 2 3)))
    (pass-if-exception "pred arg count 2" exception:wrong-type-arg
      (count (lambda (x y) x) '(1 2 3)))
    
    (pass-if-exception "improper 1" exception:wrong-type-arg
      (count or1 1))
    (pass-if-exception "improper 2" exception:wrong-type-arg
      (count or1 '(1 . 2)))
    (pass-if-exception "improper 3" exception:wrong-type-arg
      (count or1 '(1 2 . 3)))
    
    (pass-if (= 0 (count or1 '(#f))))
    (pass-if (= 1 (count or1 '(#t))))
    
    (pass-if (= 0 (count or1 '(#f #f))))
    (pass-if (= 1 (count or1 '(#f #t))))
    (pass-if (= 1 (count or1 '(#t #f))))
    (pass-if (= 2 (count or1 '(#t #t))))
    
    (pass-if (= 0 (count or1 '(#f #f #f))))
    (pass-if (= 1 (count or1 '(#f #f #t))))
    (pass-if (= 1 (count or1 '(#t #f #f))))
    (pass-if (= 2 (count or1 '(#t #f #t))))
    (pass-if (= 3 (count or1 '(#t #t #t)))))
  
  (with-test-prefix "two lists"
    (define (or2 x y)
      (or x y))
    
    (pass-if "arg order"
      (= 1 (count (lambda (x y)
		    (and (= 1 x)
			 (= 2 y)))
		  '(1) '(2))))
    
    (pass-if "empty lists" (= 0 (count or2 '() '())))
    
    (pass-if-exception "pred arg count 0" exception:wrong-type-arg
      (count (lambda () #t) '(1 2 3) '(1 2 3)))
    (pass-if-exception "pred arg count 1" exception:wrong-type-arg
      (count (lambda (x) x) '(1 2 3) '(1 2 3)))
    (pass-if-exception "pred arg count 3" exception:wrong-type-arg
      (count (lambda (x y z) x) '(1 2 3) '(1 2 3)))
    
    (pass-if-exception "improper first 1" exception:wrong-type-arg
      (count or2 1 '(1 2 3)))
    (pass-if-exception "improper first 2" exception:wrong-type-arg
      (count or2 '(1 . 2) '(1 2 3)))
    (pass-if-exception "improper first 3" exception:wrong-type-arg
      (count or2 '(1 2 . 3) '(1 2 3)))
    
    (pass-if-exception "improper second 1" exception:wrong-type-arg
      (count or2 '(1 2 3) 1))
    (pass-if-exception "improper second 2" exception:wrong-type-arg
      (count or2 '(1 2 3) '(1 . 2)))
    (pass-if-exception "improper second 3" exception:wrong-type-arg
      (count or2 '(1 2 3) '(1 2 . 3)))
    
    (pass-if (= 0 (count or2 '(#f) '(#f))))
    (pass-if (= 1 (count or2 '(#t) '(#f))))
    (pass-if (= 1 (count or2 '(#f) '(#t))))
    
    (pass-if (= 0 (count or2 '(#f #f) '(#f #f))))
    (pass-if (= 1 (count or2 '(#t #f) '(#t #f))))
    (pass-if (= 2 (count or2 '(#t #t) '(#f #f))))
    (pass-if (= 2 (count or2 '(#t #f) '(#f #t))))
    
    (with-test-prefix "stop shortest"
      (pass-if (= 2 (count or2 '(#t #f #t) '(#f #t))))
      (pass-if (= 2 (count or2 '(#t #f #t #t) '(#f #t))))
      (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t))))
      (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t #t))))))
  
  (with-test-prefix "three lists"
    (define (or3 x y z)
      (or x y z))
    
    (pass-if "arg order"
      (= 1 (count (lambda (x y z)
		    (and (= 1 x)
			 (= 2 y)
			 (= 3 z)))
		  '(1) '(2) '(3))))
    
    (pass-if "empty lists" (= 0 (count or3 '() '() '())))
    
    ;; currently bad pred argument gives wrong-num-args when 3 or more
    ;; lists, as opposed to wrong-type-arg for 1 or 2 lists
    (pass-if-exception "pred arg count 0" exception:wrong-num-args
      (count (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3)))
    (pass-if-exception "pred arg count 2" exception:wrong-num-args
      (count (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) ))
    (pass-if-exception "pred arg count 4" exception:wrong-num-args
      (count (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3)))
    
    (pass-if-exception "improper first 1" exception:wrong-type-arg
      (count or3 1 '(1 2 3) '(1 2 3)))
    (pass-if-exception "improper first 2" exception:wrong-type-arg
      (count or3 '(1 . 2) '(1 2 3) '(1 2 3)))
    (pass-if-exception "improper first 3" exception:wrong-type-arg
      (count or3 '(1 2 . 3) '(1 2 3) '(1 2 3)))
    
    (pass-if-exception "improper second 1" exception:wrong-type-arg
      (count or3 '(1 2 3) 1 '(1 2 3)))
    (pass-if-exception "improper second 2" exception:wrong-type-arg
      (count or3 '(1 2 3) '(1 . 2) '(1 2 3)))
    (pass-if-exception "improper second 3" exception:wrong-type-arg
      (count or3 '(1 2 3) '(1 2 . 3) '(1 2 3)))
    
    (pass-if-exception "improper third 1" exception:wrong-type-arg
      (count or3 '(1 2 3) '(1 2 3) 1))
    (pass-if-exception "improper third 2" exception:wrong-type-arg
      (count or3 '(1 2 3) '(1 2 3) '(1 . 2)))
    (pass-if-exception "improper third 3" exception:wrong-type-arg
      (count or3 '(1 2 3) '(1 2 3) '(1 2 . 3)))
    
    (pass-if (= 0 (count or3 '(#f) '(#f) '(#f))))
    (pass-if (= 1 (count or3 '(#t) '(#f) '(#f))))
    (pass-if (= 1 (count or3 '(#f) '(#t) '(#f))))
    (pass-if (= 1 (count or3 '(#f) '(#f) '(#t))))
    
    (pass-if (= 0 (count or3 '(#f #f) '(#f #f) '(#f #f))))
    
    (pass-if (= 1 (count or3 '(#t #f) '(#f #f) '(#f #f))))
    (pass-if (= 1 (count or3 '(#f #t) '(#f #f) '(#f #f))))
    (pass-if (= 1 (count or3 '(#f #f) '(#t #f) '(#f #f))))
    (pass-if (= 1 (count or3 '(#f #f) '(#f #t) '(#f #f))))
    (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#t #f))))
    (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#f #t))))
    
    (pass-if (= 2 (count or3 '(#t #t) '(#f #f) '(#f #f))))
    (pass-if (= 2 (count or3 '(#f #f) '(#t #t) '(#f #f))))
    (pass-if (= 2 (count or3 '(#f #f) '(#f #f) '(#t #t))))
    (pass-if (= 2 (count or3 '(#f #f) '(#t #f) '(#f #t))))
    
    (with-test-prefix "stop shortest"
      (pass-if (= 0 (count or3 '() '(#t #t #t) '(#t #t))))
      (pass-if (= 0 (count or3 '(#t #t #t) '() '(#t #t))))
      (pass-if (= 0 (count or3 '(#t #t #t) '(#t #t) '())))
      
      (pass-if (= 1 (count or3 '(#t) '(#t #t #t) '(#t #t))))
      (pass-if (= 1 (count or3 '(#t #t #t) '(#t) '(#t #t))))
      (pass-if (= 1 (count or3 '(#t #t #t) '(#t #t) '(#t)))))))


[-- Attachment #4: Type: text/plain, Size: 142 bytes --]

_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-devel

             reply	other threads:[~2003-11-24 22:09 UTC|newest]

Thread overview: 3+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2003-11-24 22:09 Kevin Ryde [this message]
2003-11-25 12:05 ` srfi-1 count Stephen Compall
2003-12-02 21:31   ` Kevin Ryde

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://www.gnu.org/software/guile/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=87oev1v2pd.fsf@zip.com.au \
    --to=user42@zip.com.au \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body. 
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).