Add missing srfi-1 functions for Nyacc.
authorJan Nieuwenhuizen <janneke@gnu.org>
Tue, 20 Dec 2016 09:44:43 +0000 (10:44 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Tue, 20 Dec 2016 09:44:43 +0000 (10:44 +0100)
* 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
GNUmakefile
module/srfi/srfi-1.mes
module/srfi/srfi-1.upstream.mes [new file with mode: 0644]
tests/srfi-1.test [new file with mode: 0755]

diff --git a/AUTHORS b/AUTHORS
index 5ee0030b57da0e18586d4138349f1fa0b0a060e8..200cfa5d367cd2b5c78ae46ea2708be89e830874 100644 (file)
--- a/AUTHORS
+++ b/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
index 6ef195b36bfa227c4708be15a679f3eb984730b4..d54cb278b58a70c08fe9a4ac583eeb3b482b61ff 100644 (file)
@@ -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\
index 5173bced824cd0c0000c40b3ba1badd818ee7a34..144b851c611745b6126e2b0c472ca31d270b41ff 100644 (file)
 
 (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))
diff --git a/module/srfi/srfi-1.upstream.mes b/module/srfi/srfi-1.upstream.mes
new file mode 100644 (file)
index 0000000..c51e69d
--- /dev/null
@@ -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)))))))
diff --git a/tests/srfi-1.test b/tests/srfi-1.test
new file mode 100755 (executable)
index 0000000..446c588
--- /dev/null
@@ -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)