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

define export in scheme

This commit is contained in:
Yuichi Nishiwaki 2015-06-17 01:42:44 +09:00
parent 52b03d928c
commit 29a966d678
2 changed files with 114 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

158
extlib/benz/boot.c
View File

@ -442,18 +442,8 @@ my $src = <<'EOL';
(lambda (form env) (lambda (form env)
`(,(the 'letrec-syntax) ,@(cdr form)))) `(,(the 'letrec-syntax) ,@(cdr form))))
(export let let* letrec letrec*
let-values let*-values define-values ;;; library primitives
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 (define-macro define-library
(lambda (form _) (lambda (form _)
@ -544,9 +534,42 @@ my $src = <<'EOL';
alist))))) alist)))))
(for-each import (cdr form))))))) (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 (export define-library
cond-expand 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 EOL
@ -787,57 +810,64 @@ const char pic_boot[][80] = {
" (body (cdr (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n ", " (body (cdr (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n ",
" `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n", " `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n",
" ,@body))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the '", " ,@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", "letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro define-li",
"es let*-values define-values\n quasiquote unquote unquote-splicing\n ", "brary\n (lambda (form _)\n (let ((name (cadr form))\n (body (cddr form",
" and or\n cond case else =>\n do when unless\n parameterize\n ", ")))\n (let ((old-library (current-library))\n (new-library (or (fi",
" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquot", "nd-library name) (make-library name))))\n (let ((env (library-environment ",
"e syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-error)", "new-library)))\n (current-library new-library)\n (for-each (lamb",
"\n\n(define-macro define-library\n (lambda (form _)\n (let ((name (cadr form))\n ", "da (expr) (eval expr env)) body)\n (current-library old-library))))))\n\n(",
" (body (cddr form)))\n (let ((old-library (current-library))\n ", "define-macro cond-expand\n (lambda (form _)\n (letrec\n ((test (lambda (",
" (new-library (or (find-library name) (make-library name))))\n (let ((", "form)\n (or\n (eq? form 'else)\n ",
"env (library-environment new-library)))\n (current-library new-library)\n", "(and (symbol? form)\n (memq form (features)))\n ",
" (for-each (lambda (expr) (eval expr env)) body)\n (current-lib", " (and (pair? form)\n (case (car form)\n ",
"rary old-library))))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec", " ((library) (find-library (cadr form)))\n ((not) (",
"\n ((test (lambda (form)\n (or\n (eq? form ", "not (test (cadr form))))\n ((and) (let loop ((form (cdr f",
"'else)\n (and (symbol? form)\n (memq form (", "orm)))\n (or (null? form)\n ",
"features)))\n (and (pair? form)\n (case (ca", " (and (test (car form)) (loop (cdr form))))))\n ",
"r form)\n ((library) (find-library (cadr form)))\n ", " ((or) (let loop ((form (cdr form)))\n (and ",
" ((not) (not (test (cadr form))))\n ((and", "(pair? form)\n (or (test (car form)) (loop (",
") (let loop ((form (cdr form)))\n (or (null? for", "cdr form))))))\n (else #f)))))))\n (let loop ((clause",
"m)\n (and (test (car form)) (loop (cdr form)", "s (cdr form)))\n (if (null? clauses)\n #undefined\n (i",
")))))\n ((or) (let loop ((form (cdr form)))\n ", "f (test (caar clauses))\n `(,the-begin ,@(cdar clauses))\n ",
" (and (pair? form)\n (or ", " (loop (cdr clauses))))))))\n\n(define-macro import\n (lambda (form _)\n (",
"(test (car form)) (loop (cdr form))))))\n (else #f)))))))", "let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n (prefix\n ",
"\n (let loop ((clauses (cdr form)))\n (if (null? clauses)\n ", " (lambda (prefix symbol)\n (string->symbol\n (string",
"#undefined\n (if (test (caar clauses))\n `(,the-begin ,@", "-append\n (symbol->string prefix)\n (symbol->string sy",
"(cdar clauses))\n (loop (cdr clauses))))))))\n\n(define-macro import", "mbol))))))\n (letrec\n ((extract\n (lambda (spec)\n ",
"\n (lambda (form _)\n (let ((caddr\n (lambda (x) (car (cdr (cdr x))))", " (case (car spec)\n ((only rename prefix except)\n ",
")\n (prefix\n (lambda (prefix symbol)\n (string->sym", " (extract (cadr spec)))\n (else\n (or (find-lib",
"bol\n (string-append\n (symbol->string prefix)\n ", "rary spec) (error \"library not found\" spec))))))\n (collect\n ",
" (symbol->string symbol))))))\n (letrec\n ((extract\n ", " (lambda (spec)\n (case (car spec)\n ((only)\n ",
" (lambda (spec)\n (case (car spec)\n ((only rename pr", " (let ((alist (collect (cadr spec))))\n (map (lambda (va",
"efix except)\n (extract (cadr spec)))\n (else\n ", "r) (assq var alist)) (cddr spec))))\n ((rename)\n (",
" (or (find-library spec) (error \"library not found\" spec))))))\n ", "let ((alist (collect (cadr spec))))\n (map (lambda (s) (or (ass",
" (collect\n (lambda (spec)\n (case (car spec)\n ", "q (car s) (cddr spec)) s)) alist)))\n ((prefix)\n (",
" ((only)\n (let ((alist (collect (cadr spec))))\n ", "let ((alist (collect (cadr spec))))\n (map (lambda (s) (cons (p",
" (map (lambda (var) (assq var alist)) (cddr spec))))\n ((r", "refix (caddr spec) (car s)) (cdr s))) alist)))\n ((except)\n ",
"ename)\n (let ((alist (collect (cadr spec))))\n ", " (let ((alist (collect (cadr spec))))\n (let loop ((al",
"(map (lambda (s) (or (assq (car s) (cddr spec)) s)) alist)))\n ((p", "ist alist))\n (if (null? alist)\n '()\n",
"refix)\n (let ((alist (collect (cadr spec))))\n ", " (if (memq (caar alist) (cddr spec))\n ",
"(map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ", " (loop (cdr alist))\n (cons (car alist) (loo",
" ((except)\n (let ((alist (collect (cadr spec))))\n ", "p (cdr alist))))))))\n (else\n (let ((lib (or (find",
" (let loop ((alist alist))\n (if (null? alist)\n ", "-library spec) (error \"library not found\" spec))))\n (map (lamb",
" '()\n (if (memq (caar alist) (cddr s", "da (x) (cons x x)) (library-exports lib))))))))\n (letrec\n ((im",
"pec))\n (loop (cdr alist))\n ", "port\n (lambda (spec)\n (let ((lib (extract spec))\n ",
" (cons (car alist) (loop (cdr alist))))))))\n (else\n ", " (alist (collect spec)))\n (for-each\n ",
" (let ((lib (or (find-library spec) (error \"library not found\" spec))))\n ", " (lambda (slot)\n (library-import lib (cdr slo",
" (map (lambda (x) (cons x x)) (library-exports lib))))))))\n ", "t) (car slot)))\n alist)))))\n (for-each import (cdr f",
" (letrec\n ((import\n (lambda (spec)\n (le", "orm)))))))\n\n(define-macro export\n (lambda (form _)\n (letrec\n ((collec",
"t ((lib (extract spec))\n (alist (collect spec)))\n ", "t\n (lambda (spec)\n (cond\n ((symbol? spec)\n ",
" (for-each\n (lambda (slot)\n (li", " `(,spec . ,spec))\n ((and (list? spec) (= (length spec) 3) (e",
"brary-import lib (cdr slot) (car slot)))\n alist)))))\n ", "q? (car spec) 'rename))\n `(,(list-ref spec 1) . ,(list-ref spec 2))",
" (for-each import (cdr form)))))))\n\n(export define-library\n cond-expand\n", ")\n (else\n (error \"malformed export\")))))\n (expo",
" import)\n\n", "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",
"", "",
"" ""
}; };

41
extlib/benz/lib.c
View File

@ -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_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 static pic_value
pic_lib_make_library(pic_state *pic) pic_lib_make_library(pic_state *pic)
{ {
@ -279,6 +264,22 @@ pic_lib_library_import(pic_state *pic)
return pic_undef_value(); 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 static pic_value
pic_lib_library_name(pic_state *pic) pic_lib_library_name(pic_state *pic)
{ {
@ -324,15 +325,13 @@ pic_lib_library_environment(pic_state *pic)
void void
pic_init_lib(pic_state *pic) 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, "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, "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);
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);
} }