Implement load.

* mes.c (symbol_primitive_load): New symbol.
  (builtin_eval): Use it to implement primitive-load.
* module/mes/base-0.mes (push!, pop!): New macro.
  (load): New macro.
* tests/data/load.scm: New file.
* tests/base.test (load): New test.

diff --git a/mes.c b/mes.c
index a0f5a751b304f6b687a2ee4e9183b1d9926fcc14..00a42150a7990d4ec10a435ac0c14bb1d681cc25 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -112,7 +112,7 @@ scm symbol_unsyntax_splicing = {SYMBOL, "unsyntax-splicing"};
 
 scm symbol_call_with_values = {SYMBOL, "call-with-values"};
 scm symbol_current_module = {SYMBOL, "current-module"};
-
+scm symbol_primitive_load = {SYMBOL, "primitive-load"};
 
 scm char_nul = {CHAR, .name="nul", .value=0};
 scm char_backspace = {CHAR, .name="backspace", .value=8};
@@ -437,6 +437,8 @@ builtin_eval (scm *e, scm *a)
         return define_env (e, a);
       if (e->car == &symbol_define_macro)
         return define_env (e, a);
+      if (e->car == &symbol_primitive_load)
+        return load_env (a);
 #else
       if (e->car == &symbol_define) {
         fprintf (stderr, "C DEFINE: ");

diff --git a/module/mes/base-0.mes b/module/mes/base-0.mes
index 6eac6843d32161977a580462f61c3ab6a299f676..55e496b3f0a9541a0c0031e67df5d7a9f1e0c7ca 100644 (file)
--- a/module/mes/base-0.mes
+++ b/module/mes/base-0.mes
@@ -35,7 +35,9 @@
 (define-macro (defined? x)
   (list 'assq x '(cddr (current-module))))
 
-(define (current-input-port) 0)
+(if (defined? 'current-input-port) #t
+    (define (current-input-port) 0))
+
 (define (current-output-port) 1)
 (define (current-error-port) 2)
 (define (port-filename port) "<stdin>")
@@ -83,3 +85,20 @@
 
 (define-macro (let bindings . rest)
   (cons 'simple-let (cons bindings rest)))
+
+(define *input-ports* '())
+(define-macro (push! stack o)
+  `(begin
+     (set! ,stack (cons ,o ,stack))
+     ,stack))
+(define-macro (pop! stack)
+  `(let ((o (car ,stack)))
+     (set! ,stack (cdr ,stack))
+     o))
+(define-macro (load file)
+  `(primitive-eval
+    (begin
+      (push! *input-ports* (current-input-port))
+      (set-current-input-port (open-input-file ,file))
+      (primitive-load)
+      (set-current-input-port (pop! *input-ports*)))))

diff --git a/tests/base.test b/tests/base.test
index b9d2ffe5f4962fe275dcda960f7915a183e4a2d2..8243b9c20561586746fe205274e469fa603a0045 100755 (executable)
--- a/tests/base.test
+++ b/tests/base.test
@@ -70,4 +70,11 @@ exit $?
 (pass-if "apply 2" (sequal? (apply list 1 '(2)) '(1 2)))
 (pass-if "apply 3" (sequal? (apply list 1 2 '(3)) '(1 2 3)))
 
+(begin
+  (define local-answer 41))
+(pass-if-equal "begin 2" 41 (begin local-answer))
+
+(if (not guile?)
+  (pass-if-equal "load" 42 (begin (load "tests/data/load.scm") the-answer)))
+
 (result 'report)

diff --git a/tests/data/load.scm b/tests/data/load.scm
new file mode 100644 (file)
index 0000000..9cd19d2
--- /dev/null
+++ b/tests/data/load.scm
@@ -0,0 +1,21 @@
+;;; -*-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/>.
+
+(define the-answer 42)