diff --git a/AUTHORS b/AUTHORS index 5ee0030b..200cfa5d 100644 --- 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 diff --git a/GNUmakefile b/GNUmakefile index 6ef195b3..d54cb278 100644 --- a/GNUmakefile +++ b/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\ diff --git a/module/srfi/srfi-1.mes b/module/srfi/srfi-1.mes index 5173bced..144b851c 100644 --- a/module/srfi/srfi-1.mes +++ b/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)) diff --git a/module/srfi/srfi-1.upstream.mes b/module/srfi/srfi-1.upstream.mes new file mode 100644 index 00000000..c51e69d0 --- /dev/null +++ b/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 +;;; 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 index 00000000..446c5884 --- /dev/null +++ b/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 +;;; +;;; 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 . + +(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)