Merge branch 'eval'

include/picrin.h

@@ -175,9 +175,9 @@ pic_value pic_apply3(pic_state *, struct pic_proc *, pic_value, pic_value, pic_v
 pic_value pic_apply4(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value);
 pic_value pic_apply5(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value, pic_value);
 pic_value pic_apply_trampoline(pic_state *, struct pic_proc *, pic_value);
-pic_value pic_eval(pic_state *, pic_value);
-struct pic_proc *pic_compile(pic_state *, pic_value);
-pic_value pic_macroexpand(pic_state *, pic_value);
+pic_value pic_eval(pic_state *, pic_value, struct pic_lib *);
+struct pic_proc *pic_compile(pic_state *, pic_value, struct pic_lib *);
+pic_value pic_macroexpand(pic_state *, pic_value, struct pic_lib *);
 
 void pic_in_library(pic_state *, pic_value);
 struct pic_lib *pic_make_library(pic_state *, pic_value);

piclib/CMakeLists.txt

@@ -8,6 +8,8 @@ list(APPEND PICLIB_SCHEME_LIBS
   ${PROJECT_SOURCE_DIR}/piclib/scheme/file.scm
   ${PROJECT_SOURCE_DIR}/piclib/scheme/case-lambda.scm
   ${PROJECT_SOURCE_DIR}/piclib/scheme/lazy.scm
+  ${PROJECT_SOURCE_DIR}/piclib/scheme/r5rs.scm
+  ${PROJECT_SOURCE_DIR}/piclib/scheme/null.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/8.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/26.scm

piclib/prelude.scm

@@ -1073,3 +1073,33 @@
                    (apply values args)))))))))))))
 
 (export guard)
