conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

define import in scheme

This commit is contained in:
Yuichi Nishiwaki 2015-06-17 00:59:19 +09:00
parent fa1c619633
commit 52b03d928c
2 changed files with 115 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
extlib/benz/boot.c
View File

@ -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",
"",
""
};

49
extlib/benz/lib.c
View File

@ -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);