diff --git a/include/picrin.h b/include/picrin.h index 29640fa7..ae6f66ef 100644 --- a/include/picrin.h +++ b/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); diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt index 9d81aae3..9e87e251 100644 --- a/piclib/CMakeLists.txt +++ b/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 diff --git a/piclib/prelude.scm b/piclib/prelude.scm index feef5c0c..e42b5ca3 100644 --- a/piclib/prelude.scm +++ b/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)) diff --git a/piclib/scheme/file.scm b/piclib/scheme/file.scm index 75c8bdd9..b449e49d 100644 --- a/piclib/scheme/file.scm +++ b/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)) diff --git a/piclib/scheme/null.scm b/piclib/scheme/null.scm new file mode 100644 index 00000000..a949473e --- /dev/null +++ b/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)) diff --git a/piclib/scheme/r5rs.scm b/piclib/scheme/r5rs.scm new file mode 100644 index 00000000..e26a999d --- /dev/null +++ b/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-downcase char-lower-case? char-numeric? char-ready? char-upcase char-upper-case? char-whitespace? 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-copy + string-length + string-set! + string=? + string? + symbol->string + tan + values + vector->list + vector-length + vector-set! + with-input-from-file + write + zero? + )) diff --git a/src/codegen.c b/src/codegen.c index 8f8d9aed..1dc7e898 100644 --- a/src/codegen.c +++ b/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); diff --git a/src/eval.c b/src/eval.c new file mode 100644 index 00000000..24807115 --- /dev/null +++ b/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); + } +} diff --git a/src/init.c b/src/init.c index 3bb10991..2a694704 100644 --- a/src/init.c +++ b/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; diff --git a/src/load.c b/src/load.c index f4b4db73..269fc657 100644 --- a/src/load.c +++ b/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"); } diff --git a/src/macro.c b/src/macro.c index 875e7d3f..40167238 100644 --- a/src/macro.c +++ b/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 diff --git a/src/vm.c b/src/vm.c index 2ab80a1e..1a48b16a 100644 --- a/src/vm.c +++ b/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()); -} diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 869fbc42..a9757218 100644 --- a/t/r7rs-tests.scm +++ b/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) diff --git a/tools/main.c b/tools/main.c index 5e43f2b7..9771df6e 100644 --- a/tools/main.c +++ b/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; }