diff --git a/GNUmakefile b/GNUmakefile index f454d080..82459a8c 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -60,6 +60,7 @@ TESTS:=\ tests/scm.test\ tests/cwv.test\ tests/optargs.test\ + tests/fluids.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 index 00000000..4f7a1db8 --- /dev/null +++ b/module/mes/fluids.mes @@ -0,0 +1,98 @@ +;;; -*-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: + +;;; 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 index 00000000..42a33461 --- /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 +;;; +;;; 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 . + +(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)