From 7da67941e296642449e2ab6e9e98f1aabc16aa6e Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 14 Oct 2018 09:10:30 +0200 Subject: [PATCH] core: Add module-define! * src/module.c (module_define_x, module_printer): New function. (make_initial_module): Use them. * tests/srfi-0.test: Test it. * src/mes.c (display_m0): Remove. Update callers. * mes/module/mes/fluids.mes (make-fluid): Rewrite. * tests/macro.test: Test it. * mes/module/mes/boot-0.scm.in (module-define!): Remove. * mes/module/mes/boot-02.scm: Likewise. * module/mes/misc.scm (pk, warn): New function. * build-aux/check-mes.sh (tests): Run tests. --- build-aux/check-mes.sh | 2 + mes/module/mes/boot-0.scm.in | 4 -- mes/module/mes/boot-02.scm | 4 -- mes/module/mes/fluids.mes | 46 ++++---------- module/mes/misc.scm | 11 ++++ src/mes.c | 106 +++++++++++++++---------------- src/module.c | 120 ++++++++++++++++++++++++++++++++--- src/reader.c | 5 +- src/struct.c | 22 +++++-- src/vector.c | 24 +++++-- tests/guile.test | 13 +--- tests/macro.test | 119 ++++++++++++++++++++++++++++++++++ tests/srfi-0.test | 48 ++++++++++++++ 13 files changed, 398 insertions(+), 126 deletions(-) create mode 100755 tests/macro.test create mode 100755 tests/srfi-0.test diff --git a/build-aux/check-mes.sh b/build-aux/check-mes.sh index bb17b54b..1e735711 100755 --- a/build-aux/check-mes.sh +++ b/build-aux/check-mes.sh @@ -34,6 +34,8 @@ MES_ARENA=${MES_ARENA-100000000} tests=" tests/boot.test tests/read.test +tests/srfi-0.test +tests/macro.test tests/base.test tests/quasiquote.test tests/let.test diff --git a/mes/module/mes/boot-0.scm.in b/mes/module/mes/boot-0.scm.in index 07034a24..23af0059 100644 --- a/mes/module/mes/boot-0.scm.in +++ b/mes/module/mes/boot-0.scm.in @@ -104,10 +104,6 @@ (cons (quote or) (cdr x)))) (car x))))) -(define-macro (module-define! module name value) - ;;(list 'define name value) - #t) - (define-macro (mes-use-module module) #t) ;; end boot-02.scm diff --git a/mes/module/mes/boot-02.scm b/mes/module/mes/boot-02.scm index 0d521762..d437b09b 100644 --- a/mes/module/mes/boot-02.scm +++ b/mes/module/mes/boot-02.scm @@ -104,10 +104,6 @@ (cons (quote or) (cdr x)))) (car x))))) -(define-macro (module-define! module name value) - ;;(list 'define name value) - #t) - (define-macro (mes-use-module module) #t) diff --git a/mes/module/mes/fluids.mes b/mes/module/mes/fluids.mes index a415c247..5fe3f187 100644 --- a/mes/module/mes/fluids.mes +++ b/mes/module/mes/fluids.mes @@ -1,7 +1,7 @@ ;;; -*-scheme-*- ;;; GNU Mes --- Maxwell Equations of Software -;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of GNU Mes. ;;; @@ -24,39 +24,19 @@ (mes-use-module (mes scm)) - -(define (sexp:define e a) - (if (atom? (car (cdr e))) (cons (car (cdr e)) - (core:eval (car (cdr (cdr e))) a)) - (cons (car (car (cdr e))) - (core:eval (cons (quote lambda) - (cons (cdr (car (cdr e))) (cdr (cdr e)))) a)))) - -(define (f:env:define a+ a) - (set-cdr! a+ (cdr a)) - (set-cdr! a a+) - ;;(set-cdr! (assq '*closure* a) a+) - ) - -(define (env:escape-closure a n) - (if (eq? (caar a) '*closure*) (if (= 0 n) a - (env:escape-closure (cdr a) (- n 1))) - (env:escape-closure (cdr a) n))) - -(define-macro (module-define! name value a) - `(f:env:define (cons (sexp:define (cons 'define (cons ',name (cons ,value '()))) ,a) '()) (env:escape-closure ,a 1))) - (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)))) + ((lambda (fluid) + `(begin + (module-define! + (boot-module) + ',fluid + ((lambda (v) + (lambda ( . rest) + (if (null? rest) v + (set! v (car rest))))) + ,(and (pair? default) (car default)))) + ',fluid)) + (symbol-append 'fluid: (gensym)))) (define (fluid-ref fluid) (fluid)) diff --git a/module/mes/misc.scm b/module/mes/misc.scm index e6d15275..c3dae084 100644 --- a/module/mes/misc.scm +++ b/module/mes/misc.scm @@ -22,7 +22,9 @@ disjoin guile? mes? + pk pke + warn stderr string-substitute)) @@ -43,6 +45,13 @@ (define (stderr string . rest) (apply logf (cons* (current-error-port) string rest))) +(define (pk . stuff) + (newline) + (display ";;; ") + (write stuff) + (newline) + (car (last-pair stuff))) + (define (pke . stuff) (newline (current-error-port)) (display ";;; " (current-error-port)) @@ -50,6 +59,8 @@ (newline (current-error-port)) (car (last-pair stuff))) +(define warn pke) + (define (disjoin . predicates) (lambda (. arguments) (any (lambda (o) (apply o arguments)) predicates))) diff --git a/src/mes.c b/src/mes.c index cd259e63..97495f98 100644 --- a/src/mes.c +++ b/src/mes.c @@ -52,6 +52,8 @@ SCM r1 = 0; SCM r2 = 0; // continuation SCM r3 = 0; +// current-module +SCM m0 = 0; // macro SCM g_macros = 1; SCM g_ports = 1; @@ -662,7 +664,7 @@ check_apply (SCM f, SCM e) ///((internal)) SCM gc_push_frame () ///((internal)) { - SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil)))); + SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cons (m0, cell_nil))))); g_stack = cons (frame, g_stack); return g_stack; } @@ -897,7 +899,10 @@ push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal)) r2 = p2; gc_push_frame (); r1 = p1; - r0 = a; + // if (TYPE (a) == TPAIR) + // r0 = module_clone_locals (r0, a); + // else + r0 = a; r3 = x; return cell_unspecified; } @@ -910,6 +915,7 @@ gc_peek_frame () ///((internal)) r2 = CADR (frame); r3 = CAR (CDDR (frame)); r0 = CADR (CDDR (frame)); + m0 = CAR (CDDR (CDDR (frame))); return frame; } @@ -1017,6 +1023,9 @@ expand_variable (SCM x, SCM formals) ///((internal)) return expand_variable_ (x, formals, 1); } +SCM struct_ref_ (SCM x, long i); +SCM vector_ref_ (SCM x, long i); + SCM eval_apply () { @@ -1268,12 +1277,7 @@ eval_apply () { entry = module_variable (r0, name); if (entry == cell_f) - { - entry = cons (name, cell_f); - aa = cons (entry, cell_nil); - set_cdr_x (aa, cdr (r0)); - set_cdr_x (r0, aa); - } + module_define_x (m0, name, cell_f); } } r2 = r1; @@ -1507,6 +1511,8 @@ eval_apply () push_cc (input, r2, r0, cell_vm_return); x = read_input_file_env (r0); + if (g_debug > 3) + module_printer (m0); gc_pop_frame (); input = r1; r1 = x; @@ -1594,12 +1600,12 @@ apply (SCM f, SCM x, SCM a) ///((internal)) SCM mes_g_stack (SCM a) ///((internal)) { - r0 = a; + //r0 = a; r1 = MAKE_CHAR (0); r2 = MAKE_CHAR (0); r3 = MAKE_CHAR (0); g_stack = cons (cell_nil, cell_nil); - return r0; + return a; } // Environment setup @@ -2025,20 +2031,6 @@ g_cells[cell_vm_return].car = cstring_to_list (scm_vm_return.car); a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a); a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a); - char *compiler = "gnuc"; -#if __MESC__ - compiler = "mesc"; -#elif __TINYC__ - compiler = "tcc"; -#endif - a = acons (cell_symbol_compiler, MAKE_STRING (cstring_to_list (compiler)), a); - - char *arch = "x86"; -#if __x86_64__ - arch = "x86_64"; -#endif - a = acons (cell_symbol_arch, MAKE_STRING (cstring_to_list (arch)), a); - a = acons (cell_type_char, MAKE_NUMBER (TCHAR), a); a = acons (cell_type_closure, MAKE_NUMBER (TCLOSURE), a); a = acons (cell_type_continuation, MAKE_NUMBER (TCONTINUATION), a); @@ -2064,9 +2056,31 @@ g_cells[cell_vm_return].car = cstring_to_list (scm_vm_return.car); } SCM -mes_environment () ///((internal)) +mes_environment (int argc, char *argv[]) { SCM a = mes_symbols (); + + char *compiler = "gnuc"; +#if __MESC__ + compiler = "mesc"; +#elif __TINYC__ + compiler = "tcc"; +#endif + a = acons (cell_symbol_compiler, MAKE_STRING (cstring_to_list (compiler)), a); + + char *arch = "x86"; +#if __x86_64__ + arch = "x86_64"; +#endif + a = acons (cell_symbol_arch, MAKE_STRING (cstring_to_list (arch)), a); + +#if !MES_MINI + SCM lst = cell_nil; + for (int i=argc-1; i>=0; i--) + lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst); + a = acons (cell_symbol_argv, lst, a); +#endif + return mes_g_stack (a); } @@ -2287,9 +2301,8 @@ load_boot (char *prefix, char const *boot, char const *location) } SCM -load_env (SCM a) ///((internal)) +load_env () ///((internal)) { - r0 = a; g_stdin = -1; char prefix[1024]; char boot[1024]; @@ -2328,15 +2341,13 @@ load_env (SCM a) ///((internal)) exit (1); } - if (!g_function) - r0 = mes_builtins (r0); r2 = read_input_file_env (r0); g_stdin = STDIN; return r2; } SCM -bload_env (SCM a) ///((internal)) +bload_env () ///((internal)) { #if !_POSIX_SOURCE char *mo = "mes/boot-0.32-mo"; @@ -2376,23 +2387,11 @@ bload_env (SCM a) ///((internal)) gc_peek_frame (); g_symbols = r1; g_stdin = STDIN; + // SCM a = struct_ref (r0, 3); + // a = mes_builtins (a); + // struct_set_x (r0, 3, a); r0 = mes_builtins (r0); - char *compiler = "gnuc"; -#if __MESC__ - compiler = "mesc"; -#elif __TINYC__ - compiler = "tcc"; -#endif - - a = acons (cell_symbol_compiler, MAKE_STRING (cstring_to_list (compiler)), a); - - char *arch = "x86"; -#if __x86_64__ - arch = "x86_64"; -#endif - a = acons (cell_symbol_arch, MAKE_STRING (cstring_to_list (arch)), a); - if (g_debug > 3) { eputs ("symbols: "); @@ -2448,21 +2447,20 @@ main (int argc, char *argv[]) GC_SAFETY = atoi (p); g_stdin = STDIN; g_stdout = STDOUT; - r0 = mes_environment (); + + SCM a = mes_environment (argc, argv); + a = mes_builtins (a); + m0 = make_initial_module (a); + + if (g_debug > 3) + module_printer (m0); SCM program = (argc > 1 && !strcmp (argv[1], "--load")) - ? bload_env (r0) : load_env (r0); + ? bload_env () : load_env (); g_tiny = argc > 2 && !strcmp (argv[2], "--tiny"); if (argc > 1 && !strcmp (argv[1], "--dump")) return dump (); -#if !MES_MINI - SCM lst = cell_nil; - for (int i=argc-1; i>=0; i--) - lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst); - r0 = acons (cell_symbol_argv, lst, r0); // FIXME - r0 = acons (cell_symbol_argv, lst, r0); -#endif push_cc (r2, cell_unspecified, r0, cell_unspecified); if (g_debug > 2) diff --git a/src/module.c b/src/module.c index 6c1d3489..9f2aacbf 100644 --- a/src/module.c +++ b/src/module.c @@ -18,8 +18,14 @@ * along with GNU Mes. If not, see . */ +SCM make_vector__ (long k); +SCM struct_ref_ (SCM x, long i); +SCM struct_set_x_ (SCM x, long i, SCM e); +SCM vector_ref_ (SCM x, long i); +SCM vector_set_x_ (SCM x, long i, SCM e); + SCM -make_initial_module (SCM a) +make_initial_module (SCM a) ///((internal)) { SCM fields = cell_nil; fields = cons (cstring_to_symbol ("globals"), fields); @@ -31,17 +37,105 @@ make_initial_module (SCM a) a = acons (module_type_name, module_type, a); SCM values = cell_nil; SCM name = cons (cstring_to_symbol ("boot"), cell_nil); - SCM globals = cell_nil; - values = cons (a, values); + //SCM globals = make_vector__ (28 * 27); + SCM globals = make_vector__ (30 * 27); values = cons (globals, values); + SCM locals = cell_nil; + values = cons (locals, values); values = cons (name, values); - SCM module = make_struct (module_type_name, values, cell_unspecified); + SCM module = make_struct (module_type_name, values, cell_module_printer); + r0 = cell_nil; + r0 = cons (CAR (a), r0); + + m0 = module; + while (TYPE (a) == TPAIR) + { + if (g_debug > 3) + { + eputs ("entry="); display_error_ (CAR (a)); eputs ("\n"); + } + module_define_x (module, CAAR (a), CDAR (a)); + a = CDR (a); + } + return module; } +SCM +module_printer (SCM module) +{ + eputs ("#<"); display_error_ (struct_ref_ (module, 0)); eputc (' '); + //eputs ("printer: "); display_error_ (struct_ref_ (module, 1)); eputc (' '); + eputs ("name: "); display_error_ (struct_ref_ (module, 2)); eputc (' '); + eputs ("locals: "); display_error_ (struct_ref_ (module, 3)); eputc (' '); + eputs ("globals:\n "); + SCM v = struct_ref_ (m0, 4); + for (int i=0; i'); +} + + + +int +char_hash (int c) +{ + if (c >= 'a' && c <= 'z') + return c - 'a'; + return 27; +} + +int +module_hash (SCM x) ///((internal)) +{ + int hash = char_hash (VALUE (CAR (STRING (x)))) * 27; + if (TYPE (CDR (STRING (x))) == TPAIR) + hash = hash + char_hash (VALUE (CADR (STRING (x)))); + else + hash = hash + char_hash (0); + assert (hash <= 756); + return hash; +} + +SCM +module_variable (SCM module, SCM name) +{ + //SCM locals = struct_ref_ (module, 3); + SCM locals = module; + SCM x = assq (name, locals); + if (x == cell_f) + { + int hash = module_hash (name); + module = m0; + SCM globals = struct_ref_ (module, 4); + SCM bucket = vector_ref_ (globals, hash); + if (TYPE (bucket) == TPAIR) + x = assq (name, bucket); + } + return x; +} + SCM module_ref (SCM module, SCM name) { + if (g_debug > 4) + { + eputs ("module_ref: "); display_error_ (name); eputs ("\n"); + } SCM x = module_variable (module, name); if (x == cell_f) return cell_undefined; @@ -49,9 +143,19 @@ module_ref (SCM module, SCM name) } SCM -module_variable (SCM module, SCM name) +module_define_x (SCM module, SCM name, SCM value) { - //SCM locals = struct_ref (module, 4); - SCM locals = module; - return assq (name, locals); + if (g_debug > 4) + { + eputs ("module_define_x: "); display_error_ (name); eputs ("\n"); + } + int hash = module_hash (name); + module = m0; + SCM globals = struct_ref_ (module, 4); + SCM bucket = vector_ref_ (globals, hash); + if (TYPE (bucket) != TPAIR) + bucket = cell_nil; + bucket = acons (name, value, bucket); + vector_set_x_ (globals, hash, bucket); + return cell_t; } diff --git a/src/reader.c b/src/reader.c index ef699a7d..5f4e3bec 100644 --- a/src/reader.c +++ b/src/reader.c @@ -34,8 +34,9 @@ read_input_file_env_ (SCM e, SCM a) SCM read_input_file_env (SCM a) { - r0 = a; - return read_input_file_env_ (read_env (r0), r0); + //r0 = a; + //return read_input_file_env_ (read_env (r0), r0); + return read_input_file_env_ (read_env (cell_nil), cell_nil); } int diff --git a/src/struct.c b/src/struct.c index 75e43a46..f73013dc 100644 --- a/src/struct.c +++ b/src/struct.c @@ -47,11 +47,11 @@ struct_length (SCM x) } SCM -struct_ref (SCM x, SCM i) +struct_ref_ (SCM x, long i) { assert (TYPE (x) == TSTRUCT); - assert (VALUE (i) < LENGTH (x)); - SCM e = STRUCT (x) + VALUE (i); + assert (i < LENGTH (x)); + SCM e = STRUCT (x) + i; if (TYPE (e) == TREF) e = REF (e); if (TYPE (e) == TCHAR) @@ -62,10 +62,22 @@ struct_ref (SCM x, SCM i) } SCM -struct_set_x (SCM x, SCM i, SCM e) +struct_set_x_ (SCM x, long i, SCM e) { assert (TYPE (x) == TSTRUCT); assert (VALUE (i) < LENGTH (x)); - g_cells[STRUCT (x)+VALUE (i)] = g_cells[vector_entry (e)]; + g_cells[STRUCT (x)+i] = g_cells[vector_entry (e)]; return cell_unspecified; } + +SCM +struct_ref (SCM x, SCM i) +{ + return struct_ref_ (x, VALUE (i)); +} + +SCM +struct_set_x (SCM x, SCM i, SCM e) +{ + return struct_set_x_ (x, VALUE (i), e); +} diff --git a/src/vector.c b/src/vector.c index 0e34d93c..09517d56 100644 --- a/src/vector.c +++ b/src/vector.c @@ -42,11 +42,11 @@ vector_length (SCM x) } SCM -vector_ref (SCM x, SCM i) +vector_ref_ (SCM x, long i) { assert (TYPE (x) == TVECTOR); - assert (VALUE (i) < LENGTH (x)); - SCM e = VECTOR (x) + VALUE (i); + assert (i < LENGTH (x)); + SCM e = VECTOR (x) + i; if (TYPE (e) == TREF) e = REF (e); if (TYPE (e) == TCHAR) @@ -56,6 +56,12 @@ vector_ref (SCM x, SCM i) return e; } +SCM +vector_ref (SCM x, SCM i) +{ + return vector_ref_ (x, VALUE (i)); +} + SCM vector_entry (SCM x) { @@ -65,14 +71,20 @@ vector_entry (SCM x) } SCM -vector_set_x (SCM x, SCM i, SCM e) +vector_set_x_ (SCM x, long i, SCM e) { assert (TYPE (x) == TVECTOR); - assert (VALUE (i) < LENGTH (x)); - g_cells[VECTOR (x)+VALUE (i)] = g_cells[vector_entry (e)]; + assert (i < LENGTH (x)); + g_cells[VECTOR (x)+i] = g_cells[vector_entry (e)]; return cell_unspecified; } +SCM +vector_set_x (SCM x, SCM i, SCM e) +{ + return vector_set_x_ (x, VALUE (i), e); +} + SCM list_to_vector (SCM x) { diff --git a/tests/guile.test b/tests/guile.test index 350c523d..cb63692b 100755 --- a/tests/guile.test +++ b/tests/guile.test @@ -26,11 +26,13 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests (define-module (tests guile) #:use-module (ice-9 rdelim) #:use-module (mes mes-0) + #:use-module (mes misc) #:use-module (mes test)) (cond-expand (mes (mes-use-module (mes test)) + (mes-use-module (mes misc)) (mes-use-module (mes guile))) (else)) @@ -71,14 +73,6 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests (set-current-input-port (car ipstk)) (fluid-set! *input-stack* (cdr ipstk)))))) -;; Return #f if empty -(define (pop-input) - (let ((ipstk (fluid-ref *input-stack*))) - (if (null? ipstk) #f - (begin - (set-current-input-port (car ipstk)) - (fluid-set! *input-stack* (cdr ipstk)))))) - (pass-if-equal "push-input" "bla" (let () @@ -102,8 +96,7 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests (unless (eof-object? ch) (write-char ch) (iter (read-char)))) (pop-input) (let iter ((ch (read-char))) - (unless (eof-object? ch) (write-char ch) (iter (read-char)))) - ))))) + (unless (eof-object? ch) (write-char ch) (iter (read-char))))))))) (pass-if "input-stack/2" (let ((sp (open-input-string "abc"))) diff --git a/tests/macro.test b/tests/macro.test new file mode 100755 index 00000000..0c874215 --- /dev/null +++ b/tests/macro.test @@ -0,0 +1,119 @@ +#! /bin/sh +# -*-scheme-*- +if [ "$MES" != guile ]; then + export MES_BOOT=boot-02.scm + MES=${MES-$(dirname $0)/../src/mes} + $MES < $0 + exit $? +else + exit 0 +fi +exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests macro)' -s "$0" "$@" +!# + +;;; -*-scheme-*- + +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of GNU Mes. +;;; +;;; GNU 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. +;;; +;;; GNU 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 GNU Mes. If not, see . + +(define-module (tests boot) + #:use-module (mes mes-0) + #:use-module (mes test)) + +(cond-expand + (mes + (primitive-load "module/mes/test.scm")) + (guile-2) + (guile + (use-modules (ice-9 syncase)))) + +(pass-if "first dummy" #t) +(pass-if-not "second dummy" #f) + +(define gensym + ((lambda (symbols) + (lambda (. rest) + ((lambda (head tail) + (set! symbols tail) + head) + (car symbols) + (cdr symbols)))) + '(g0 g1 g2 g3 g4))) + +;; type-0.mes +(define (string . lst) + (core:make-cell lst 0)) + +(define (string->symbol s) + (if (not (pair? (core:car s))) '() + (list->symbol (core:car s)))) + +(define (symbol->list s) + (core:car s)) + +;; boot-0.scm +(define (symbol->string s) + (apply string (symbol->list s))) + +(define (string-append . rest) + (apply string (apply append (map1 string->list rest)))) + +;; scm.mes +(define (symbol-append . rest) + (string->symbol (apply string-append (map symbol->string rest)))) + +(define-macro (make-fluid . default) + ((lambda (fluid) + (list + 'begin + (list + 'module-define! + (list 'boot-module) + (list 'quote fluid) + (list + (lambda (v) + (lambda ( . rest) + (if (null? rest) v + (set! v (car rest))))) + (and (pair? default) (car default)))) + (list 'quote fluid))) + (symbol-append 'fluid: (gensym)))) + +(define fluid (make-fluid 42)) + +(pass-if-eq "fluid" 42 (fluid)) + +(fluid 0) +(pass-if-eq "fluid 0" 0 (fluid)) + +(fluid '()) +(pass-if-eq "fluid null" '() (fluid)) + +(define (fluid-ref fluid) + (fluid)) + +(define (fluid-set! fluid value) + (fluid value)) + +(fluid-set! fluid 0) +(pass-if-eq "fluid 0" 0 (fluid-ref fluid)) + +(fluid-set! fluid '()) +(pass-if-eq "fluid null" '() (fluid-ref fluid)) + +(result 'report) diff --git a/tests/srfi-0.test b/tests/srfi-0.test new file mode 100755 index 00000000..90c526aa --- /dev/null +++ b/tests/srfi-0.test @@ -0,0 +1,48 @@ +#! /bin/sh +# -*-scheme-*- +if [ "$MES" != guile ]; then + export MES_BOOT=boot-02.scm + MES=${MES-$(dirname $0)/../src/mes} + $MES < $0 + exit $? +fi +exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@" +!# + +;;; -*-scheme-*- + +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of GNU Mes. +;;; +;;; GNU 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. +;;; +;;; GNU 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 GNU Mes. If not, see . + +(define-module (tests srfi-0) + #:use-module (mes mes-0) + #:use-module (mes test)) + +(display "srfi-0...\n") + +(cond-expand + (mes + (display "mes\n") + (exit 0)) + (guile + (display "guile\n") + (exit guile?)) + (else + (exit 1))) + +(exit 1)