Import srfi-26 from Guile.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sat, 24 Dec 2016 07:34:19 +0000 (08:34 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sat, 24 Dec 2016 07:34:19 +0000 (08:34 +0100)
* module/srfi/srfi-26.scm: Import.
* module/srfi/srfi-26.mes: Include it.
* AUTHORS: Mention it.

AUTHORS
module/srfi/srfi-26.mes [new file with mode: 0644]
module/srfi/srfi-26.scm [new file with mode: 0644]

diff --git a/AUTHORS b/AUTHORS
index 625511e554d4664ba0578cf4dddbc93b051f9f14..f020fe53ae5c2b2312e86eb7faee8b3907b35ddf 100644 (file)
--- a/AUTHORS
+++ b/AUTHORS
@@ -35,5 +35,8 @@ module/mes/pmatch.scm
 Srfi-1 bits from Guile
 module/srfi/srfi-1.scm
 
+Srfi-26 from Guile
+module/srfi/srfi-26.scm
+
 Sxml bits from Guile
 module/sxml/xpath.scm
\ No newline at end of file
diff --git a/module/srfi/srfi-26.mes b/module/srfi/srfi-26.mes
new file mode 100644 (file)
index 0000000..a22c282
--- /dev/null
@@ -0,0 +1,28 @@
+;;; -*-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/>.
+
+;;; Commentary:
+
+;;; srfi-26.mes - cut, cute
+
+(mes-use-module (mes scm))
+(mes-use-module (mes guile))
+(mes-use-module (srfi srfi-1))
+(include-from-path "srfi/srfi-26.scm")
diff --git a/module/srfi/srfi-26.scm b/module/srfi/srfi-26.scm
new file mode 100644 (file)
index 0000000..410d2e2
--- /dev/null
@@ -0,0 +1,49 @@
+;;; srfi-26.scm --- specializing parameters without currying.
+
+;; Copyright (C) 2002, 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
+
+(define-module (srfi srfi-26)
+  :export (cut cute))
+
+(cond-expand-provide (current-module) '(srfi-26))
+
+(define-macro (cut slot . slots)
+  (let loop ((slots    (cons slot slots))
+            (params    '())
+            (args      '()))
+    (if (null? slots)
+       `(lambda ,(reverse! params) ,(reverse! args))
+      (let ((s   (car slots))
+           (rest (cdr slots)))
+       (case s
+         ((<>)
+          (let ((var (gensym)))
+            (loop rest (cons var params) (cons var args))))
+         ((<...>)
+          (if (pair? rest)
+              (error "<...> not on the end of cut expression"))
+          (let ((var (gensym)))
+            `(lambda ,(append! (reverse! params) var)
+               (apply ,@(reverse! (cons var args))))))
+         (else
+          (loop rest params (cons s args))))))))
+
+(define-macro (cute . slots)
+  (let ((temp (map (lambda (s) (and (not (memq s '(<> <...>))) (gensym)))
+                  slots)))
+    `(let ,(delq! #f (map (lambda (t s) (and t (list t s))) temp slots))
+       (cut ,@(map (lambda (t s) (or t s)) temp slots)))))