define import in scheme
This commit is contained in:
parent
fa1c619633
commit
52b03d928c
|
@ -492,8 +492,61 @@ my $src = <<'EOL';
|
||||||
`(,the-begin ,@(cdar clauses))
|
`(,the-begin ,@(cdar clauses))
|
||||||
(loop (cdr 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
|
(export define-library
|
||||||
cond-expand)
|
cond-expand
|
||||||
|
import)
|
||||||
|
|
||||||
EOL
|
EOL
|
||||||
|
|
||||||
|
@ -757,8 +810,34 @@ const char pic_boot[][80] = {
|
||||||
"(test (car form)) (loop (cdr form))))))\n (else #f)))))))",
|
"(test (car form)) (loop (cdr form))))))\n (else #f)))))))",
|
||||||
"\n (let loop ((clauses (cdr form)))\n (if (null? clauses)\n ",
|
"\n (let loop ((clauses (cdr form)))\n (if (null? clauses)\n ",
|
||||||
"#undefined\n (if (test (caar clauses))\n `(,the-begin ,@",
|
"#undefined\n (if (test (caar clauses))\n `(,the-begin ,@",
|
||||||
"(cdar clauses))\n (loop (cdr clauses))))))))\n\n(export define-libra",
|
"(cdar clauses))\n (loop (cdr clauses))))))))\n\n(define-macro import",
|
||||||
"ry\n cond-expand)\n\n",
|
"\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",
|
||||||
"",
|
"",
|
||||||
""
|
""
|
||||||
};
|
};
|
||||||
|
|
|
@ -188,21 +188,6 @@ pic_export(pic_state *pic, pic_sym *sym)
|
||||||
export(pic, pic_obj_value(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
|
static pic_value
|
||||||
pic_lib_export(pic_state *pic)
|
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
|
static pic_value
|
||||||
pic_lib_library_name(pic_state *pic)
|
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);
|
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_defmacro(pic, pic->sEXPORT, pic->uEXPORT, pic_lib_export);
|
||||||
|
|
||||||
pic_defun(pic, "make-library", pic_lib_make_library);
|
pic_defun(pic, "make-library", pic_lib_make_library);
|
||||||
pic_defun(pic, "find-library", pic_lib_find_library);
|
pic_defun(pic, "find-library", pic_lib_find_library);
|
||||||
pic_defun(pic, "current-library", pic_lib_current_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-name", pic_lib_library_name);
|
||||||
pic_defun(pic, "library-exports", pic_lib_library_exports);
|
pic_defun(pic, "library-exports", pic_lib_library_exports);
|
||||||
pic_defun(pic, "library-environment", pic_lib_library_environment);
|
pic_defun(pic, "library-environment", pic_lib_library_environment);
|
||||||
|
|
Loading…
Reference in New Issue