diff --git a/AUTHORS b/AUTHORS index 625511e5..f020fe53 100644 --- 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 index 00000000..a22c2822 --- /dev/null +++ b/module/srfi/srfi-26.mes @@ -0,0 +1,28 @@ +;;; -*-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 . + +;;; 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 index 00000000..410d2e2f --- /dev/null +++ b/module/srfi/srfi-26.scm @@ -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)))))