From 490c97cd814476224bbcce974dae8c7df7d56870 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Jun 2015 00:03:52 +0900 Subject: [PATCH 1/7] add library-name and current-library --- extlib/benz/lib.c | 34 ++++++++++++++++++++++++++++++++++ piclib/picrin/base.scm | 2 ++ 2 files changed, 36 insertions(+) diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index cc1eb503..893cc36e 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -336,6 +336,38 @@ pic_lib_find_library(pic_state *pic) return pic_obj_value(lib); } +static pic_value +pic_lib_current_library(pic_state *pic) +{ + pic_value lib; + size_t n; + + n = pic_get_args(pic, "|o", &lib); + + if (n == 0) { + return pic_obj_value(pic->lib); + } + else { + pic_assert_type(pic, lib, lib); + + pic->lib = pic_lib_ptr(lib); + + return pic_undef_value(); + } +} + +static pic_value +pic_lib_library_name(pic_state *pic) +{ + pic_value lib; + + pic_get_args(pic, "o", &lib); + + pic_assert_type(pic, lib, lib); + + return pic_lib_ptr(lib)->name; +} + static pic_value pic_lib_library_exports(pic_state *pic) { @@ -378,6 +410,8 @@ pic_init_lib(pic_state *pic) pic_defun(pic, "make-library", pic_lib_make_library); pic_defun(pic, "find-library", pic_lib_find_library); + pic_defun(pic, "current-library", pic_lib_current_library); + pic_defun(pic, "library-name", pic_lib_library_name); pic_defun(pic, "library-exports", pic_lib_library_exports); pic_defun(pic, "library-environment", pic_lib_library_environment); } diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm index edbac8c1..224043fb 100644 --- a/piclib/picrin/base.scm +++ b/piclib/picrin/base.scm @@ -254,6 +254,8 @@ (export make-library find-library + current-library + library-name library-exports library-environment) From 62b7c1a0f95ead14752b8278a7b9d4f6b75e9875 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Jun 2015 00:11:02 +0900 Subject: [PATCH 2/7] warn macro redefinition only when transformer object slot is being overwritten --- extlib/benz/codegen.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 371b0ee8..8052873f 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -51,6 +51,9 @@ resolve(pic_state *pic, pic_value var, struct pic_env *env) static void define_macro(pic_state *pic, pic_sym *uid, struct pic_proc *mac) { + if (pic_dict_has(pic, pic->macros, uid)) { + pic_warnf(pic, "redefining syntax variable: ~s", pic_obj_value(uid)); + } pic_dict_set(pic, pic->macros, uid, pic_obj_value(mac)); } @@ -209,8 +212,6 @@ expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) } if ((uid = pic_find_variable(pic, env, var)) == NULL) { uid = pic_add_variable(pic, env, var); - } else { - pic_warnf(pic, "redefining syntax variable: ~s", var); } val = pic_cadr(pic, pic_cdr(pic, expr)); From 63d3510de8210643483196ddd5d16adfae5a0ffc Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Jun 2015 00:13:00 +0900 Subject: [PATCH 3/7] move features procedure defun to state.c benz --- contrib/05.r7rs/scheme/base.scm | 4 +++- extlib/benz/state.c | 10 ++++++++++ piclib/picrin/base.scm | 4 +++- src/main.c | 12 ------------ 4 files changed, 16 insertions(+), 14 deletions(-) diff --git a/contrib/05.r7rs/scheme/base.scm b/contrib/05.r7rs/scheme/base.scm index 08d438c0..927643aa 100644 --- a/contrib/05.r7rs/scheme/base.scm +++ b/contrib/05.r7rs/scheme/base.scm @@ -518,4 +518,6 @@ write-string write-u8 write-bytevector - flush-output-port)) + flush-output-port) + + (export features)) diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 65c0bcf5..39b506ce 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -91,6 +91,14 @@ pic_init_features(pic_state *pic) #endif } +static pic_value +pic_features(pic_state *pic) +{ + pic_get_args(pic, ""); + + return pic->features; +} + #define DONE pic_gc_arena_restore(pic, ai); static void @@ -111,6 +119,8 @@ pic_init_core(pic_state *pic) pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->uBEGIN); pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_MACRO, pic->uDEFINE_MACRO); + pic_defun(pic, "features", pic_features); + pic_init_undef(pic); DONE; pic_init_bool(pic); DONE; pic_init_pair(pic); DONE; diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm index 224043fb..a9d6d7fa 100644 --- a/piclib/picrin/base.scm +++ b/piclib/picrin/base.scm @@ -286,4 +286,6 @@ write-shared display) - (export eval)) + (export eval) + + (export features)) diff --git a/src/main.c b/src/main.c index fbdae10c..a4a330ef 100644 --- a/src/main.c +++ b/src/main.c @@ -7,14 +7,6 @@ void pic_init_contrib(pic_state *); void pic_load_piclib(pic_state *); -static pic_value -pic_features(pic_state *pic) -{ - pic_get_args(pic, ""); - - return pic->features; -} - static pic_value pic_libraries(pic_state *pic) { @@ -38,10 +30,6 @@ pic_init_picrin(pic_state *pic) pic_defun(pic, "libraries", pic_libraries); } - pic_deflibrary (pic, "(scheme base)") { - pic_defun(pic, "features", pic_features); - } - pic_init_contrib(pic); pic_load_piclib(pic); } From fa1c61963352be46eefb46831098f862f5d7936f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Jun 2015 00:14:12 +0900 Subject: [PATCH 4/7] define define-library and cond-expand in scheme --- extlib/benz/boot.c | 1319 +++++++++++++++++++++++--------------------- extlib/benz/lib.c | 96 ---- 2 files changed, 683 insertions(+), 732 deletions(-) diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index c2c895ad..2bb39ea8 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -8,454 +8,492 @@ use strict; my $src = <<'EOL'; -(define-library (picrin base) +(define-macro call-with-current-environment + (lambda (form env) + (list (cadr form) env))) - (define-macro call-with-current-environment - (lambda (form env) - (list (cadr form) env))) +(define here + (call-with-current-environment + (lambda (env) + env))) - (define here - (call-with-current-environment - (lambda (env) - env))) +(define (the var) ; synonym for #'var + (make-identifier var here)) - (define (the var) ; synonym for #'var - (make-identifier var here)) +(define the-define (the 'define)) +(define the-lambda (the 'lambda)) +(define the-begin (the 'begin)) +(define the-quote (the 'quote)) +(define the-set! (the 'set!)) +(define the-if (the 'if)) +(define the-define-macro (the 'define-macro)) - (define the-define (the 'define)) - (define the-lambda (the 'lambda)) - (define the-begin (the 'begin)) - (define the-quote (the 'quote)) - (define the-set! (the 'set!)) - (define the-if (the 'if)) - (define the-define-macro (the 'define-macro)) +(define-macro syntax-error + (lambda (form _) + (apply error (cdr form)))) - (define-macro syntax-error - (lambda (form _) - (apply error (cdr form)))) +(define-macro define-auxiliary-syntax + (lambda (form _) + (define message + (string-append + "invalid use of auxiliary syntax: '" (symbol->string (cadr form)) "'")) + (list + the-define-macro + (cadr form) + (list the-lambda '_ + (list (the 'error) message))))) - (define-macro define-auxiliary-syntax - (lambda (form _) - (define message - (string-append - "invalid use of auxiliary syntax: '" (symbol->string (cadr form)) "'")) - (list - the-define-macro - (cadr form) - (list the-lambda '_ - (list (the 'error) message))))) +(define-auxiliary-syntax else) +(define-auxiliary-syntax =>) +(define-auxiliary-syntax unquote) +(define-auxiliary-syntax unquote-splicing) +(define-auxiliary-syntax syntax-unquote) +(define-auxiliary-syntax syntax-unquote-splicing) - (define-auxiliary-syntax else) - (define-auxiliary-syntax =>) - (define-auxiliary-syntax unquote) - (define-auxiliary-syntax unquote-splicing) - (define-auxiliary-syntax syntax-unquote) - (define-auxiliary-syntax syntax-unquote-splicing) +(define-macro let + (lambda (form env) + (if (variable? (cadr form)) + (list + (list the-lambda '() + (list the-define (cadr form) + (cons the-lambda + (cons (map car (car (cddr form))) + (cdr (cddr form))))) + (cons (cadr form) (map cadr (car (cddr form)))))) + (cons + (cons + the-lambda + (cons (map car (cadr form)) + (cddr form))) + (map cadr (cadr form)))))) - (define-macro let - (lambda (form env) - (if (variable? (cadr form)) - (list - (list the-lambda '() - (list the-define (cadr form) - (cons the-lambda - (cons (map car (car (cddr form))) - (cdr (cddr form))))) - (cons (cadr form) (map cadr (car (cddr form)))))) - (cons - (cons - the-lambda - (cons (map car (cadr form)) - (cddr form))) - (map cadr (cadr form)))))) +(define-macro and + (lambda (form env) + (if (null? (cdr form)) + #t + (if (null? (cddr form)) + (cadr form) + (list the-if + (cadr form) + (cons (the 'and) (cddr form)) + #f))))) - (define-macro and - (lambda (form env) - (if (null? (cdr form)) - #t - (if (null? (cddr form)) - (cadr form) - (list the-if - (cadr form) - (cons (the 'and) (cddr form)) - #f))))) +(define-macro or + (lambda (form env) + (if (null? (cdr form)) + #f + (let ((tmp (make-identifier 'it env))) + (list (the 'let) + (list (list tmp (cadr form))) + (list the-if + tmp + tmp + (cons (the 'or) (cddr form)))))))) - (define-macro or - (lambda (form env) - (if (null? (cdr form)) - #f - (let ((tmp (make-identifier 'it env))) - (list (the 'let) - (list (list tmp (cadr form))) - (list the-if - tmp - tmp - (cons (the 'or) (cddr form)))))))) +(define-macro cond + (lambda (form env) + (let ((clauses (cdr form))) + (if (null? clauses) + #undefined + (let ((clause (car clauses))) + (if (and (variable? (car clause)) + (variable=? (the 'else) (make-identifier (car clause) env))) + (cons the-begin (cdr clause)) + (if (and (variable? (cadr clause)) + (variable=? (the '=>) (make-identifier (cadr clause) env))) + (let ((tmp (make-identifier 'tmp here))) + (list (the 'let) (list (list tmp (car clause))) + (list the-if tmp + (list (car (cddr clause)) tmp) + (cons (the 'cond) (cdr clauses))))) + (list the-if (car clause) + (cons the-begin (cdr clause)) + (cons (the 'cond) (cdr clauses)))))))))) - (define-macro cond - (lambda (form env) - (let ((clauses (cdr form))) +(define-macro quasiquote + (lambda (form env) + + (define (quasiquote? form) + (and (pair? form) + (variable? (car form)) + (variable=? (the 'quasiquote) (make-identifier (car form) env)))) + + (define (unquote? form) + (and (pair? form) + (variable? (car form)) + (variable=? (the 'unquote) (make-identifier (car form) env)))) + + (define (unquote-splicing? form) + (and (pair? form) + (pair? (car form)) + (variable? (caar form)) + (variable=? (the 'unquote-splicing) (make-identifier (caar form) env)))) + + (define (qq depth expr) + (cond + ;; unquote + ((unquote? expr) + (if (= depth 1) + (car (cdr expr)) + (list (the 'list) + (list (the 'quote) (the 'unquote)) + (qq (- depth 1) (car (cdr expr)))))) + ;; unquote-splicing + ((unquote-splicing? expr) + (if (= depth 1) + (list (the 'append) + (car (cdr (car expr))) + (qq depth (cdr expr))) + (list (the 'cons) + (list (the 'list) + (list (the 'quote) (the 'unquote-splicing)) + (qq (- depth 1) (car (cdr (car expr))))) + (qq depth (cdr expr))))) + ;; quasiquote + ((quasiquote? expr) + (list (the 'list) + (list (the 'quote) (the 'quasiquote)) + (qq (+ depth 1) (car (cdr expr))))) + ;; list + ((pair? expr) + (list (the 'cons) + (qq depth (car expr)) + (qq depth (cdr expr)))) + ;; vector + ((vector? expr) + (list (the 'list->vector) (qq depth (vector->list expr)))) + ;; simple datum + (else + (list (the 'quote) expr)))) + + (let ((x (cadr form))) + (qq 1 x)))) + +(define-macro let* + (lambda (form env) + (let ((bindings (car (cdr form))) + (body (cdr (cdr form)))) + (if (null? bindings) + `(,(the 'let) () ,@body) + `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings)))) + (,(the 'let*) (,@(cdr bindings)) + ,@body)))))) + +(define-macro letrec + (lambda (form env) + `(,(the 'letrec*) ,@(cdr form)))) + +(define-macro letrec* + (lambda (form env) + (let ((bindings (car (cdr form))) + (body (cdr (cdr form)))) + (let ((variables (map (lambda (v) `(,v #f)) (map car bindings))) + (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings))) + `(,(the 'let) (,@variables) + ,@initials + ,@body))))) + +(define-macro let-values + (lambda (form env) + `(,(the 'let*-values) ,@(cdr form)))) + +(define-macro let*-values + (lambda (form env) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + (if (null? formal) + `(,(the 'let) () ,@body) + `(,(the 'call-with-values) (,the-lambda () ,@(cdr (car formal))) + (,(the 'lambda) (,@(car (car formal))) + (,(the 'let*-values) (,@(cdr formal)) + ,@body))))))) + +(define-macro define-values + (lambda (form env) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + (let ((arguments (make-identifier 'arguments here))) + `(,the-begin + ,@(let loop ((formal formal)) + (if (pair? formal) + `((,the-define ,(car formal) #undefined) ,@(loop (cdr formal))) + (if (variable? formal) + `((,the-define ,formal #undefined)) + '()))) + (,(the 'call-with-values) (,the-lambda () ,@body) + (,the-lambda + ,arguments + ,@(let loop ((formal formal) (args arguments)) + (if (pair? formal) + `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args))) + (if (variable? formal) + `((,the-set! ,formal ,args)) + '())))))))))) + +(define-macro do + (lambda (form env) + (let ((bindings (car (cdr form))) + (test (car (car (cdr (cdr form))))) + (cleanup (cdr (car (cdr (cdr form))))) + (body (cdr (cdr (cdr form))))) + (let ((loop (make-identifier 'loop here))) + `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings) + (,the-if ,test + (,the-begin + ,@cleanup) + (,the-begin + ,@body + (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car x) (car (cdr (cdr x))))) bindings))))))))) + +(define-macro when + (lambda (form env) + (let ((test (car (cdr form))) + (body (cdr (cdr form)))) + `(,the-if ,test + (,the-begin ,@body) + #undefined)))) + +(define-macro unless + (lambda (form env) + (let ((test (car (cdr form))) + (body (cdr (cdr form)))) + `(,the-if ,test + #undefined + (,the-begin ,@body))))) + +(define-macro case + (lambda (form env) + (let ((key (car (cdr form))) + (clauses (cdr (cdr form)))) + (let ((the-key (make-identifier 'key here))) + `(,(the 'let) ((,the-key ,key)) + ,(let loop ((clauses clauses)) + (if (null? clauses) + #undefined + (let ((clause (car clauses))) + `(,the-if ,(if (and (variable? (car clause)) + (variable=? (the 'else) (make-identifier (car clause) env))) + #t + `(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause)))) + ,(if (and (variable? (cadr clause)) + (variable=? (the '=>) (make-identifier (cadr clause) env))) + `(,(car (cdr (cdr clause))) ,the-key) + `(,the-begin ,@(cdr clause))) + ,(loop (cdr clauses))))))))))) + +(define-macro parameterize + (lambda (form env) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + `(,(the 'with-parameter) + (,(the 'lambda) () + ,@formal + ,@body))))) + +(define-macro syntax-quote + (lambda (form env) + (let ((renames '())) + (letrec + ((rename (lambda (var) + (let ((x (assq var renames))) + (if x + (cadr x) + (begin + (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames)) + (rename var)))))) + (walk (lambda (f form) + (cond + ((variable? form) + (f form)) + ((pair? form) + `(,(the 'cons) (walk f (car form)) (walk f (cdr form)))) + ((vector? form) + `(,(the 'list->vector) (walk f (vector->list form)))) + (else + `(,(the 'quote) ,form)))))) + (let ((form (walk rename (cadr form)))) + `(,(the 'let) + ,(map cdr renames) + ,form)))))) + +(define-macro syntax-quasiquote + (lambda (form env) + (let ((renames '())) + (letrec + ((rename (lambda (var) + (let ((x (assq var renames))) + (if x + (cadr x) + (begin + (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames)) + (rename var))))))) + + (define (syntax-quasiquote? form) + (and (pair? form) + (variable? (car form)) + (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env)))) + + (define (syntax-unquote? form) + (and (pair? form) + (variable? (car form)) + (variable=? (the 'syntax-unquote) (make-identifier (car form) env)))) + + (define (syntax-unquote-splicing? form) + (and (pair? form) + (pair? (car form)) + (variable? (caar form)) + (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env)))) + + (define (qq depth expr) + (cond + ;; syntax-unquote + ((syntax-unquote? expr) + (if (= depth 1) + (car (cdr expr)) + (list (the 'list) + (list (the 'quote) (the 'syntax-unquote)) + (qq (- depth 1) (car (cdr expr)))))) + ;; syntax-unquote-splicing + ((syntax-unquote-splicing? expr) + (if (= depth 1) + (list (the 'append) + (car (cdr (car expr))) + (qq depth (cdr expr))) + (list (the 'cons) + (list (the 'list) + (list (the 'quote) (the 'syntax-unquote-splicing)) + (qq (- depth 1) (car (cdr (car expr))))) + (qq depth (cdr expr))))) + ;; syntax-quasiquote + ((syntax-quasiquote? expr) + (list (the 'list) + (list (the 'quote) (the 'quasiquote)) + (qq (+ depth 1) (car (cdr expr))))) + ;; list + ((pair? expr) + (list (the 'cons) + (qq depth (car expr)) + (qq depth (cdr expr)))) + ;; vector + ((vector? expr) + (list (the 'list->vector) (qq depth (vector->list expr)))) + ;; variable + ((variable? expr) + (rename expr)) + ;; simple datum + (else + (list (the 'quote) expr)))) + + (let ((body (qq 1 (cadr form)))) + `(,(the 'let) + ,(map cdr renames) + ,body)))))) + +(define (transformer f) + (lambda (form env) + (let ((register1 (make-register)) + (register2 (make-register))) + (letrec + ((wrap (lambda (var1) + (let ((var2 (register1 var1))) + (if (undefined? var2) + (let ((var2 (make-identifier var1 env))) + (register1 var1 var2) + (register2 var2 var1) + var2) + var2)))) + (unwrap (lambda (var2) + (let ((var1 (register2 var2))) + (if (undefined? var1) + var2 + var1)))) + (walk (lambda (f form) + (cond + ((variable? form) + (f form)) + ((pair? form) + (cons (walk f (car form)) (walk f (cdr form)))) + ((vector? form) + (list->vector (walk f (vector->list form)))) + (else + form))))) + (let ((form (cdr form))) + (walk unwrap (apply f (walk wrap form)))))))) + +(define-macro define-syntax + (lambda (form env) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + (if (pair? formal) + `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body)) + `(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body))))))) + +(define-macro letrec-syntax + (lambda (form env) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + `(let () + ,@(map (lambda (x) + `(,(the 'define-syntax) ,(car x) ,(cadr x))) + formal) + ,@body)))) + +(define-macro let-syntax + (lambda (form env) + `(,(the 'letrec-syntax) ,@(cdr form)))) + +(export let let* letrec letrec* + let-values let*-values define-values + quasiquote unquote unquote-splicing + and or + cond case else => + do when unless + parameterize + define-syntax + syntax-quote syntax-unquote + syntax-quasiquote syntax-unquote-splicing + let-syntax letrec-syntax + syntax-error) + +(define-macro define-library + (lambda (form _) + (let ((name (cadr form)) + (body (cddr form))) + (let ((old-library (current-library)) + (new-library (or (find-library name) (make-library name)))) + (let ((env (library-environment new-library))) + (current-library new-library) + (for-each (lambda (expr) (eval expr env)) body) + (current-library old-library)))))) + +(define-macro cond-expand + (lambda (form _) + (letrec + ((test (lambda (form) + (or + (eq? form 'else) + (and (symbol? form) + (memq form (features))) + (and (pair? form) + (case (car form) + ((library) (find-library (cadr form))) + ((not) (not (test (cadr form)))) + ((and) (let loop ((form (cdr form))) + (or (null? form) + (and (test (car form)) (loop (cdr form)))))) + ((or) (let loop ((form (cdr form))) + (and (pair? form) + (or (test (car form)) (loop (cdr form)))))) + (else #f))))))) + (let loop ((clauses (cdr form))) (if (null? clauses) #undefined - (let ((clause (car clauses))) - (if (and (variable? (car clause)) - (variable=? (the 'else) (make-identifier (car clause) env))) - (cons the-begin (cdr clause)) - (if (and (variable? (cadr clause)) - (variable=? (the '=>) (make-identifier (cadr clause) env))) - (let ((tmp (make-identifier 'tmp here))) - (list (the 'let) (list (list tmp (car clause))) - (list the-if tmp - (list (car (cddr clause)) tmp) - (cons (the 'cond) (cdr clauses))))) - (list the-if (car clause) - (cons the-begin (cdr clause)) - (cons (the 'cond) (cdr clauses)))))))))) + (if (test (caar clauses)) + `(,the-begin ,@(cdar clauses)) + (loop (cdr clauses)))))))) - (define-macro quasiquote - (lambda (form env) - - (define (quasiquote? form) - (and (pair? form) - (variable? (car form)) - (variable=? (the 'quasiquote) (make-identifier (car form) env)))) - - (define (unquote? form) - (and (pair? form) - (variable? (car form)) - (variable=? (the 'unquote) (make-identifier (car form) env)))) - - (define (unquote-splicing? form) - (and (pair? form) - (pair? (car form)) - (variable? (caar form)) - (variable=? (the 'unquote-splicing) (make-identifier (caar form) env)))) - - (define (qq depth expr) - (cond - ;; unquote - ((unquote? expr) - (if (= depth 1) - (car (cdr expr)) - (list (the 'list) - (list (the 'quote) (the 'unquote)) - (qq (- depth 1) (car (cdr expr)))))) - ;; unquote-splicing - ((unquote-splicing? expr) - (if (= depth 1) - (list (the 'append) - (car (cdr (car expr))) - (qq depth (cdr expr))) - (list (the 'cons) - (list (the 'list) - (list (the 'quote) (the 'unquote-splicing)) - (qq (- depth 1) (car (cdr (car expr))))) - (qq depth (cdr expr))))) - ;; quasiquote - ((quasiquote? expr) - (list (the 'list) - (list (the 'quote) (the 'quasiquote)) - (qq (+ depth 1) (car (cdr expr))))) - ;; list - ((pair? expr) - (list (the 'cons) - (qq depth (car expr)) - (qq depth (cdr expr)))) - ;; vector - ((vector? expr) - (list (the 'list->vector) (qq depth (vector->list expr)))) - ;; simple datum - (else - (list (the 'quote) expr)))) - - (let ((x (cadr form))) - (qq 1 x)))) - - (define-macro let* - (lambda (form env) - (let ((bindings (car (cdr form))) - (body (cdr (cdr form)))) - (if (null? bindings) - `(,(the 'let) () ,@body) - `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings)))) - (,(the 'let*) (,@(cdr bindings)) - ,@body)))))) - - (define-macro letrec - (lambda (form env) - `(,(the 'letrec*) ,@(cdr form)))) - - (define-macro letrec* - (lambda (form env) - (let ((bindings (car (cdr form))) - (body (cdr (cdr form)))) - (let ((variables (map (lambda (v) `(,v #f)) (map car bindings))) - (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings))) - `(,(the 'let) (,@variables) - ,@initials - ,@body))))) - - (define-macro let-values - (lambda (form env) - `(,(the 'let*-values) ,@(cdr form)))) - - (define-macro let*-values - (lambda (form env) - (let ((formal (car (cdr form))) - (body (cdr (cdr form)))) - (if (null? formal) - `(,(the 'let) () ,@body) - `(,(the 'call-with-values) (,the-lambda () ,@(cdr (car formal))) - (,(the 'lambda) (,@(car (car formal))) - (,(the 'let*-values) (,@(cdr formal)) - ,@body))))))) - - (define-macro define-values - (lambda (form env) - (let ((formal (car (cdr form))) - (body (cdr (cdr form)))) - (let ((arguments (make-identifier 'arguments here))) - `(,the-begin - ,@(let loop ((formal formal)) - (if (pair? formal) - `((,the-define ,(car formal) #undefined) ,@(loop (cdr formal))) - (if (variable? formal) - `((,the-define ,formal #undefined)) - '()))) - (,(the 'call-with-values) (,the-lambda () ,@body) - (,the-lambda - ,arguments - ,@(let loop ((formal formal) (args arguments)) - (if (pair? formal) - `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args))) - (if (variable? formal) - `((,the-set! ,formal ,args)) - '())))))))))) - - (define-macro do - (lambda (form env) - (let ((bindings (car (cdr form))) - (test (car (car (cdr (cdr form))))) - (cleanup (cdr (car (cdr (cdr form))))) - (body (cdr (cdr (cdr form))))) - (let ((loop (make-identifier 'loop here))) - `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings) - (,the-if ,test - (,the-begin - ,@cleanup) - (,the-begin - ,@body - (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car x) (car (cdr (cdr x))))) bindings))))))))) - - (define-macro when - (lambda (form env) - (let ((test (car (cdr form))) - (body (cdr (cdr form)))) - `(,the-if ,test - (,the-begin ,@body) - #undefined)))) - - (define-macro unless - (lambda (form env) - (let ((test (car (cdr form))) - (body (cdr (cdr form)))) - `(,the-if ,test - #undefined - (,the-begin ,@body))))) - - (define-macro case - (lambda (form env) - (let ((key (car (cdr form))) - (clauses (cdr (cdr form)))) - (let ((the-key (make-identifier 'key here))) - `(,(the 'let) ((,the-key ,key)) - ,(let loop ((clauses clauses)) - (if (null? clauses) - #undefined - (let ((clause (car clauses))) - `(,the-if ,(if (and (variable? (car clause)) - (variable=? (the 'else) (make-identifier (car clause) env))) - #t - `(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause)))) - ,(if (and (variable? (cadr clause)) - (variable=? (the '=>) (make-identifier (cadr clause) env))) - `(,(car (cdr (cdr clause))) ,the-key) - `(,the-begin ,@(cdr clause))) - ,(loop (cdr clauses))))))))))) - - (define-macro parameterize - (lambda (form env) - (let ((formal (car (cdr form))) - (body (cdr (cdr form)))) - `(,(the 'with-parameter) - (,(the 'lambda) () - ,@formal - ,@body))))) - - (define-macro syntax-quote - (lambda (form env) - (let ((renames '())) - (letrec - ((rename (lambda (var) - (let ((x (assq var renames))) - (if x - (cadr x) - (begin - (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames)) - (rename var)))))) - (walk (lambda (f form) - (cond - ((variable? form) - (f form)) - ((pair? form) - `(,(the 'cons) (walk f (car form)) (walk f (cdr form)))) - ((vector? form) - `(,(the 'list->vector) (walk f (vector->list form)))) - (else - `(,(the 'quote) ,form)))))) - (let ((form (walk rename (cadr form)))) - `(,(the 'let) - ,(map cdr renames) - ,form)))))) - - (define-macro syntax-quasiquote - (lambda (form env) - (let ((renames '())) - (letrec - ((rename (lambda (var) - (let ((x (assq var renames))) - (if x - (cadr x) - (begin - (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames)) - (rename var))))))) - - (define (syntax-quasiquote? form) - (and (pair? form) - (variable? (car form)) - (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env)))) - - (define (syntax-unquote? form) - (and (pair? form) - (variable? (car form)) - (variable=? (the 'syntax-unquote) (make-identifier (car form) env)))) - - (define (syntax-unquote-splicing? form) - (and (pair? form) - (pair? (car form)) - (variable? (caar form)) - (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env)))) - - (define (qq depth expr) - (cond - ;; syntax-unquote - ((syntax-unquote? expr) - (if (= depth 1) - (car (cdr expr)) - (list (the 'list) - (list (the 'quote) (the 'syntax-unquote)) - (qq (- depth 1) (car (cdr expr)))))) - ;; syntax-unquote-splicing - ((syntax-unquote-splicing? expr) - (if (= depth 1) - (list (the 'append) - (car (cdr (car expr))) - (qq depth (cdr expr))) - (list (the 'cons) - (list (the 'list) - (list (the 'quote) (the 'syntax-unquote-splicing)) - (qq (- depth 1) (car (cdr (car expr))))) - (qq depth (cdr expr))))) - ;; syntax-quasiquote - ((syntax-quasiquote? expr) - (list (the 'list) - (list (the 'quote) (the 'quasiquote)) - (qq (+ depth 1) (car (cdr expr))))) - ;; list - ((pair? expr) - (list (the 'cons) - (qq depth (car expr)) - (qq depth (cdr expr)))) - ;; vector - ((vector? expr) - (list (the 'list->vector) (qq depth (vector->list expr)))) - ;; variable - ((variable? expr) - (rename expr)) - ;; simple datum - (else - (list (the 'quote) expr)))) - - (let ((body (qq 1 (cadr form)))) - `(,(the 'let) - ,(map cdr renames) - ,body)))))) - - (define (transformer f) - (lambda (form env) - (let ((register1 (make-register)) - (register2 (make-register))) - (letrec - ((wrap (lambda (var1) - (let ((var2 (register1 var1))) - (if (undefined? var2) - (let ((var2 (make-identifier var1 env))) - (register1 var1 var2) - (register2 var2 var1) - var2) - var2)))) - (unwrap (lambda (var2) - (let ((var1 (register2 var2))) - (if (undefined? var1) - var2 - var1)))) - (walk (lambda (f form) - (cond - ((variable? form) - (f form)) - ((pair? form) - (cons (walk f (car form)) (walk f (cdr form)))) - ((vector? form) - (list->vector (walk f (vector->list form)))) - (else - form))))) - (let ((form (cdr form))) - (walk unwrap (apply f (walk wrap form)))))))) - - (define-macro define-syntax - (lambda (form env) - (let ((formal (car (cdr form))) - (body (cdr (cdr form)))) - (if (pair? formal) - `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body)) - `(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body))))))) - - (define-macro letrec-syntax - (lambda (form env) - (let ((formal (car (cdr form))) - (body (cdr (cdr form)))) - `(let () - ,@(map (lambda (x) - `(,(the 'define-syntax) ,(car x) ,(cadr x))) - formal) - ,@body)))) - - (define-macro let-syntax - (lambda (form env) - `(,(the 'letrec-syntax) ,@(cdr form)))) - - (export let let* letrec letrec* - let-values let*-values define-values - quasiquote unquote unquote-splicing - and or - cond case else => - do when unless - parameterize - define-syntax - syntax-quote syntax-unquote - syntax-quasiquote syntax-unquote-splicing - let-syntax letrec-syntax - syntax-error)) +(export define-library + cond-expand) EOL @@ -509,209 +547,218 @@ EOL #endif const char pic_boot[][80] = { -"\n(define-library (picrin base)\n\n (define-macro call-with-current-environment\n ", -" (lambda (form env)\n (list (cadr form) env)))\n\n (define here\n (call-wi", -"th-current-environment\n (lambda (env)\n env)))\n\n (define (the var) ", -" ; synonym for #'var\n (make-identifier var here))\n\n (define ", -"the-define (the 'define))\n (define the-lambda (the 'lambda))\n (define the-begi", -"n (the 'begin))\n (define the-quote (the 'quote))\n (define the-set! (the 'set!)", -")\n (define the-if (the 'if))\n (define the-define-macro (the 'define-macro))\n\n ", -" (define-macro syntax-error\n (lambda (form _)\n (apply error (cdr form)))", -")\n\n (define-macro define-auxiliary-syntax\n (lambda (form _)\n (define me", -"ssage\n (string-append\n \"invalid use of auxiliary syntax: '\" (symb", -"ol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (cadr f", -"orm)\n (list the-lambda '_\n (list (the 'error) message)))))\n\n ", -"(define-auxiliary-syntax else)\n (define-auxiliary-syntax =>)\n (define-auxiliar", -"y-syntax unquote)\n (define-auxiliary-syntax unquote-splicing)\n (define-auxilia", -"ry-syntax syntax-unquote)\n (define-auxiliary-syntax syntax-unquote-splicing)\n\n ", -" (define-macro let\n (lambda (form env)\n (if (variable? (cadr form))\n ", -" (list\n (list the-lambda '()\n (list the-define (c", -"adr form)\n (cons the-lambda\n (", -"cons (map car (car (cddr form)))\n (cdr (cddr f", -"orm)))))\n (cons (cadr form) (map cadr (car (cddr form))))))\n ", -" (cons\n (cons\n the-lambda\n (cons (map car (", -"cadr form))\n (cddr form)))\n (map cadr (cadr form)))))", -")\n\n (define-macro and\n (lambda (form env)\n (if (null? (cdr form))\n ", -" #t\n (if (null? (cddr form))\n (cadr form)\n ", -" (list the-if\n (cadr form)\n (cons (the 'a", -"nd) (cddr form))\n #f)))))\n\n (define-macro or\n (lambda (fo", -"rm env)\n (if (null? (cdr form))\n #f\n (let ((tmp (make-ide", -"ntifier 'it env)))\n (list (the 'let)\n (list (list tm", -"p (cadr form)))\n (list the-if\n tmp\n ", -" tmp\n (cons (the 'or) (cddr form)))))))", -")\n\n (define-macro cond\n (lambda (form env)\n (let ((clauses (cdr form)))", -"\n (if (null? clauses)\n #undefined\n (let ((clause (c", -"ar clauses)))\n (if (and (variable? (car clause))\n ", +"\n(define-macro call-with-current-environment\n (lambda (form env)\n (list (cad", +"r form) env)))\n\n(define here\n (call-with-current-environment\n (lambda (env)\n ", +" env)))\n\n(define (the var) ; synonym for #'var\n (make-id", +"entifier var here))\n\n(define the-define (the 'define))\n(define the-lambda (the '", +"lambda))\n(define the-begin (the 'begin))\n(define the-quote (the 'quote))\n(define", +" the-set! (the 'set!))\n(define the-if (the 'if))\n(define the-define-macro (the '", +"define-macro))\n\n(define-macro syntax-error\n (lambda (form _)\n (apply error (", +"cdr form))))\n\n(define-macro define-auxiliary-syntax\n (lambda (form _)\n (defi", +"ne message\n (string-append\n \"invalid use of auxiliary syntax: '\" (sym", +"bol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (cadr form)\n", +" (list the-lambda '_\n (list (the 'error) message)))))\n\n(define-aux", +"iliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-auxiliary-syntax unquot", +"e)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxiliary-syntax syntax-un", +"quote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(define-macro let\n (l", +"ambda (form env)\n (if (variable? (cadr form))\n (list\n (list th", +"e-lambda '()\n (list the-define (cadr form)\n (c", +"ons the-lambda\n (cons (map car (car (cddr form)))\n ", +" (cdr (cddr form)))))\n (cons (cadr for", +"m) (map cadr (car (cddr form))))))\n (cons\n (cons\n the-la", +"mbda\n (cons (map car (cadr form))\n (cddr form)))\n ", +" (map cadr (cadr form))))))\n\n(define-macro and\n (lambda (form env)\n (if (nu", +"ll? (cdr form))\n #t\n (if (null? (cddr form))\n (cadr for", +"m)\n (list the-if\n (cadr form)\n (con", +"s (the 'and) (cddr form))\n #f)))))\n\n(define-macro or\n (lambda ", +"(form env)\n (if (null? (cdr form))\n #f\n (let ((tmp (make-identi", +"fier 'it env)))\n (list (the 'let)\n (list (list tmp (cadr", +" form)))\n (list the-if\n tmp\n ", +" tmp\n (cons (the 'or) (cddr form))))))))\n\n(define-macr", +"o cond\n (lambda (form env)\n (let ((clauses (cdr form)))\n (if (null? cla", +"uses)\n #undefined\n (let ((clause (car clauses)))\n (", +"if (and (variable? (car clause))\n (variable=? (the 'else) (m", +"ake-identifier (car clause) env)))\n (cons the-begin (cdr clause))", +"\n (if (and (variable? (cadr clause))\n (va", +"riable=? (the '=>) (make-identifier (cadr clause) env)))\n (le", +"t ((tmp (make-identifier 'tmp here)))\n (list (the 'let) (li", +"st (list tmp (car clause)))\n (list the-if tmp\n ", +" (list (car (cddr clause)) tmp)\n ", +" (cons (the 'cond) (cdr clauses)))))\n (list the-if", +" (car clause)\n (cons the-begin (cdr clause))\n ", +" (cons (the 'cond) (cdr clauses))))))))))\n\n(define-macro quasiquo", +"te\n (lambda (form env)\n\n (define (quasiquote? form)\n (and (pair? form)\n", +" (variable? (car form))\n (variable=? (the 'quasiquote) (make", +"-identifier (car form) env))))\n\n (define (unquote? form)\n (and (pair? fo", +"rm)\n (variable? (car form))\n (variable=? (the 'unquote) (mak", +"e-identifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and", +" (pair? form)\n (pair? (car form))\n (variable? (caar form))\n ", +" (variable=? (the 'unquote-splicing) (make-identifier (caar form) env))", +"))\n\n (define (qq depth expr)\n (cond\n ;; unquote\n ((unquote? ", +"expr)\n (if (= depth 1)\n (car (cdr expr))\n (list (th", +"e 'list)\n (list (the 'quote) (the 'unquote))\n ", +"(qq (- depth 1) (car (cdr expr))))))\n ;; unquote-splicing\n ((unquote", +"-splicing? expr)\n (if (= depth 1)\n (list (the 'append)\n ", +" (car (cdr (car expr)))\n (qq depth (cdr expr)))\n ", +" (list (the 'cons)\n (list (the 'list)\n ", +" (list (the 'quote) (the 'unquote-splicing))\n (qq (- ", +"depth 1) (car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ", +" ;; quasiquote\n ((quasiquote? expr)\n (list (the 'list)\n ", +" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) (car (c", +"dr expr)))))\n ;; list\n ((pair? expr)\n (list (the 'cons)\n ", +" (qq depth (car expr))\n (qq depth (cdr expr))))\n ;; v", +"ector\n ((vector? expr)\n (list (the 'list->vector) (qq depth (vector", +"->list expr))))\n ;; simple datum\n (else\n (list (the 'quote) e", +"xpr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(define-macro let*\n (lam", +"bda (form env)\n (let ((bindings (car (cdr form)))\n (body (cdr (c", +"dr form))))\n (if (null? bindings)\n `(,(the 'let) () ,@body)\n ", +" `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n (", +",(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n(define-macro letrec\n", +" (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n\n(define-macro letrec", +"*\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ", +" (cdr (cdr form))))\n (let ((variables (map (lambda (v) `(,v #f)) (map car b", +"indings)))\n (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings", +")))\n `(,(the 'let) (,@variables)\n ,@initials\n ,@body)))", +"))\n\n(define-macro let-values\n (lambda (form env)\n `(,(the 'let*-values) ,@(c", +"dr form))))\n\n(define-macro let*-values\n (lambda (form env)\n (let ((formal (c", +"ar (cdr form)))\n (body (cdr (cdr form))))\n (if (null? formal)\n ", +" `(,(the 'let) () ,@body)\n `(,(the 'call-with-values) (,the-lamb", +"da () ,@(cdr (car formal)))\n (,(the 'lambda) (,@(car (car formal)))\n ", +" (,(the 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n(", +"define-macro define-values\n (lambda (form env)\n (let ((formal (car (cdr form", +")))\n (body (cdr (cdr form))))\n (let ((arguments (make-identifier", +" 'arguments here)))\n `(,the-begin\n ,@(let loop ((formal formal))", +"\n (if (pair? formal)\n `((,the-define ,(car formal)", +" #undefined) ,@(loop (cdr formal)))\n (if (variable? formal)\n ", +" `((,the-define ,formal #undefined))\n '()", +")))\n (,(the 'call-with-values) (,the-lambda () ,@body)\n (,the", +"-lambda\n ,arguments\n ,@(let loop ((formal formal) (args ar", +"guments))\n (if (pair? formal)\n `((,the-set! ,(", +"car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))\n ", +" (if (variable? formal)\n `((,the-set! ,fo", +"rmal ,args))\n '()))))))))))\n\n(define-macro do\n (lambda (", +"form env)\n (let ((bindings (car (cdr form)))\n (test (car (car (c", +"dr (cdr form)))))\n (cleanup (cdr (car (cdr (cdr form)))))\n (b", +"ody (cdr (cdr (cdr form)))))\n (let ((loop (make-identifier 'loop here))", +")\n `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings)", +"\n (,the-if ,test\n (,the-begin\n ,@c", +"leanup)\n (,the-begin\n ,@body\n ", +" (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car x) (car (cdr (cdr", +" x))))) bindings)))))))))\n\n(define-macro when\n (lambda (form env)\n (let ((te", +"st (car (cdr form)))\n (body (cdr (cdr form))))\n `(,the-if ,test\n ", +" (,the-begin ,@body)\n #undefined))))\n\n(define-macro ", +"unless\n (lambda (form env)\n (let ((test (car (cdr form)))\n (body (c", +"dr (cdr form))))\n `(,the-if ,test\n #undefined\n ", +" (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (form env)\n (let ((ke", +"y (car (cdr form)))\n (clauses (cdr (cdr form))))\n (let ((the-k", +"ey (make-identifier 'key here)))\n `(,(the 'let) ((,the-key ,key))\n ", +" ,(let loop ((clauses clauses))\n (if (null? clauses)\n ", +" #undefined\n (let ((clause (car clauses)))\n ", +" `(,the-if ,(if (and (variable? (car clause))\n ", " (variable=? (the 'else) (make-identifier (car clause) env)))\n ", -" (cons the-begin (cdr clause))\n (if (and (variable? (cadr cl", -"ause))\n (variable=? (the '=>) (make-identifier (cadr c", -"lause) env)))\n (let ((tmp (make-identifier 'tmp here)))\n ", -" (list (the 'let) (list (list tmp (car clause)))\n ", -" (list the-if tmp\n (list (c", -"ar (cddr clause)) tmp)\n (cons (the 'cond) (cd", -"r clauses)))))\n (list the-if (car clause)\n ", -" (cons the-begin (cdr clause))\n (cons (the ", -"'cond) (cdr clauses))))))))))\n\n (define-macro quasiquote\n (lambda (form env)", -"\n\n (define (quasiquote? form)\n (and (pair? form)\n (varia", -"ble? (car form))\n (variable=? (the 'quasiquote) (make-identifier (ca", -"r form) env))))\n\n (define (unquote? form)\n (and (pair? form)\n ", -" (variable? (car form))\n (variable=? (the 'unquote) (make-ident", -"ifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and (p", -"air? form)\n (pair? (car form))\n (variable? (caar form))\n", -" (variable=? (the 'unquote-splicing) (make-identifier (caar form) en", -"v))))\n\n (define (qq depth expr)\n (cond\n ;; unquote\n ", -"((unquote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ", -" (list (the 'list)\n (list (the 'quote) (the 'unquote))", -"\n (qq (- depth 1) (car (cdr expr))))))\n ;; unquote-sp", -"licing\n ((unquote-splicing? expr)\n (if (= depth 1)\n ", -" (list (the 'append)\n (car (cdr (car expr)))\n ", -" (qq depth (cdr expr)))\n (list (the 'cons)\n ", -"(list (the 'list)\n (list (the 'quote) (the 'unquote-spl", -"icing))\n (qq (- depth 1) (car (cdr (car expr)))))\n ", -" (qq depth (cdr expr)))))\n ;; quasiquote\n ((quasiq", -"uote? expr)\n (list (the 'list)\n (list (the 'quote) (the ", -"'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))))\n ;; li", -"st\n ((pair? expr)\n (list (the 'cons)\n (qq depth ", -"(car expr))\n (qq depth (cdr expr))))\n ;; vector\n ", -"((vector? expr)\n (list (the 'list->vector) (qq depth (vector->list expr", -"))))\n ;; simple datum\n (else\n (list (the 'quote) expr))", -"))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n (define-macro let*\n (", -"lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ", -"(cdr (cdr form))))\n (if (null? bindings)\n `(,(the 'let) () ,@b", -"ody)\n `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n", -" (,(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n (d", -"efine-macro letrec\n (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form)))", -")\n\n (define-macro letrec*\n (lambda (form env)\n (let ((bindings (car (cd", -"r form)))\n (body (cdr (cdr form))))\n (let ((variables (map", -" (lambda (v) `(,v #f)) (map car bindings)))\n (initials (map (lambd", -"a (v) `(,(the 'set!) ,@v)) bindings)))\n `(,(the 'let) (,@variables)\n ", -" ,@initials\n ,@body)))))\n\n (define-macro let-values\n (lam", -"bda (form env)\n `(,(the 'let*-values) ,@(cdr form))))\n\n (define-macro let*", -"-values\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", -" (body (cdr (cdr form))))\n (if (null? formal)\n `(,(the 'let)", -" () ,@body)\n `(,(the 'call-with-values) (,the-lambda () ,@(cdr (car f", -"ormal)))\n (,(the 'lambda) (,@(car (car formal)))\n (,(", -"the 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n (define-macr", -"o define-values\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", -" (body (cdr (cdr form))))\n (let ((arguments (make-identifier 'a", -"rguments here)))\n `(,the-begin\n ,@(let loop ((formal formal)", -")\n (if (pair? formal)\n `((,the-define ,(car fo", -"rmal) #undefined) ,@(loop (cdr formal)))\n (if (variable? form", -"al)\n `((,the-define ,formal #undefined))\n ", -" '())))\n (,(the 'call-with-values) (,the-lambda () ,@body)\n ", -" (,the-lambda\n ,arguments\n ,@(let loop ((form", -"al formal) (args arguments))\n (if (pair? formal)\n ", -" `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,", -"(the 'cdr) ,args)))\n (if (variable? formal)\n ", -" `((,the-set! ,formal ,args))\n '()))))))))))\n", -"\n (define-macro do\n (lambda (form env)\n (let ((bindings (car (cdr form)", -"))\n (test (car (car (cdr (cdr form)))))\n (cleanup (cd", -"r (car (cdr (cdr form)))))\n (body (cdr (cdr (cdr form)))))\n ", -" (let ((loop (make-identifier 'loop here)))\n `(,(the 'let) ,loop ,(map", -" (lambda (x) `(,(car x) ,(cadr x))) bindings)\n (,the-if ,test\n ", -" (,the-begin\n ,@cleanup)\n (,the-begin\n ", -" ,@body\n (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car ", -"x) (car (cdr (cdr x))))) bindings)))))))))\n\n (define-macro when\n (lambda (fo", -"rm env)\n (let ((test (car (cdr form)))\n (body (cdr (cdr form))))", -"\n `(,the-if ,test\n (,the-begin ,@body)\n ", -" #undefined))))\n\n (define-macro unless\n (lambda (form env)\n (let ((test", -" (car (cdr form)))\n (body (cdr (cdr form))))\n `(,the-if ,test\n", -" #undefined\n (,the-begin ,@body)))))\n\n (defin", -"e-macro case\n (lambda (form env)\n (let ((key (car (cdr form)))\n ", -" (clauses (cdr (cdr form))))\n (let ((the-key (make-identifier 'key ", -"here)))\n `(,(the 'let) ((,the-key ,key))\n ,(let loop ((claus", -"es clauses))\n (if (null? clauses)\n #undefined\n ", -" (let ((clause (car clauses)))\n `(,the-if ,(", -"if (and (variable? (car clause))\n (varia", -"ble=? (the 'else) (make-identifier (car clause) env)))\n ", -" #t\n `(,(the 'or) ,@(map (lambda (x", -") `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ", -" ,(if (and (variable? (cadr clause))\n ", -" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ", -" `(,(car (cdr (cdr clause))) ,the-key)\n ", -" `(,the-begin ,@(cdr clause)))\n ,", -"(loop (cdr clauses)))))))))))\n\n (define-macro parameterize\n (lambda (form en", -"v)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n", -" `(,(the 'with-parameter)\n (,(the 'lambda) ()\n ,@forma", -"l\n ,@body)))))\n\n (define-macro syntax-quote\n (lambda (form env)\n ", -" (let ((renames '()))\n (letrec\n ((rename (lambda (var)\n ", -" (let ((x (assq var renames)))\n (if x\n", -" (cadr x)\n (begin\n ", -" (set! renames `((,var ,(make-identifier var env) (,(the", -" 'make-identifier) ',var ',env)) . ,renames))\n (re", -"name var))))))\n (walk (lambda (f form)\n (cond\n ", -" ((variable? form)\n (f form))\n ", -" ((pair? form)\n `(,(the 'cons) (walk f (car fo", -"rm)) (walk f (cdr form))))\n ((vector? form)\n ", -" `(,(the 'list->vector) (walk f (vector->list form))))\n ", -" (else\n `(,(the 'quote) ,form))))))\n (let ((fo", -"rm (walk rename (cadr form))))\n `(,(the 'let)\n ,(map cdr", -" renames)\n ,form))))))\n\n (define-macro syntax-quasiquote\n (lamb", -"da (form env)\n (let ((renames '()))\n (letrec\n ((rename (l", -"ambda (var)\n (let ((x (assq var renames)))\n ", -" (if x\n (cadr x)\n ", -" (begin\n (set! renames `((,var ,(make-identifier", -" var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ", -" (rename var)))))))\n\n (define (syntax-quasiquote? form)\n ", -" (and (pair? form)\n (variable? (car form))\n ", -" (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env))))\n\n ", -" (define (syntax-unquote? form)\n (and (pair? form)\n ", -" (variable? (car form))\n (variable=? (the 'syntax-unquote) ", -"(make-identifier (car form) env))))\n\n (define (syntax-unquote-splicing?", -" form)\n (and (pair? form)\n (pair? (car form))\n ", -" (variable? (caar form))\n (variable=? (the 'syntax-unqu", -"ote-splicing) (make-identifier (caar form) env))))\n\n (define (qq depth ", -"expr)\n (cond\n ;; syntax-unquote\n ((syntax-unq", -"uote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ", -" (list (the 'list)\n (list (the 'quote) (the", -" 'syntax-unquote))\n (qq (- depth 1) (car (cdr expr))))))\n", -" ;; syntax-unquote-splicing\n ((syntax-unquote-splicing? ", -"expr)\n (if (= depth 1)\n (list (the 'append)\n ", -" (car (cdr (car expr)))\n (qq depth (cdr ", -"expr)))\n (list (the 'cons)\n (list (the '", -"list)\n (list (the 'quote) (the 'syntax-unquote-spli", -"cing))\n (qq (- depth 1) (car (cdr (car expr)))))\n ", -" (qq depth (cdr expr)))))\n ;; syntax-quasiquote", -"\n ((syntax-quasiquote? expr)\n (list (the 'list)\n ", -" (list (the 'quote) (the 'quasiquote))\n (qq (+ de", -"pth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n ", -" (list (the 'cons)\n (qq depth (car expr))\n ", -" (qq depth (cdr expr))))\n ;; vector\n ((vector? e", -"xpr)\n (list (the 'list->vector) (qq depth (vector->list expr))))\n ", -" ;; variable\n ((variable? expr)\n (rename expr", -"))\n ;; simple datum\n (else\n (list (the 'quo", -"te) expr))))\n\n (let ((body (qq 1 (cadr form))))\n `(,(the 'le", -"t)\n ,(map cdr renames)\n ,body))))))\n\n (define (transf", -"ormer f)\n (lambda (form env)\n (let ((register1 (make-register))\n ", -" (register2 (make-register)))\n (letrec\n ((wrap (lambda (var", -"1)\n (let ((var2 (register1 var1)))\n (i", -"f (undefined? var2)\n (let ((var2 (make-identifier var1", -" env)))\n (register1 var1 var2)\n ", -" (register2 var2 var1)\n var2)\n ", -" var2))))\n (unwrap (lambda (var2)\n ", -"(let ((var1 (register2 var2)))\n (if (undefined? var1)\n ", -" var2\n var1))))\n ", -" (walk (lambda (f form)\n (cond\n ((var", -"iable? form)\n (f form))\n ((pair? form", -")\n (cons (walk f (car form)) (walk f (cdr form))))\n ", -" ((vector? form)\n (list->vector (walk f (vec", -"tor->list form))))\n (else\n form)))))\n", -" (let ((form (cdr form)))\n (walk unwrap (apply f (walk wrap ", -"form))))))))\n\n (define-macro define-syntax\n (lambda (form env)\n (let ((", -"formal (car (cdr form)))\n (body (cdr (cdr form))))\n (if (pai", -"r? formal)\n `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr ", -"formal) ,@body))\n `(,the-define-macro ,formal (,(the 'transformer) (,", -"the-begin ,@body)))))))\n\n (define-macro letrec-syntax\n (lambda (form env)\n ", -" (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n ", -" `(let ()\n ,@(map (lambda (x)\n `(,(the 'define-sy", -"ntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n (d", -"efine-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(c", -"dr form))))\n\n (export let let* letrec letrec*\n let-values let*-values ", -"define-values\n quasiquote unquote unquote-splicing\n and or\n ", -" cond case else =>\n do when unless\n parameterize\n ", -" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquo", -"te syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-e", -"rror))\n\n", +" #t\n `(,(the 'or) ,@(map (la", +"mbda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ", +" ,(if (and (variable? (cadr clause))\n ", +" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ", +" `(,(car (cdr (cdr clause))) ,the-key)\n ", +" `(,the-begin ,@(cdr clause)))\n ,(lo", +"op (cdr clauses)))))))))))\n\n(define-macro parameterize\n (lambda (form env)\n ", +"(let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(,(t", +"he 'with-parameter)\n (,(the 'lambda) ()\n ,@formal\n ,@body", +")))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (let ((renames '()))\n", +" (letrec\n ((rename (lambda (var)\n (let ((x (as", +"sq var renames)))\n (if x\n (cadr ", +"x)\n (begin\n (set! renames ", +"`((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,ren", +"ames))\n (rename var))))))\n (walk (lambda (", +"f form)\n (cond\n ((variable? form)\n ", +" (f form))\n ((pair? form)\n `(,", +"(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ((vect", +"or? form)\n `(,(the 'list->vector) (walk f (vector->list form", +"))))\n (else\n `(,(the 'quote) ,form))))))\n", +" (let ((form (walk rename (cadr form))))\n `(,(the 'let)\n ", +" ,(map cdr renames)\n ,form))))))\n\n(define-macro syntax-quasiquote\n", +" (lambda (form env)\n (let ((renames '()))\n (letrec\n ((rename (", +"lambda (var)\n (let ((x (assq var renames)))\n ", +" (if x\n (cadr x)\n (beg", +"in\n (set! renames `((,var ,(make-identifier var env)", +" (,(the 'make-identifier) ',var ',env)) . ,renames))\n ", +" (rename var)))))))\n\n (define (syntax-quasiquote? form)\n (and (", +"pair? form)\n (variable? (car form))\n (variable=? (th", +"e 'syntax-quasiquote) (make-identifier (car form) env))))\n\n (define (synt", +"ax-unquote? form)\n (and (pair? form)\n (variable? (car for", +"m))\n (variable=? (the 'syntax-unquote) (make-identifier (car form)", +" env))))\n\n (define (syntax-unquote-splicing? form)\n (and (pair? ", +"form)\n (pair? (car form))\n (variable? (caar form))\n ", +" (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar ", +"form) env))))\n\n (define (qq depth expr)\n (cond\n ;; syn", +"tax-unquote\n ((syntax-unquote? expr)\n (if (= depth 1)\n ", +" (car (cdr expr))\n (list (the 'list)\n ", +" (list (the 'quote) (the 'syntax-unquote))\n (qq (- depth", +" 1) (car (cdr expr))))))\n ;; syntax-unquote-splicing\n ((synt", +"ax-unquote-splicing? expr)\n (if (= depth 1)\n (list (th", +"e 'append)\n (car (cdr (car expr)))\n (q", +"q depth (cdr expr)))\n (list (the 'cons)\n (li", +"st (the 'list)\n (list (the 'quote) (the 'syntax-unquo", +"te-splicing))\n (qq (- depth 1) (car (cdr (car expr)))", +"))\n (qq depth (cdr expr)))))\n ;; syntax-quasiquot", +"e\n ((syntax-quasiquote? expr)\n (list (the 'list)\n ", +" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) ", +"(car (cdr expr)))))\n ;; list\n ((pair? expr)\n (lis", +"t (the 'cons)\n (qq depth (car expr))\n (qq dept", +"h (cdr expr))))\n ;; vector\n ((vector? expr)\n (lis", +"t (the 'list->vector) (qq depth (vector->list expr))))\n ;; variable\n ", +" ((variable? expr)\n (rename expr))\n ;; simple datum", +"\n (else\n (list (the 'quote) expr))))\n\n (let ((body (", +"qq 1 (cadr form))))\n `(,(the 'let)\n ,(map cdr renames)\n ", +" ,body))))))\n\n(define (transformer f)\n (lambda (form env)\n (let ((regi", +"ster1 (make-register))\n (register2 (make-register)))\n (letrec\n ", +" ((wrap (lambda (var1)\n (let ((var2 (register1 var1)))\n ", +" (if (undefined? var2)\n (let ((var2 (m", +"ake-identifier var1 env)))\n (register1 var1 var2)\n ", +" (register2 var2 var1)\n var2)\n ", +" var2))))\n (unwrap (lambda (var2)\n ", +" (let ((var1 (register2 var2)))\n (if (undefined? var", +"1)\n var2\n var1))))\n ", +" (walk (lambda (f form)\n (cond\n ((variable", +"? form)\n (f form))\n ((pair? form)\n ", +" (cons (walk f (car form)) (walk f (cdr form))))\n ", +" ((vector? form)\n (list->vector (walk f (vector->list form)", +")))\n (else\n form)))))\n (let ((form", +" (cdr form)))\n (walk unwrap (apply f (walk wrap form))))))))\n\n(define-m", +"acro define-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", +" (body (cdr (cdr form))))\n (if (pair? formal)\n `(,(the 'def", +"ine-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-d", +"efine-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(define-macr", +"o letrec-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", +" (body (cdr (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n ", +" `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n", +" ,@body))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the '", +"letrec-syntax) ,@(cdr form))))\n\n(export let let* letrec letrec*\n let-valu", +"es let*-values define-values\n quasiquote unquote unquote-splicing\n ", +" and or\n cond case else =>\n do when unless\n parameterize\n ", +" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquot", +"e syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-error)", +"\n\n(define-macro define-library\n (lambda (form _)\n (let ((name (cadr form))\n ", +" (body (cddr form)))\n (let ((old-library (current-library))\n ", +" (new-library (or (find-library name) (make-library name))))\n (let ((", +"env (library-environment new-library)))\n (current-library new-library)\n", +" (for-each (lambda (expr) (eval expr env)) body)\n (current-lib", +"rary old-library))))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec", +"\n ((test (lambda (form)\n (or\n (eq? form ", +"'else)\n (and (symbol? form)\n (memq form (", +"features)))\n (and (pair? form)\n (case (ca", +"r form)\n ((library) (find-library (cadr form)))\n ", +" ((not) (not (test (cadr form))))\n ((and", +") (let loop ((form (cdr form)))\n (or (null? for", +"m)\n (and (test (car form)) (loop (cdr form)", +")))))\n ((or) (let loop ((form (cdr form)))\n ", +" (and (pair? form)\n (or ", +"(test (car form)) (loop (cdr form))))))\n (else #f)))))))", +"\n (let loop ((clauses (cdr form)))\n (if (null? clauses)\n ", +"#undefined\n (if (test (caar clauses))\n `(,the-begin ,@", +"(cdar clauses))\n (loop (cdr clauses))))))))\n\n(export define-libra", +"ry\n cond-expand)\n\n", "", "" }; diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index 893cc36e..fc866aa4 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -188,70 +188,6 @@ pic_export(pic_state *pic, pic_sym *sym) export(pic, pic_obj_value(sym)); } -static bool -condexpand(pic_state *pic, pic_value clause) -{ - pic_sym *tag; - pic_value c, feature, it; - - if (pic_eq_p(clause, pic_obj_value(pic->sELSE))) { - return true; - } - if (pic_sym_p(clause)) { - pic_for_each (feature, pic->features, it) { - if(pic_eq_p(feature, clause)) - return true; - } - return false; - } - - if (! (pic_pair_p(clause) && pic_sym_p(pic_car(pic, clause)))) { - pic_errorf(pic, "invalid 'cond-expand' clause ~s", clause); - } else { - tag = pic_sym_ptr(pic_car(pic, clause)); - } - - if (tag == pic->sLIBRARY) { - return pic_find_library(pic, pic_list_ref(pic, clause, 1)) != NULL; - } - if (tag == pic->sNOT) { - return ! condexpand(pic, pic_list_ref(pic, clause, 1)); - } - if (tag == pic->sAND) { - pic_for_each (c, pic_cdr(pic, clause), it) { - if (! condexpand(pic, c)) - return false; - } - return true; - } - if (tag == pic->sOR) { - pic_for_each (c, pic_cdr(pic, clause), it) { - if (condexpand(pic, c)) - return true; - } - return false; - } - - pic_errorf(pic, "unknown 'cond-expand' directive ~s", clause); -} - -static pic_value -pic_lib_condexpand(pic_state *pic) -{ - pic_value *clauses; - size_t argc, i; - - pic_get_args(pic, "*", &argc, &clauses); - - for (i = 0; i < argc; i++) { - if (condexpand(pic, pic_car(pic, clauses[i]))) { - return pic_cons(pic, pic_obj_value(pic->sBEGIN), pic_cdr(pic, clauses[i])); - } - } - - return pic_undef_value(); -} - static pic_value pic_lib_import(pic_state *pic) { @@ -282,36 +218,6 @@ pic_lib_export(pic_state *pic) return pic_undef_value(); } -static pic_value -pic_lib_define_library(pic_state *pic) -{ - struct pic_lib *lib, *prev = pic->lib; - size_t argc, i; - pic_value spec, *argv; - - pic_get_args(pic, "o*", &spec, &argc, &argv); - - if ((lib = pic_find_library(pic, spec)) == NULL) { - lib = pic_make_library(pic, spec); - } - - pic_try { - pic->lib = lib; - - for (i = 0; i < argc; ++i) { - pic_void(pic_eval(pic, argv[i], pic->lib->env)); - } - - pic->lib = prev; - } - pic_catch { - pic->lib = prev; /* restores pic->lib even if an error occured */ - pic_raise(pic, pic->err); - } - - return pic_undef_value(); -} - static pic_value pic_lib_make_library(pic_state *pic) { @@ -403,10 +309,8 @@ pic_init_lib(pic_state *pic) { void pic_defmacro(pic_state *, pic_sym *, pic_sym *, pic_func_t); - pic_defmacro(pic, pic->sCOND_EXPAND, pic->uCOND_EXPAND, pic_lib_condexpand); pic_defmacro(pic, pic->sIMPORT, pic->uIMPORT, pic_lib_import); pic_defmacro(pic, pic->sEXPORT, pic->uEXPORT, pic_lib_export); - pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->uDEFINE_LIBRARY, pic_lib_define_library); pic_defun(pic, "make-library", pic_lib_make_library); pic_defun(pic, "find-library", pic_lib_find_library); From 52b03d928cd201d5c9da5cf22e3c2e0c6c7574c1 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Jun 2015 00:59:19 +0900 Subject: [PATCH 5/7] define import in scheme --- extlib/benz/boot.c | 85 ++++++++++++++++++++++++++++++++++++++++++++-- extlib/benz/lib.c | 49 +++++++++++++++++--------- 2 files changed, 115 insertions(+), 19 deletions(-) diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index 2bb39ea8..9fc3cbfa 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -492,8 +492,61 @@ my $src = <<'EOL'; `(,the-begin ,@(cdar clauses)) (loop (cdr clauses)))))))) +(define-macro import + (lambda (form _) + (let ((caddr + (lambda (x) (car (cdr (cdr x))))) + (prefix + (lambda (prefix symbol) + (string->symbol + (string-append + (symbol->string prefix) + (symbol->string symbol)))))) + (letrec + ((extract + (lambda (spec) + (case (car spec) + ((only rename prefix except) + (extract (cadr spec))) + (else + (or (find-library spec) (error "library not found" spec)))))) + (collect + (lambda (spec) + (case (car spec) + ((only) + (let ((alist (collect (cadr spec)))) + (map (lambda (var) (assq var alist)) (cddr spec)))) + ((rename) + (let ((alist (collect (cadr spec)))) + (map (lambda (s) (or (assq (car s) (cddr spec)) s)) alist))) + ((prefix) + (let ((alist (collect (cadr spec)))) + (map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist))) + ((except) + (let ((alist (collect (cadr spec)))) + (let loop ((alist alist)) + (if (null? alist) + '() + (if (memq (caar alist) (cddr spec)) + (loop (cdr alist)) + (cons (car alist) (loop (cdr alist)))))))) + (else + (let ((lib (or (find-library spec) (error "library not found" spec)))) + (map (lambda (x) (cons x x)) (library-exports lib)))))))) + (letrec + ((import + (lambda (spec) + (let ((lib (extract spec)) + (alist (collect spec))) + (for-each + (lambda (slot) + (library-import lib (cdr slot) (car slot))) + alist))))) + (for-each import (cdr form))))))) + (export define-library - cond-expand) + cond-expand + import) EOL @@ -757,8 +810,34 @@ const char pic_boot[][80] = { "(test (car form)) (loop (cdr form))))))\n (else #f)))))))", "\n (let loop ((clauses (cdr form)))\n (if (null? clauses)\n ", "#undefined\n (if (test (caar clauses))\n `(,the-begin ,@", -"(cdar clauses))\n (loop (cdr clauses))))))))\n\n(export define-libra", -"ry\n cond-expand)\n\n", +"(cdar clauses))\n (loop (cdr clauses))))))))\n\n(define-macro import", +"\n (lambda (form _)\n (let ((caddr\n (lambda (x) (car (cdr (cdr x))))", +")\n (prefix\n (lambda (prefix symbol)\n (string->sym", +"bol\n (string-append\n (symbol->string prefix)\n ", +" (symbol->string symbol))))))\n (letrec\n ((extract\n ", +" (lambda (spec)\n (case (car spec)\n ((only rename pr", +"efix except)\n (extract (cadr spec)))\n (else\n ", +" (or (find-library spec) (error \"library not found\" spec))))))\n ", +" (collect\n (lambda (spec)\n (case (car spec)\n ", +" ((only)\n (let ((alist (collect (cadr spec))))\n ", +" (map (lambda (var) (assq var alist)) (cddr spec))))\n ((r", +"ename)\n (let ((alist (collect (cadr spec))))\n ", +"(map (lambda (s) (or (assq (car s) (cddr spec)) s)) alist)))\n ((p", +"refix)\n (let ((alist (collect (cadr spec))))\n ", +"(map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ", +" ((except)\n (let ((alist (collect (cadr spec))))\n ", +" (let loop ((alist alist))\n (if (null? alist)\n ", +" '()\n (if (memq (caar alist) (cddr s", +"pec))\n (loop (cdr alist))\n ", +" (cons (car alist) (loop (cdr alist))))))))\n (else\n ", +" (let ((lib (or (find-library spec) (error \"library not found\" spec))))\n ", +" (map (lambda (x) (cons x x)) (library-exports lib))))))))\n ", +" (letrec\n ((import\n (lambda (spec)\n (le", +"t ((lib (extract spec))\n (alist (collect spec)))\n ", +" (for-each\n (lambda (slot)\n (li", +"brary-import lib (cdr slot) (car slot)))\n alist)))))\n ", +" (for-each import (cdr form)))))))\n\n(export define-library\n cond-expand\n", +" import)\n\n", "", "" }; diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index fc866aa4..cf225211 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -188,21 +188,6 @@ pic_export(pic_state *pic, pic_sym *sym) export(pic, pic_obj_value(sym)); } -static pic_value -pic_lib_import(pic_state *pic) -{ - size_t argc, i; - pic_value *argv; - - pic_get_args(pic, "*", &argc, &argv); - - for (i = 0; i < argc; ++i) { - import(pic, argv[i]); - } - - return pic_undef_value(); -} - static pic_value pic_lib_export(pic_state *pic) { @@ -262,6 +247,38 @@ pic_lib_current_library(pic_state *pic) } } +static pic_value +pic_lib_library_import(pic_state *pic) +{ + pic_value lib_opt; + pic_sym *name, *realname, *uid, *alias = NULL; + struct pic_lib *lib; + + pic_get_args(pic, "om|m", &lib_opt, &name, &alias); + + pic_assert_type(pic, lib_opt, lib); + + if (alias == NULL) { + alias = name; + } + + lib = pic_lib_ptr(lib_opt); + + if (! pic_dict_has(pic, lib->exports, name)) { + pic_errorf(pic, "attempted to import undefined variable '~s'", pic_obj_value(name)); + } else { + realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name)); + } + + if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(realname))) == NULL) { + pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname)); + } else { + pic_put_variable(pic, pic->lib->env, pic_obj_value(alias), uid); + } + + return pic_undef_value(); +} + static pic_value pic_lib_library_name(pic_state *pic) { @@ -309,12 +326,12 @@ pic_init_lib(pic_state *pic) { void pic_defmacro(pic_state *, pic_sym *, pic_sym *, pic_func_t); - pic_defmacro(pic, pic->sIMPORT, pic->uIMPORT, pic_lib_import); pic_defmacro(pic, pic->sEXPORT, pic->uEXPORT, pic_lib_export); pic_defun(pic, "make-library", pic_lib_make_library); pic_defun(pic, "find-library", pic_lib_find_library); pic_defun(pic, "current-library", pic_lib_current_library); + pic_defun(pic, "library-import", pic_lib_library_import); pic_defun(pic, "library-name", pic_lib_library_name); pic_defun(pic, "library-exports", pic_lib_library_exports); pic_defun(pic, "library-environment", pic_lib_library_environment); From 29a966d678613e79b491fbc89c328518dda35bb0 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Jun 2015 01:42:44 +0900 Subject: [PATCH 6/7] define export in scheme --- extlib/benz/boot.c | 158 +++++++++++++++++++++++++++------------------ extlib/benz/lib.c | 41 ++++++------ 2 files changed, 114 insertions(+), 85 deletions(-) diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index 9fc3cbfa..d24bcf40 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -442,18 +442,8 @@ my $src = <<'EOL'; (lambda (form env) `(,(the 'letrec-syntax) ,@(cdr form)))) -(export let let* letrec letrec* - let-values let*-values define-values - quasiquote unquote unquote-splicing - and or - cond case else => - do when unless - parameterize - define-syntax - syntax-quote syntax-unquote - syntax-quasiquote syntax-unquote-splicing - let-syntax letrec-syntax - syntax-error) + +;;; library primitives (define-macro define-library (lambda (form _) @@ -544,9 +534,42 @@ my $src = <<'EOL'; alist))))) (for-each import (cdr form))))))) +(define-macro export + (lambda (form _) + (letrec + ((collect + (lambda (spec) + (cond + ((symbol? spec) + `(,spec . ,spec)) + ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename)) + `(,(list-ref spec 1) . ,(list-ref spec 2))) + (else + (error "malformed export"))))) + (export + (lambda (spec) + (let ((slot (collect spec))) + (library-export (car slot) (cdr slot)))))) + (for-each export (cdr form))))) + (export define-library cond-expand - import) + import + export) + +(export let let* letrec letrec* + let-values let*-values define-values + quasiquote unquote unquote-splicing + and or + cond case else => + do when unless + parameterize + define-syntax + syntax-quote syntax-unquote + syntax-quasiquote syntax-unquote-splicing + let-syntax letrec-syntax + syntax-error) + EOL @@ -787,57 +810,64 @@ const char pic_boot[][80] = { " (body (cdr (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n ", " `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n", " ,@body))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the '", -"letrec-syntax) ,@(cdr form))))\n\n(export let let* letrec letrec*\n let-valu", -"es let*-values define-values\n quasiquote unquote unquote-splicing\n ", -" and or\n cond case else =>\n do when unless\n parameterize\n ", -" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquot", -"e syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-error)", -"\n\n(define-macro define-library\n (lambda (form _)\n (let ((name (cadr form))\n ", -" (body (cddr form)))\n (let ((old-library (current-library))\n ", -" (new-library (or (find-library name) (make-library name))))\n (let ((", -"env (library-environment new-library)))\n (current-library new-library)\n", -" (for-each (lambda (expr) (eval expr env)) body)\n (current-lib", -"rary old-library))))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec", -"\n ((test (lambda (form)\n (or\n (eq? form ", -"'else)\n (and (symbol? form)\n (memq form (", -"features)))\n (and (pair? form)\n (case (ca", -"r form)\n ((library) (find-library (cadr form)))\n ", -" ((not) (not (test (cadr form))))\n ((and", -") (let loop ((form (cdr form)))\n (or (null? for", -"m)\n (and (test (car form)) (loop (cdr form)", -")))))\n ((or) (let loop ((form (cdr form)))\n ", -" (and (pair? form)\n (or ", -"(test (car form)) (loop (cdr form))))))\n (else #f)))))))", -"\n (let loop ((clauses (cdr form)))\n (if (null? clauses)\n ", -"#undefined\n (if (test (caar clauses))\n `(,the-begin ,@", -"(cdar clauses))\n (loop (cdr clauses))))))))\n\n(define-macro import", -"\n (lambda (form _)\n (let ((caddr\n (lambda (x) (car (cdr (cdr x))))", -")\n (prefix\n (lambda (prefix symbol)\n (string->sym", -"bol\n (string-append\n (symbol->string prefix)\n ", -" (symbol->string symbol))))))\n (letrec\n ((extract\n ", -" (lambda (spec)\n (case (car spec)\n ((only rename pr", -"efix except)\n (extract (cadr spec)))\n (else\n ", -" (or (find-library spec) (error \"library not found\" spec))))))\n ", -" (collect\n (lambda (spec)\n (case (car spec)\n ", -" ((only)\n (let ((alist (collect (cadr spec))))\n ", -" (map (lambda (var) (assq var alist)) (cddr spec))))\n ((r", -"ename)\n (let ((alist (collect (cadr spec))))\n ", -"(map (lambda (s) (or (assq (car s) (cddr spec)) s)) alist)))\n ((p", -"refix)\n (let ((alist (collect (cadr spec))))\n ", -"(map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ", -" ((except)\n (let ((alist (collect (cadr spec))))\n ", -" (let loop ((alist alist))\n (if (null? alist)\n ", -" '()\n (if (memq (caar alist) (cddr s", -"pec))\n (loop (cdr alist))\n ", -" (cons (car alist) (loop (cdr alist))))))))\n (else\n ", -" (let ((lib (or (find-library spec) (error \"library not found\" spec))))\n ", -" (map (lambda (x) (cons x x)) (library-exports lib))))))))\n ", -" (letrec\n ((import\n (lambda (spec)\n (le", -"t ((lib (extract spec))\n (alist (collect spec)))\n ", -" (for-each\n (lambda (slot)\n (li", -"brary-import lib (cdr slot) (car slot)))\n alist)))))\n ", -" (for-each import (cdr form)))))))\n\n(export define-library\n cond-expand\n", -" import)\n\n", +"letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro define-li", +"brary\n (lambda (form _)\n (let ((name (cadr form))\n (body (cddr form", +")))\n (let ((old-library (current-library))\n (new-library (or (fi", +"nd-library name) (make-library name))))\n (let ((env (library-environment ", +"new-library)))\n (current-library new-library)\n (for-each (lamb", +"da (expr) (eval expr env)) body)\n (current-library old-library))))))\n\n(", +"define-macro cond-expand\n (lambda (form _)\n (letrec\n ((test (lambda (", +"form)\n (or\n (eq? form 'else)\n ", +"(and (symbol? form)\n (memq form (features)))\n ", +" (and (pair? form)\n (case (car form)\n ", +" ((library) (find-library (cadr form)))\n ((not) (", +"not (test (cadr form))))\n ((and) (let loop ((form (cdr f", +"orm)))\n (or (null? form)\n ", +" (and (test (car form)) (loop (cdr form))))))\n ", +" ((or) (let loop ((form (cdr form)))\n (and ", +"(pair? form)\n (or (test (car form)) (loop (", +"cdr form))))))\n (else #f)))))))\n (let loop ((clause", +"s (cdr form)))\n (if (null? clauses)\n #undefined\n (i", +"f (test (caar clauses))\n `(,the-begin ,@(cdar clauses))\n ", +" (loop (cdr clauses))))))))\n\n(define-macro import\n (lambda (form _)\n (", +"let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n (prefix\n ", +" (lambda (prefix symbol)\n (string->symbol\n (string", +"-append\n (symbol->string prefix)\n (symbol->string sy", +"mbol))))))\n (letrec\n ((extract\n (lambda (spec)\n ", +" (case (car spec)\n ((only rename prefix except)\n ", +" (extract (cadr spec)))\n (else\n (or (find-lib", +"rary spec) (error \"library not found\" spec))))))\n (collect\n ", +" (lambda (spec)\n (case (car spec)\n ((only)\n ", +" (let ((alist (collect (cadr spec))))\n (map (lambda (va", +"r) (assq var alist)) (cddr spec))))\n ((rename)\n (", +"let ((alist (collect (cadr spec))))\n (map (lambda (s) (or (ass", +"q (car s) (cddr spec)) s)) alist)))\n ((prefix)\n (", +"let ((alist (collect (cadr spec))))\n (map (lambda (s) (cons (p", +"refix (caddr spec) (car s)) (cdr s))) alist)))\n ((except)\n ", +" (let ((alist (collect (cadr spec))))\n (let loop ((al", +"ist alist))\n (if (null? alist)\n '()\n", +" (if (memq (caar alist) (cddr spec))\n ", +" (loop (cdr alist))\n (cons (car alist) (loo", +"p (cdr alist))))))))\n (else\n (let ((lib (or (find", +"-library spec) (error \"library not found\" spec))))\n (map (lamb", +"da (x) (cons x x)) (library-exports lib))))))))\n (letrec\n ((im", +"port\n (lambda (spec)\n (let ((lib (extract spec))\n ", +" (alist (collect spec)))\n (for-each\n ", +" (lambda (slot)\n (library-import lib (cdr slo", +"t) (car slot)))\n alist)))))\n (for-each import (cdr f", +"orm)))))))\n\n(define-macro export\n (lambda (form _)\n (letrec\n ((collec", +"t\n (lambda (spec)\n (cond\n ((symbol? spec)\n ", +" `(,spec . ,spec))\n ((and (list? spec) (= (length spec) 3) (e", +"q? (car spec) 'rename))\n `(,(list-ref spec 1) . ,(list-ref spec 2))", +")\n (else\n (error \"malformed export\")))))\n (expo", +"rt\n (lambda (spec)\n (let ((slot (collect spec)))\n ", +" (library-export (car slot) (cdr slot))))))\n (for-each export (cdr for", +"m)))))\n\n(export define-library\n cond-expand\n import\n export", +")\n\n(export let let* letrec letrec*\n let-values let*-values define-values\n", +" quasiquote unquote unquote-splicing\n and or\n cond case els", +"e =>\n do when unless\n parameterize\n define-syntax\n s", +"yntax-quote syntax-unquote\n syntax-quasiquote syntax-unquote-splicing\n ", +" let-syntax letrec-syntax\n syntax-error)\n\n\n", "", "" }; diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index cf225211..81c98472 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -188,21 +188,6 @@ pic_export(pic_state *pic, pic_sym *sym) export(pic, pic_obj_value(sym)); } -static pic_value -pic_lib_export(pic_state *pic) -{ - size_t argc, i; - pic_value *argv; - - pic_get_args(pic, "*", &argc, &argv); - - for (i = 0; i < argc; ++i) { - export(pic, argv[i]); - } - - return pic_undef_value(); -} - static pic_value pic_lib_make_library(pic_state *pic) { @@ -279,6 +264,22 @@ pic_lib_library_import(pic_state *pic) return pic_undef_value(); } +static pic_value +pic_lib_library_export(pic_state *pic) +{ + pic_sym *name, *alias = NULL; + + pic_get_args(pic, "m|m", &name, &alias); + + if (alias == NULL) { + alias = name; + } + + pic_dict_set(pic, pic->lib->exports, alias, pic_obj_value(name)); + + return pic_undef_value(); +} + static pic_value pic_lib_library_name(pic_state *pic) { @@ -324,15 +325,13 @@ pic_lib_library_environment(pic_state *pic) void pic_init_lib(pic_state *pic) { - void pic_defmacro(pic_state *, pic_sym *, pic_sym *, pic_func_t); - - pic_defmacro(pic, pic->sEXPORT, pic->uEXPORT, pic_lib_export); - pic_defun(pic, "make-library", pic_lib_make_library); pic_defun(pic, "find-library", pic_lib_find_library); - pic_defun(pic, "current-library", pic_lib_current_library); - pic_defun(pic, "library-import", pic_lib_library_import); pic_defun(pic, "library-name", pic_lib_library_name); pic_defun(pic, "library-exports", pic_lib_library_exports); pic_defun(pic, "library-environment", pic_lib_library_environment); + + pic_defun(pic, "current-library", pic_lib_current_library); + pic_defun(pic, "library-import", pic_lib_library_import); + pic_defun(pic, "library-export", pic_lib_library_export); } From 1d1210db09056514baf142d4fb0735030217e08b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 17 Jun 2015 01:52:20 +0900 Subject: [PATCH 7/7] cleanup lib.c --- extlib/benz/include/picrin.h | 3 +- extlib/benz/lib.c | 130 +++-------------------------------- extlib/benz/state.c | 2 +- 3 files changed, 11 insertions(+), 124 deletions(-) diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index f6fb2800..a063fa68 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -233,8 +233,7 @@ struct pic_lib *pic_find_library(pic_state *, pic_value); ((pic->lib = pic->prev_lib), \ (pic->prev_lib = NULL))) -void pic_import(pic_state *, pic_value); -void pic_import_library(pic_state *, struct pic_lib *); +void pic_import(pic_state *, struct pic_lib *); void pic_export(pic_state *, pic_sym *); PIC_NORETURN void pic_panic(pic_state *, const char *); diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index 81c98472..7ffa66fe 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -54,138 +54,26 @@ pic_find_library(pic_state *pic, pic_value spec) return pic_lib_ptr(pic_cdr(pic, v)); } -static void -import_table(pic_state *pic, pic_value spec, struct pic_dict *imports) +void +pic_import(pic_state *pic, struct pic_lib *lib) { - struct pic_lib *lib; - struct pic_dict *table; - pic_value val, tmp, prefix, it; - pic_sym *sym, *id, *tag, *nick; - xh_entry *iter; + pic_sym *name, *realname, *uid; + xh_entry *it; - table = pic_make_dict(pic); - - if (pic_pair_p(spec) && pic_sym_p(pic_car(pic, spec))) { - - tag = pic_sym_ptr(pic_car(pic, spec)); - - if (tag == pic->sONLY) { - import_table(pic, pic_cadr(pic, spec), table); - - pic_for_each (val, pic_cddr(pic, spec), it) { - pic_dict_set(pic, imports, pic_sym_ptr(val), pic_dict_ref(pic, table, pic_sym_ptr(val))); - } - return; - } - if (tag == pic->sRENAME) { - import_table(pic, pic_cadr(pic, spec), imports); - - pic_for_each (val, pic_cddr(pic, spec), it) { - tmp = pic_dict_ref(pic, imports, pic_sym_ptr(pic_car(pic, val))); - pic_dict_del(pic, imports, pic_sym_ptr(pic_car(pic, val))); - pic_dict_set(pic, imports, pic_sym_ptr(pic_cadr(pic, val)), tmp); - } - return; - } - if (tag == pic->sPREFIX) { - import_table(pic, pic_cadr(pic, spec), table); - - prefix = pic_list_ref(pic, spec, 2); - pic_dict_for_each (sym, table, iter) { - id = pic_intern(pic, pic_format(pic, "~s~s", prefix, pic_obj_value(sym))); - pic_dict_set(pic, imports, id, pic_dict_ref(pic, table, sym)); - } - return; - } - if (tag == pic->sEXCEPT) { - import_table(pic, pic_cadr(pic, spec), imports); - pic_for_each (val, pic_cddr(pic, spec), it) { - pic_dict_del(pic, imports, pic_sym_ptr(val)); - } - return; - } - } - lib = pic_find_library(pic, spec); - if (! lib) { - pic_errorf(pic, "library not found: ~a", spec); - } - pic_dict_for_each (nick, lib->exports, iter) { - pic_sym *realname, *uid; - - realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, nick)); + pic_dict_for_each (name, lib->exports, it) { + realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name)); if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(realname))) == NULL) { pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname)); } - pic_dict_set(pic, imports, nick, pic_obj_value(uid)); + pic_put_variable(pic, pic->lib->env, pic_obj_value(name), uid); } } -static void -import(pic_state *pic, pic_value spec) -{ - struct pic_dict *imports; - pic_sym *sym; - xh_entry *it; - - imports = pic_make_dict(pic); - - import_table(pic, spec, imports); - - pic_dict_for_each (sym, imports, it) { - pic_put_variable(pic, pic->lib->env, pic_obj_value(sym), pic_sym_ptr(pic_dict_ref(pic, imports, sym))); - } -} - -static void -export(pic_state *pic, pic_value spec) -{ - pic_sym *sRENAME = pic_intern_cstr(pic, "rename"); - pic_value a, b; - - if (pic_sym_p(spec)) { /* (export a) */ - a = b = spec; - } else { /* (export (rename a b)) */ - if (! pic_list_p(spec)) - goto fail; - if (! (pic_length(pic, spec) == 3)) - goto fail; - if (! pic_eq_p(pic_car(pic, spec), pic_obj_value(sRENAME))) - goto fail; - if (! pic_sym_p(a = pic_list_ref(pic, spec, 1))) - goto fail; - if (! pic_sym_p(b = pic_list_ref(pic, spec, 2))) - goto fail; - } - -#if DEBUG - printf("* exporting %s as %s\n", pic_symbol_name(pic, pic_sym_ptr(b)), pic_symbol_name(pic, pic_sym_ptr(a))); -#endif - - pic_dict_set(pic, pic->lib->exports, pic_sym_ptr(b), a); - - return; - - fail: - pic_errorf(pic, "illegal export spec: ~s", spec); -} - void -pic_import(pic_state *pic, pic_value spec) +pic_export(pic_state *pic, pic_sym *name) { - import(pic, spec); -} - -void -pic_import_library(pic_state *pic, struct pic_lib *lib) -{ - import(pic, lib->name); -} - -void -pic_export(pic_state *pic, pic_sym *sym) -{ - export(pic, pic_obj_value(sym)); + pic_dict_set(pic, pic->lib->exports, name, pic_obj_value(name)); } static pic_value diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 39b506ce..6e11f812 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -148,7 +148,7 @@ pic_init_core(pic_state *pic) pic_load_cstr(pic, &pic_boot[0][0]); } - pic_import_library(pic, pic->PICRIN_BASE); + pic_import(pic, pic->PICRIN_BASE); } pic_state *