Add missing srfi-1 functions for Nyacc.

* module/srfi/srfi-1.scm (fold, fold-right, remove, append-reverse,
  remove!): New functions.
* tests/srfi-1.test: New file.
* GNUmakefile (TESTS): Add it.
* module/srfi/srfi-1.upstream.mes: Import bits from Guile-1.8.
* AUTHORS: Mention it.

AUTHORS

@@ -25,3 +25,6 @@ module/mes/psyntax-pp.mes [generated]
 
 Optargs from Guile
 module/mes/optargs.upstream.mes
+
+Srfi-1 bits from Guile
+module/srfi/srfi-1.upstream.mes

GNUmakefile

@@ -59,6 +59,7 @@ TESTS:=\
  tests/vector.test\
  tests/scm.test\
  tests/cwv.test\
+ tests/srfi-1.test\
  tests/optargs.test\
  tests/fluids.test\
  tests/catch.test\

module/srfi/srfi-1.mes

@@ -39,3 +39,35 @@
 
 (define (append-map f lst)
   (apply append (map f lst)))
+
+;;; nyacc requirements
+
+(define (fold proc init lst1 . rest)
+  (if (null? rest)
+      (let loop ((lst lst1) (result init))
+        (if (null? lst) result
+            (loop (cdr lst) (proc (car lst) result))))
+      '*FOLD-n-NOT-SUPPORTED))
+
+(define (fold-right proc init lst1 . rest)
+  (if (null? rest)
+      (let loop ((lst lst1))
+        (if (null? lst) init
+            (proc (car lst) (loop (cdr lst)))))
+      '*FOLD-RIGHT-n-NOT-SUPPORTED))
+
+(define (remove pred lst) (filter (lambda (x) (not (pred x))) lst))
+
+(define (append-reverse rev-head tail)
+  (let loop ((rev-head rev-head) (tail tail))
+    (if (null? rev-head) tail
+	(loop (cdr rev-head) (cons (car rev-head) tail)))))
+
+(define (reverse! lst)
+  (let loop ((lst lst) (result '()))
+    (if (null? lst) result
+        (let ((tail (cdr lst)))
+          (set-cdr! lst result)
+          (loop tail lst)))))
+
+(mes-use-module (srfi srfi-1.upstream))

module/srfi/srfi-1.upstream.mes

@@ -0,0 +1,99 @@
+;;; From Guile-1.8
+
+;; 	Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 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
+
+;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+;;; Date: 2001-06-06
+
+;;; Searching
+
+;; Internal helper procedure.  Map `f' over the single list `ls'.
+;;
+(define map1 map)
+
+(define (any pred ls . lists)
+  (if (null? lists)
+      (any1 pred ls)
+      (let lp ((lists (cons ls lists)))
+	(cond ((any1 null? lists)
+	       #f)
+	      ((any1 null? (map1 cdr lists))
+	       (apply pred (map1 car lists)))
+	      (else
+	       (or (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
+
+(define (any1 pred ls)
+  (let lp ((ls ls))
+    (cond ((null? ls)
+	   #f)
+	  ((null? (cdr ls))
+	   (pred (car ls)))
+	  (else
+	   (or (pred (car ls)) (lp (cdr ls)))))))
+
+(define (every pred ls . lists)
+  (if (null? lists)
+      (every1 pred ls)
+      (let lp ((lists (cons ls lists)))
+	(cond ((any1 null? lists)
+	       #t)
+	      ((any1 null? (map1 cdr lists))
+	       (apply pred (map1 car lists)))
+	      (else
+	       (and (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
+
+(define (every1 pred ls)
+  (let lp ((ls ls))
+    (cond ((null? ls)
+	   #t)
+	  ((null? (cdr ls))
+	   (pred (car ls)))
+	  (else
+	   (and (pred (car ls)) (lp (cdr ls)))))))
+
+;;; Set operations on lists
+
+(define (lset-union = . rest)
+  (let ((acc '()))
+    (for-each (lambda (lst)
+		(if (null? acc)
+		    (set! acc lst)
+		    (for-each (lambda (elem)
+				(if (not (member elem acc
+						 (lambda (x y) (= y x))))
+				    (set! acc (cons elem acc))))
+			      lst)))
+	      rest)
+    acc))
+
+(define (lset-intersection = list1 . rest)
+  (let lp ((l list1) (acc '()))
+    (if (null? l)
+      (reverse! acc)
+      (if (every (lambda (ll) (member (car l) ll =)) rest)
+	(lp (cdr l) (cons (car l) acc))
+	(lp (cdr l) acc)))))
+
+(define (lset-difference = list1 . rest)
+  (if (null? rest)
+    list1
+    (let lp ((l list1) (acc '()))
+      (if (null? l)
+	(reverse! acc)
+	(if (any (lambda (ll) (member (car l) ll =)) rest)
+	  (lp (cdr l) acc)
+	  (lp (cdr l) (cons (car l) acc)))))))

tests/srfi-1.test

@@ -0,0 +1,51 @@
+#! /bin/sh
+# -*-scheme-*-
+echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@"
+#paredit:||
+exit $?
+!#
+
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+(cond-expand (guile (use-modules (srfi srfi-1))) (mes))
+(mes-use-module (srfi srfi-1))
+(mes-use-module (mes test))
+
+(pass-if "first dummy" #t)
+(pass-if-not "second dummy" #f)
+
+(pass-if-equal "fold"
+               '(3 2 1)
+               (fold cons '() '(1 2 3)))
+
+(pass-if-equal "fold-right"
+               '(1 2 3)
+               (fold-right cons '() '(1 2 3)))
+
+(pass-if-equal "remove"
+               '(1 3)
+               (remove even? '(1 2 3)))
+
+(pass-if-equal "append-reverse"
+               '(3 2 1 4 5 6)
+               (append-reverse '(1 2 3) '(4 5 6)))
+
+(result 'report)