Minimal syntactic fluids support.

* module/mes/fluids.mes: New file.
* tests/fluids.test: New file.
* GNUmakefile (TESTS): Add it.

diff --git a/GNUmakefile b/GNUmakefile
index f454d0804d0e9658d616ec79b7d89be7d30691f3..82459a8c0430166838ccbc9469a1c735c38a39f4 100644 (file)
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -60,6 +60,7 @@ TESTS:=\
  tests/scm.test\
  tests/cwv.test\
  tests/optargs.test\
  tests/scm.test\
  tests/cwv.test\
  tests/optargs.test\

+ tests/fluids.test\

  tests/psyntax.test\
  tests/let-syntax.test\
  tests/record.test\
  tests/psyntax.test\
  tests/let-syntax.test\
  tests/record.test\

diff --git a/module/mes/fluids.mes b/module/mes/fluids.mes
new file mode 100644 (file)
index 0000000..4f7a1db
--- /dev/null
+++ b/module/mes/fluids.mes
@@ -0,0 +1,98 @@
+;;; -*-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:
+
+;;; Code:
+
+(mes-use-module (mes scm))
+
+(define (env:define a+ a)
+  (set-cdr! a+ (cdr a))
+  (set-cdr! a a+)
+  ;;(set-cdr! (assq '*closure* a) a+)
+  )
+
+(define (env:escape-closure a)
+  (let loop ((a a) (n 1))
+    (if (eq? (caar a) '*closure*) (if (= 0 n) a
+                                      (loop (cdr a) (- n 1)))
+        (loop (cdr a) n))))
+
+(define (sexp:define e a)
+  (if (atom? (cadr e)) (cons (cadr e) (eval-env (caddr e) a))
+      (cons (caadr e) (eval-env (cons 'lambda (cons (cdadr e) (cddr e))) a))))
+
+(define-macro (module-define! name value a)
+  `(env:define (cons (sexp:define (cons 'define (cons ',name (cons ,value '()))) ,a) '()) (env:escape-closure ,a)))
+
+(define-macro (make-fluid . default)
+  `(begin
+     ,(let ((fluid (symbol-append 'fluid: (gensym)))
+            (module (current-module)))
+        `(begin
+           (module-define! ,fluid
+                           (let ((v ,(and (pair? default) (car default))))
+                             (lambda ( . rest)
+                               (if (null? rest) v
+                                   (set! v (car rest))))) ',module)
+           ',fluid))))
+
+(define (fluid-ref fluid)
+  (fluid))
+
+(define (fluid-set! fluid value)
+  (fluid value))
+
+(define-macro (fluid? fluid)
+  `(begin
+     (and (symbol? ,fluid)
+          (symbol-prefix? 'fluid: ,fluid))))
+
+(define (with-fluid* fluid value thunk)
+  (let ((v (fluid)))
+    (fluid-set! fluid value)
+    (let ((r (thunk)))
+      (fluid-set! fluid v)
+      r)))
+
+;; (define-macro (with-fluids*-macro fluids values thunk)
+;;   `(begin
+;;      ,@(map (lambda (f v) (list 'set! f v)) fluids values)
+;;      (,thunk)))
+
+;; (define (with-fluids*-next fluids values thunk)
+;;   `(with-fluids*-macro ,fluids ,values ,thunk))
+
+;; (define (with-fluids* fluids values thunk)
+;;   (primitive-eval (with-fluids*-next fluids values thunk)))
+
+;; (define-macro (with-fluids bindings . bodies)
+;;   `(let ()
+;;     (define (expand bindings a)
+;;       (if (null? bindings)
+;;           (cons (car bindings) (expand (cdr bindings) a))))
+;;     (eval-env (begin ,@bodies) (expand ',bindings (current-module)))))
+
+(define (dynamic-wind in-guard thunk out-guard)
+  (in-guard)
+  (let ((r (thunk)))
+    (out-guard)
+    r))

diff --git a/tests/fluids.test b/tests/fluids.test
new file mode 100755 (executable)
index 0000000..42a3346
--- /dev/null
+++ b/tests/fluids.test
@@ -0,0 +1,68 @@
+#! /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/>.
+
+(mes-use-module (mes fluids))
+(mes-use-module (mes test))
+
+(define a (make-fluid))
+(define b (make-fluid))
+(define c #f)
+
+(pass-if "fluid?" (fluid? a))
+(pass-if-not "fluid? not" (fluid? c))
+(pass-if-not "fluid-ref"
+             (fluid-ref a))
+
+(pass-if "with-fluid*"
+  (with-fluid* a #t (lambda () (fluid-ref a))))
+
+(pass-if-not "with-fluid* reset"
+             (begin
+               (with-fluid* a #t (lambda () (fluid-ref a)))
+               (fluid-ref a)))
+
+;; (pass-if-equal "with fluids*"
+;;     0 (with-fluids* (list a b) '(0 1)
+;;                     (lambda () (fluid-ref a))))
+
+;; (pass-if-equal "with-fluids"
+;;     0 (with-fluids ((a 1)
+;;                     (a 2)
+;;                     (a 3))
+;;         (begin (fluid-set! a 0))
+;;         (begin (fluid-ref a))))
+
+;; (pass-if-equal "with-fluids"
+;;     #f (begin
+;;          (with-fluids ((a 1)
+;;                        (a 2)
+;;                        (a 3))
+;;            (begin (fluid-set! a 0))
+;;            (begin (display "X:") (display (fluid-ref a)) (newline)))
+;;          (fluid-ref a)))
+
+(result 'report)