From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 6 Jan 2017 19:52:17 +0000 (-0800)
Subject: Implement non-empty-list?.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~207
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=620b9b028ec322e4a51ae9e92f2322b69d2d22de;p=mit-scheme.git

Implement non-empty-list?.
---

diff --git a/src/runtime/list.scm b/src/runtime/list.scm
index cee530d59..7fa192d84 100644
--- a/src/runtime/list.scm
+++ b/src/runtime/list.scm
@@ -174,6 +174,10 @@ USA.
 		  #f)))
 	#f)))
 
+(define (non-empty-list? object)
+  (and (pair? object)
+       (list? (cdr object))))
+
 (define-guarantee pair "pair")
 (define-guarantee list "list")
 (define-guarantee dotted-list "improper list")
diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index 7db9532fb..b68a421d4 100644
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -264,6 +264,7 @@ USA.
    (register-predicate! keyword-list? 'keyword-list '<= list?)
    (register-predicate! list-of-unique-symbols? 'list-of-unique-symbols
 			'<= list?)
+   (register-predicate! non-empty-list? 'non-empty-list '<= (list list? pair?))
    (register-predicate! unique-keyword-list? 'unique-keyword-list
 			'<= keyword-list?)
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index ef1e73820..cd23dfe0c 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2738,6 +2738,7 @@ USA.
 	  memq
 	  memv
 	  ninth
+	  non-empty-list?
 	  not-pair?			;SRFI-1
 	  null-list?			;SRFI-1
 	  null?