+
+(define-library (scheme eval)
+  (import (scheme base))
+
+  (define (null-environment n)
+    (if (not (= n 5))
+        (error "unsupported environment version" n)
+        '(scheme null)))
+
+  (define (scheme-report-environment n)
+    (if (not (= n 5))
+        (error "unsupported environment version" n)
+        '(scheme r5rs)))
+
+  (define environment
+    (let ((counter 0))
+      (lambda specs
+        (let ((library-name `(picrin @@my-environment ,counter)))
+          (set! counter (+ counter 1))
+          (eval
+           `(define-library ,library-name
+              ,@(map (lambda (spec)
+                       `(import ,spec))
+                     specs))
+           '(scheme base))
+          library-name))))
+
+  (export null-environment
+          scheme-report-environment
+          environment))

piclib/scheme/file.scm

@@ -7,5 +7,19 @@
   (define (call-with-output-file filename callback)
     (call-with-port (open-output-file filename) callback))
 
+  (define (with-input-from-file filename thunk)
+    (call-with-input-file filename
+      (lambda (port)
+        (parameterize ((current-input-port port))
+          (thunk)))))
+
+  (define (with-output-to-file filename thunk)
+    (call-with-output-file filename
+      (lambda (port)
+        (parameterize ((current-output-port port))
+          (thunk)))))
+
   (export call-with-input-file
-          call-with-output-file))
+          call-with-output-file
+          with-input-from-file
+          with-output-to-file))

piclib/scheme/null.scm

@@ -0,0 +1,12 @@
+(define-library (scheme null)
+  (import (scheme base))
+  (export define
+          lambda
+          if
+          quote
+          quasiquote
+          unquote
+          unquote-splicing
+          begin
+          set!
+          define-syntax))

piclib/scheme/r5rs.scm

@@ -0,0 +1,118 @@
+(define-library (scheme r5rs)
+  (import (scheme base)
+          (scheme inexact)
+          (scheme write)
+          (scheme read)
+          (scheme file)
+          (scheme cxr)
+          (scheme lazy)
+          (scheme eval)
+          (scheme load))
+
+  (export * + - / < <= = > >=
+          abs acos and
+          ;; angle
+          append apply asin assoc assq assv atan
+          begin boolean?
+          caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr
+          call-with-current-continuation
+          call-with-input-file
+          call-with-output-file
+          call-with-values
+          car case cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr
+          ceiling
+          ;; char->integer char-alphabetic? char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase char-lower-case? char-numeric? char-ready? char-upcase char-upper-case? char-whitespace? char<=? char<? char=? char>=? char>? char?
+          close-input-port close-output-port complex? cond cons cos current-input-port current-output-port
+          define define-syntax delay
+          ;; denominator
+          display do dynamic-wind
+          eof-object? eq? equal? eqv? eval even?
+          (rename inexact exact->inexact)
+          exact? exp expt
+          floor for-each force
+          gcd
+          if
+          ;; imag-part
+          (rename exact inexact->exact)
+          inexact? input-port? integer->char integer?
+          ;; interaction-environment
+          lambda lcm length let
+          peek-char procedure?
+          quote
+          rational? read
+          ;; real-part
+          remainder round
+          scheme-report-environment
+          set! set-cdr! sqrt string->list string->symbol
+          ;; string-ci<=? string-ci=? string-ci>?
+          string-fill! string-ref string<=? string=? string>? substring symbol?
+          truncate
+          vector vector-fill! vector-ref vector? with-output-to-file write-char
+          output-port?
+          let-syntax
+          letrec-syntax
+          list->string
+          list-ref
+          list?
+          log
+          ;; make-polar
+          make-string
+          map
+          member
+          memv
+          modulo
+          newline
+          null-environment
+          number->string
+          ;; numerator
+          open-input-file
+          or
+          pair?
+          positive?
+          quasiquote
+          quotient
+          ;; rationalize
+          read-char
+          real?
+          reverse
+          let*
+          letrec
+          list
+          list->vector
+          list-tail
+          load
+          ;; magnitude
+          ;; make-rectangular
+          make-vector
+          max
+          memq
+          min
+          negative?
+          not
+          null?
+          number?
+          odd?
+          open-output-file
+          set-car!
+          sin
+          string
+          string->number
+          string-append
+          ;; string-ci<?
+          ;; string-ci>=?
+          string-copy
+          string-length
+          string-set!
+          string<?
+          string>=?
+          string?
+          symbol->string
+          tan
+          values
+          vector->list
+          vector-length
+          vector-set!
+          with-input-from-file
+          write
+          zero?
+          ))

src/codegen.c

@@ -1442,7 +1442,7 @@ pic_codegen(pic_state *pic, pic_value obj)
 }
 
 struct pic_proc *
-pic_compile(pic_state *pic, pic_value obj)
+pic_compile(pic_state *pic, pic_value obj, struct pic_lib *lib)
 {
   struct pic_irep *irep;
   size_t ai = pic_gc_arena_preserve(pic);
@@ -1458,7 +1458,7 @@ pic_compile(pic_state *pic, pic_value obj)
 #endif
 
   /* macroexpand */
-  obj = pic_macroexpand(pic, obj);
+  obj = pic_macroexpand(pic, obj, lib);
 #if DEBUG
   fprintf(stdout, "## macroexpand completed\n");
   pic_debug(pic, obj);

src/eval.c

@@ -0,0 +1,39 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#include "picrin.h"
+#include "picrin/macro.h"
+
+pic_value
+pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib)
+{
+  struct pic_proc *proc;
+
+  proc = pic_compile(pic, program, lib);
+
+  return pic_apply(pic, proc, pic_nil_value());
+}
+
+static pic_value
+pic_eval_eval(pic_state *pic)
+{
+  pic_value program, spec;
+  struct pic_lib *lib;
+
+  pic_get_args(pic, "oo", &program, &spec);
+
+  lib = pic_find_library(pic, spec);
+  if (lib == NULL) {
+    pic_errorf(pic, "no library found: ~s", spec);
+  }
+  return pic_eval(pic, program, lib);
+}
+
+void
+pic_init_eval(pic_state *pic)
+{
+  pic_deflibrary ("(scheme eval)") {
+    pic_defun(pic, "eval", pic_eval_eval);
+  }
+}

src/init.c

@@ -31,6 +31,7 @@ void pic_init_load(pic_state *);
 void pic_init_write(pic_state *);
 void pic_init_read(pic_state *);
 void pic_init_dict(pic_state *);
+void pic_init_eval(pic_state *);
 void pic_init_contrib(pic_state *);
 
 void pic_load_piclib(pic_state *);
@@ -92,6 +93,7 @@ pic_init_core(pic_state *pic)
     pic_init_write(pic); DONE;
     pic_init_read(pic); DONE;
     pic_init_dict(pic); DONE;
+    pic_init_eval(pic); DONE;
 
     pic_load_piclib(pic); DONE;
 

src/load.c

@@ -20,7 +20,7 @@ pic_load_cstr(pic_state *pic, const char *src)
   pic_for_each (v, exprs) {
     ai = pic_gc_arena_preserve(pic);
 
-    proc = pic_compile(pic, v);
+    proc = pic_compile(pic, v, pic->lib);
     if (proc == NULL) {
       pic_error(pic, "load: compilation failure");
     }
@@ -54,7 +54,7 @@ pic_load(pic_state *pic, const char *fn)
   pic_for_each (v, exprs) {
     ai = pic_gc_arena_preserve(pic);
 
-    proc = pic_compile(pic, v);
+    proc = pic_compile(pic, v, pic->lib);
     if (proc == NULL) {
       pic_error(pic, "load: compilation failure");
     }

src/macro.c

@@ -168,7 +168,7 @@ macroexpand_deflibrary(pic_state *pic, pic_value expr)
     pic_in_library(pic, pic_cadr(pic, expr));
 
     pic_for_each (v, pic_cddr(pic, expr)) {
-      pic_void(pic_eval(pic, v));
+      pic_void(pic_eval(pic, v, pic->lib));
     }
 
     pic_in_library(pic, prev->name);
@@ -293,7 +293,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
   val = pic_cadr(pic, pic_cdr(pic, expr));
 
   pic_try {
-    val = pic_eval(pic, val);
+    val = pic_eval(pic, val, pic->lib);
   } pic_catch {
     pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic));
   }
@@ -413,8 +413,9 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
 }
 
 pic_value
-pic_macroexpand(pic_state *pic, pic_value expr)
+pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib)
 {
+  struct pic_lib *prev;
   pic_value v;
 
 #if DEBUG
@@ -423,7 +424,13 @@ pic_macroexpand(pic_state *pic, pic_value expr)
   puts("");
 #endif
 
-  v = macroexpand(pic, expr, pic->lib->env);
+  /* change library for macro-expansion time processing */
+  prev = pic->lib;
+  pic->lib = lib;
+
+  v = macroexpand(pic, expr, lib->env);
+
+  pic->lib = prev;
 
 #if DEBUG
   puts("after expand:");
@@ -560,7 +567,7 @@ pic_macro_macroexpand(pic_state *pic)
 
   pic_get_args(pic, "o", &expr);
 
-  return pic_macroexpand(pic, expr);
+  return pic_macroexpand(pic, expr, pic->lib);
 }
 
 static pic_value

src/vm.c

@@ -1061,13 +1061,3 @@ pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args)
   ci->retc = pic_length(pic, args);
   return pic_obj_value(proc);
 }
-
-pic_value
-pic_eval(pic_state *pic, pic_value program)
-{
-  struct pic_proc *proc;
-
-  proc = pic_compile(pic, program);
-
-  return pic_apply(pic, proc, pic_nil_value());
-}

t/r7rs-tests.scm

@@ -34,7 +34,7 @@
         (scheme file)
         (scheme read)
         (scheme write)
-;        (scheme eval)
+        (scheme eval)
         (scheme process-context)
         (scheme case-lambda)
         (picrin test))
@@ -1766,18 +1766,18 @@
 
 (test-begin "6.12 Environments and evaluation")
 
-;; (test 21 (eval '(* 7 3) (scheme-report-environment 5)))
+(test 21 (eval '(* 7 3) (scheme-report-environment 5)))
 
-;; (test 20
-;;     (let ((f (eval '(lambda (f x) (f x x)) (null-environment 5))))
-;;       (f + 10)))
+(test 20
+    (let ((f (eval '(lambda (f x) (f x x)) (null-environment 5))))
+      (f + 10)))
 
-;; (test 1024 (eval '(expt 2 10) (environment '(scheme base))))
-;; ;; (sin 0) may return exact number
-;; (test 0.0 (inexact (eval '(sin 0) (environment '(scheme inexact)))))
-;; ;; ditto
-;; (test 1024.0 (eval '(+ (expt 2 10) (inexact (sin 0)))
-;;                    (environment '(scheme base) '(scheme inexact))))
+(test 1024 (eval '(expt 2 10) (environment '(scheme base))))
+;; (sin 0) may return exact number
+(test 0.0 (inexact (eval '(sin 0) (environment '(scheme inexact)))))
+;; ditto
+(test 1024.0 (eval '(+ (expt 2 10) (inexact (sin 0)))
+                   (environment '(scheme base) '(scheme inexact))))
 
 (test-end)
 

tools/main.c

@@ -134,7 +134,7 @@ repl(pic_state *pic)
         pic_for_each (v, exprs) {
 
           /* eval */
-          v = pic_eval(pic, v);
+          v = pic_eval(pic, v, pic->lib);
 
           /* print */
           pic_printf(pic, "=> ~s\n", v);
@@ -185,7 +185,7 @@ exec_file(pic_state *pic, const char *fname)
 
   pic_for_each (v, exprs) {
 
-    proc = pic_compile(pic, v);
+    proc = pic_compile(pic, v, pic->lib);
     if (proc == NULL) {
       fputs(pic_errmsg(pic), stderr);
       fprintf(stderr, "fatal error: %s compilation failure\n", fname);
@@ -223,7 +223,7 @@ exec_string(pic_state *pic, const char *str)
   ai = pic_gc_arena_preserve(pic);
   pic_for_each (v, exprs) {
 
-    proc = pic_compile(pic, v);
+    proc = pic_compile(pic, v, pic->lib);
     if (proc == NULL) {
       goto abort;
     }