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

library is now a non-first-class object

This commit is contained in:
Yuichi Nishiwaki 2016-02-18 17:39:32 +09:00
parent 7816be80c1
commit 561c350a12
34 changed files with 308 additions and 282 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
contrib/10.callcc/callcc.c
View File

@ -282,8 +282,6 @@ pic_callcc_callcc(pic_state *pic)
void
pic_init_callcc(pic_state *pic)
{
pic_deflibrary(pic, "(scheme base)");
pic_redefun(pic, pic->PICRIN_BASE, "call-with-current-continuation", pic_callcc_callcc);
pic_redefun(pic, pic->PICRIN_BASE, "call/cc", pic_callcc_callcc);
pic_redefun(pic, "picrin.base", "call-with-current-continuation", pic_callcc_callcc);
pic_redefun(pic, "picrin.base", "call/cc", pic_callcc_callcc);
}

2
contrib/10.math/math.c
View File

@ -284,7 +284,7 @@ pic_number_expt(pic_state *pic)
void
pic_init_math(pic_state *pic)
{
pic_deflibrary(pic, "(picrin math)");
pic_deflibrary(pic, "picrin.math");
pic_defun(pic, "floor/", pic_number_floor2);
pic_defun(pic, "truncate/", pic_number_trunc2);

11
contrib/20.r7rs/scheme/eval.scm
View File

@ -6,14 +6,11 @@
(define-syntax (inc! n)
#`(set! #,n (+ #,n 1)))
(define (number->symbol n)
(string->symbol (number->string n)))
(define (environment . specs)
(let ((library-name `(picrin @@my-environment ,(number->symbol counter))))
(let ((lib (string-append "picrin.@@my-environment." (number->string counter))))
(inc! counter)
(let ((lib (make-library library-name)))
(eval `(import ,@specs) lib)
lib)))
(make-library lib)
(eval `(import ,@specs) lib)
lib))
(export environment eval))

4
contrib/20.r7rs/scheme/r5rs.scm
View File

@ -28,12 +28,12 @@
(define (null-environment n)
(if (not (= n 5))
(error "unsupported environment version" n)
(find-library '(scheme null))))
"scheme.null"))
(define (scheme-report-environment n)
(if (not (= n 5))
(error "unsupported environment version" n)
(find-library '(scheme r5rs))))
"scheme.r5rs"))
(export * + - / < <= = > >=
abs acos and

2
contrib/20.r7rs/src/file.c
View File

@ -93,7 +93,7 @@ pic_file_delete(pic_state *pic)
void
pic_init_file(pic_state *pic)
{
pic_deflibrary(pic, "(scheme file)");
pic_deflibrary(pic, "scheme.file");
pic_defun(pic, "open-input-file", pic_file_open_input_file);
pic_defun(pic, "open-binary-input-file", pic_file_open_binary_input_file);

2
contrib/20.r7rs/src/load.c
View File

@ -25,7 +25,7 @@ pic_load_load(pic_state *pic)
void
pic_init_load(pic_state *pic)
{
pic_deflibrary(pic, "(scheme load)");
pic_deflibrary(pic, "scheme.load");
pic_defun(pic, "load", pic_load_load);
}

2
contrib/20.r7rs/src/mutable-string.c
View File

@ -85,7 +85,7 @@ pic_str_string_fill_ip(pic_state *pic)
void
pic_init_mutable_string(pic_state *pic)
{
pic_deflibrary(pic, "(picrin string)");
pic_deflibrary(pic, "picrin.string");
pic_defun(pic, "string-set!", pic_str_string_set);
pic_defun(pic, "string-copy!", pic_str_string_copy_ip);

2
contrib/20.r7rs/src/system.c
View File

@ -127,7 +127,7 @@ pic_system_getenvs(pic_state *pic)
void
pic_init_system(pic_state *pic)
{
pic_deflibrary(pic, "(scheme process-context)");
pic_deflibrary(pic, "scheme.process-context");
pic_defun(pic, "command-line", pic_system_cmdline);
pic_defun(pic, "exit", pic_system_exit);

2
contrib/20.r7rs/src/time.c
View File

@ -41,7 +41,7 @@ pic_jiffies_per_second(pic_state *pic)
void
pic_init_time(pic_state *pic)
{
pic_deflibrary(pic, "(scheme time)");
pic_deflibrary(pic, "scheme.time");
pic_defun(pic, "current-second", pic_current_second);
pic_defun(pic, "current-jiffy", pic_current_jiffy);

2
contrib/30.random/src/random.c
View File

@ -13,7 +13,7 @@ pic_random_real(pic_state *pic)
void
pic_init_random(pic_state *pic)
{
pic_deflibrary(pic, "(srfi 27)");
pic_deflibrary(pic, "srfi.27");
pic_defun(pic, "random-real", pic_random_real);
}

4
contrib/30.readline/src/readline.c
View File

@ -247,11 +247,11 @@ void
pic_init_readline(pic_state *pic){
using_history();
pic_deflibrary(pic, "(picrin readline)");
pic_deflibrary(pic, "picrin.readline");
pic_defun(pic, "readline", pic_rl_readline);
pic_deflibrary(pic, "(picrin readline history)");
pic_deflibrary(pic, "picrin.readline.history");
/* pic_defun(pic, "history-offset", pic_rl_history_offset); */
pic_defun(pic, "history-length", pic_rl_history_length);

2
contrib/30.regexp/src/regexp.c
View File

@ -178,7 +178,7 @@ pic_regexp_regexp_replace(pic_state *pic)
void
pic_init_regexp(pic_state *pic)
{
pic_deflibrary(pic, "(picrin regexp)");
pic_deflibrary(pic, "picrin.regexp");
pic_defun(pic, "regexp", pic_regexp_regexp);
pic_defun(pic, "regexp?", pic_regexp_regexp_p);

6
contrib/40.srfi/src/106.c
View File

@ -399,10 +399,10 @@ pic_socket_call_with_socket(pic_state *pic)
void
pic_init_srfi_106(pic_state *pic)
{
#define pic_defun_(pic, name, f) pic_define(pic, pic->lib, name, pic_obj_value(pic_make_proc(pic, f, 0, NULL)))
#define pic_define_(pic, name, v) pic_define(pic, pic->lib, name, v)
pic_deflibrary(pic, "srfi.106");
pic_deflibrary(pic, "(srfi 106)");
#define pic_defun_(pic, name, f) pic_define(pic, "srfi.106", name, pic_obj_value(pic_make_proc(pic, f, 0, NULL)))
#define pic_define_(pic, name, v) pic_define(pic, "srfi.106", name, v)
pic_defun_(pic, "socket?", pic_socket_socket_p);
pic_defun_(pic, "make-socket", pic_socket_make_socket);

2
contrib/60.repl/repl.c
View File

@ -15,7 +15,7 @@ pic_repl_tty_p(pic_state *pic)
void
pic_init_repl(pic_state *pic)
{
pic_deflibrary(pic, "(picrin repl)");
pic_deflibrary(pic, "picrin.repl");
pic_defun(pic, "tty?", pic_repl_tty_p);
}

4
contrib/60.repl/repl.scm
View File

@ -34,7 +34,7 @@
(scheme eval)
(scheme r5rs)
(picrin macro))
(find-library '(picrin user))))
"picrin.user"))
(define (repl)
(init-env)
@ -65,7 +65,7 @@
(lambda (port)
(let next ((expr (read port)))
(unless (eof-object? expr)
(write (eval expr (find-library '(picrin user))))
(write (eval expr "picrin.user"))
(newline)
(set! str "")
(next (read port))))))))))

2
contrib/70.main/main.scm
View File

@ -41,7 +41,7 @@
(lambda (in)
(let loop ((expr (read in)))
(unless (eof-object? expr)
(eval expr (find-library '(picrin user)))
(eval expr (find-library "picrin.user"))
(loop (read in)))))))
(define (main)

126
extlib/benz/boot.c
View File

@ -542,12 +542,24 @@ my $src = <<'EOL';
;;; library primitives
(define (mangle name)
(define (->string n)
(if (symbol? n)
(symbol->string n)
(number->string n)))
(define (join strs delim)
(let loop ((res (car strs)) (strs (cdr strs)))
(if (null? strs)
res
(loop (string-append res delim (car strs)) (cdr strs)))))
(join (map ->string name) "."))
(define-macro define-library
(lambda (form _)
(let ((name (cadr form))
(let ((lib (mangle (cadr form)))
(body (cddr form)))
(let ((new-library (or (find-library name) (make-library name))))
(for-each (lambda (expr) (eval expr new-library)) body)))))
(or (find-library lib) (make-library lib))
(for-each (lambda (expr) (eval expr lib)) body))))
(define-macro cond-expand
(lambda (form _)
@ -559,7 +571,7 @@ my $src = <<'EOL';
(memq form (features)))
(and (pair? form)
(case (car form)
((library) (find-library (cadr form)))
((library) (find-library (mangle (cadr form))))
((not) (not (test (cadr form))))
((and) (let loop ((form (cdr form)))
(or (null? form)
@ -584,7 +596,13 @@ my $src = <<'EOL';
(string->symbol
(string-append
(symbol->string prefix)
(symbol->string symbol))))))
(symbol->string symbol)))))
(getlib
(lambda (name)
(let ((lib (mangle name)))
(if (find-library lib)
lib
(error "library not found" name))))))
(letrec
((extract
(lambda (spec)
@ -592,7 +610,7 @@ my $src = <<'EOL';
((only rename prefix except)
(extract (cadr spec)))
(else
(or (find-library spec) (error "library not found" spec))))))
(getlib spec)))))
(collect
(lambda (spec)
(case (car spec)
@ -615,8 +633,7 @@ my $src = <<'EOL';
(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))))))))
(map (lambda (x) (cons x x)) (library-exports (getlib spec))))))))
(letrec
((import
(lambda (spec)
@ -948,31 +965,37 @@ const char pic_boot[][80] = {
"rm))))\n `(let ()\n ,@(map (lambda (x)\n `(,(the 'def",
"ine-syntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n(d",
"efine-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(cdr f",
"orm))))\n\n\n;;; library primitives\n\n(define-macro define-library\n (lambda (form _",
")\n (let ((name (cadr form))\n (body (cddr form)))\n (let ((new-li",
"brary (or (find-library name) (make-library name))))\n (for-each (lambda (",
"expr) (eval expr new-library)) body)))))\n\n(define-macro cond-expand\n (lambda (f",
"orm _)\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 (cad",
"r form)))\n ((not) (not (test (cadr form))))\n ",
" ((and) (let loop ((form (cdr form)))\n ",
" (or (null? form)\n (and (test (car form)",
") (loop (cdr form))))))\n ((or) (let loop ((form (cdr for",
"m)))\n (and (pair? form)\n ",
" (or (test (car form)) (loop (cdr form))))))\n ",
" (else #f)))))))\n (let loop ((clauses (cdr form)))\n (if (null? cla",
"uses)\n #undefined\n (if (test (caar clauses))\n ",
" `(,the-begin ,@(cdar clauses))\n (loop (cdr clauses))))))))\n\n(d",
"efine-macro import\n (lambda (form _)\n (let ((caddr\n (lambda (x) (c",
"ar (cdr (cdr x)))))\n (prefix\n (lambda (prefix symbol)\n ",
" (string->symbol\n (string-append\n (symbol->strin",
"g prefix)\n (symbol->string symbol))))))\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-library spec) (error \"library not found\"",
" spec))))))\n (collect\n (lambda (spec)\n (case (",
"orm))))\n\n\n;;; library primitives\n\n(define (mangle name)\n (define (->string n)\n ",
" (if (symbol? n)\n (symbol->string n)\n (number->string n)))\n (de",
"fine (join strs delim)\n (let loop ((res (car strs)) (strs (cdr strs)))\n ",
"(if (null? strs)\n res\n (loop (string-append res delim (car str",
"s)) (cdr strs)))))\n (join (map ->string name) \".\"))\n\n(define-macro define-libra",
"ry\n (lambda (form _)\n (let ((lib (mangle (cadr form)))\n (body (cddr",
" form)))\n (or (find-library lib) (make-library lib))\n (for-each (lambd",
"a (expr) (eval expr lib)) body))))\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 (mangle (c",
"adr form))))\n ((not) (not (test (cadr form))))\n ",
" ((and) (let loop ((form (cdr form)))\n ",
" (or (null? form)\n (and (test (car fo",
"rm)) (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->symbol\n (string-append\n (symbol->st",
"ring prefix)\n (symbol->string symbol)))))\n (getlib\n ",
" (lambda (name)\n (let ((lib (mangle name)))\n (if (",
"find-library lib)\n lib\n (error \"library not ",
"found\" name))))))\n (letrec\n ((extract\n (lambda (spec)\n ",
" (case (car spec)\n ((only rename prefix except)\n ",
" (extract (cadr spec)))\n (else\n (getli",
"b spec)))))\n (collect\n (lambda (spec)\n (case (",
"car spec)\n ((only)\n (let ((alist (collect (cadr s",
"pec))))\n (map (lambda (var) (assq var alist)) (cddr spec))))\n ",
" ((rename)\n (let ((alist (collect (cadr spec)))\n ",
@ -985,25 +1008,24 @@ const char pic_boot[][80] = {
"f (null? alist)\n '()\n (if (memq ",
"(caar alist) (cddr spec))\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",
" (let ((lib (extract spec))\n (alist (colle",
"ct spec)))\n (for-each\n (lambda (slot)\n ",
" (library-import lib (cdr slot) (car slot)))\n ",
" alist)))))\n (for-each import (cdr form)))))))\n\n(define-macro export\n ",
"(lambda (form _)\n (letrec\n ((collect\n (lambda (spec)\n ",
" (cond\n ((symbol? spec)\n `(,spec . ,spec))\n ",
" ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n ",
" `(,(list-ref spec 1) . ,(list-ref spec 2)))\n (else\n ",
"(error \"malformed export\")))))\n (export\n (lambda (spec)\n ",
" (let ((slot (collect spec)))\n (library-export (car slot) (c",
"dr slot))))))\n (for-each export (cdr form)))))\n\n(export define lambda quote",
" set! if begin define-macro\n let let* letrec letrec*\n let-values l",
"et*-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-quasiquote sy",
"ntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-error)\n\n\n",
" (else\n (map (lambda (x) (cons x x)) (library-exports (getlib s",
"pec))))))))\n (letrec\n ((import\n (lambda (spec)\n ",
" (let ((lib (extract spec))\n (alist (collec",
"t spec)))\n (for-each\n (lambda (slot)\n ",
" (library-import lib (cdr slot) (car slot)))\n ",
"alist)))))\n (for-each import (cdr form)))))))\n\n(define-macro export\n (",
"lambda (form _)\n (letrec\n ((collect\n (lambda (spec)\n ",
" (cond\n ((symbol? spec)\n `(,spec . ,spec))\n ",
" ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n ",
" `(,(list-ref spec 1) . ,(list-ref spec 2)))\n (else\n (",
"error \"malformed export\")))))\n (export\n (lambda (spec)\n ",
" (let ((slot (collect spec)))\n (library-export (car slot) (cd",
"r slot))))))\n (for-each export (cdr form)))))\n\n(export define lambda quote ",
"set! if begin define-macro\n let let* letrec letrec*\n let-values le",
"t*-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-quasiquote syn",
"tax-unquote-splicing\n let-syntax letrec-syntax\n syntax-error)\n\n\n",
"",
""
};

24
extlib/benz/eval.c
View File

@ -885,20 +885,23 @@ pic_compile(pic_state *pic, pic_value obj)
}
pic_value
pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib)
pic_eval(pic_state *pic, pic_value program, const char *lib)
{
struct pic_lib *prev_lib = pic->lib;
const char *prev_lib = pic_current_library(pic);
struct pic_env *env;
pic_value r;
pic->lib = lib;
env = pic_library_environment(pic, lib);
pic_in_library(pic, lib);
pic_try {
r = pic_call(pic, pic_compile(pic, pic_expand(pic, program, lib->env)), 0);
r = pic_call(pic, pic_compile(pic, pic_expand(pic, program, env)), 0);
}
pic_catch {
pic->lib = prev_lib;
pic_in_library(pic, prev_lib);
pic_raise(pic, pic->err);
}
pic->lib = prev_lib;
pic_in_library(pic, prev_lib);
return r;
}
@ -906,13 +909,12 @@ pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib)
static pic_value
pic_eval_eval(pic_state *pic)
{
pic_value program, lib;
pic_value program;
const char *str;
pic_get_args(pic, "oo", &program, &lib);
pic_get_args(pic, "oz", &program, &str);
pic_assert_type(pic, lib, lib);
return pic_eval(pic, program, pic_lib_ptr(lib));
return pic_eval(pic, program, str);
}
void

25
extlib/benz/gc.c
View File

@ -34,7 +34,6 @@ struct pic_object {
struct pic_context cxt;
struct pic_port port;
struct pic_error err;
struct pic_lib lib;
struct pic_checkpoint cp;
} u;
};
@ -347,20 +346,11 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
gc_mark_object(pic, (struct pic_object *)kh_val(h, it));
}
}
if (obj->u.env.prefix) {
gc_mark_object(pic, (struct pic_object *)obj->u.env.prefix);
}
if (obj->u.env.up) {
LOOP(obj->u.env.up);
}
break;
}
case PIC_TT_LIB: {
gc_mark(pic, obj->u.lib.name);
gc_mark_object(pic, (struct pic_object *)obj->u.lib.env);
LOOP(obj->u.lib.exports);
break;
}
case PIC_TT_DATA: {
if (obj->u.data.type->mark) {
obj->u.data.type->mark(pic, obj->u.data.data, gc_mark);
@ -428,6 +418,7 @@ gc_mark_phase(pic_state *pic)
pic_callinfo *ci;
struct pic_proc **xhandler;
struct pic_list *list;
khiter_t it;
size_t j;
assert(pic->heap->weaks == NULL);
@ -492,12 +483,19 @@ gc_mark_phase(pic_state *pic)
/* features */
gc_mark(pic, pic->features);
/* library table */
gc_mark(pic, pic->libs);
/* parameter table */
gc_mark(pic, pic->ptable);
/* library table */
for (it = kh_begin(&pic->ltable); it != kh_end(&pic->ltable); ++it) {
if (! kh_exist(&pic->ltable, it)) {
continue;
}
gc_mark_object(pic, (struct pic_object *)kh_val(&pic->ltable, it).name);
gc_mark_object(pic, (struct pic_object *)kh_val(&pic->ltable, it).env);
gc_mark_object(pic, (struct pic_object *)kh_val(&pic->ltable, it).exports);
}
/* weak maps */
do {
struct pic_object *key;
@ -580,7 +578,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
case PIC_TT_PORT:
case PIC_TT_ERROR:
case PIC_TT_ID:
case PIC_TT_LIB:
case PIC_TT_RECORD:
case PIC_TT_CP:
break;

33
extlib/benz/include/picrin.h
View File

@ -63,17 +63,18 @@ void pic_add_feature(pic_state *, const char *);
void pic_defun(pic_state *, const char *, pic_func_t);
void pic_defvar(pic_state *, const char *, pic_value, struct pic_proc *);
void pic_define(pic_state *, struct pic_lib *, const char *, pic_value);
pic_value pic_ref(pic_state *, struct pic_lib *, const char *);
void pic_set(pic_state *, struct pic_lib *, const char *, pic_value);
void pic_define(pic_state *, const char *, const char *, pic_value);
pic_value pic_ref(pic_state *, const char *, const char *);
void pic_set(pic_state *, const char *, const char *, pic_value);
pic_value pic_closure_ref(pic_state *, int);
void pic_closure_set(pic_state *, int, pic_value);
pic_value pic_funcall(pic_state *pic, struct pic_lib *, const char *, int, ...);
pic_value pic_funcall(pic_state *pic, const char *, const char *, int, ...);
struct pic_lib *pic_make_library(pic_state *, pic_value);
void pic_in_library(pic_state *, pic_value);
struct pic_lib *pic_find_library(pic_state *, pic_value);
void pic_import(pic_state *, struct pic_lib *);
void pic_make_library(pic_state *, const char *);
void pic_in_library(pic_state *, const char *);
bool pic_find_library(pic_state *, const char *);
const char *pic_current_library(pic_state *);
void pic_import(pic_state *, const char *);
void pic_export(pic_state *, pic_sym *);
PIC_NORETURN void pic_panic(pic_state *, const char *);
@ -186,7 +187,6 @@ int pic_str_hash(pic_state *, struct pic_string *);
#include "picrin/data.h"
#include "picrin/dict.h"
#include "picrin/error.h"
#include "picrin/lib.h"
#include "picrin/macro.h"
#include "picrin/pair.h"
#include "picrin/port.h"
@ -215,16 +215,15 @@ pic_value pic_read_cstr(pic_state *, const char *);
void pic_load(pic_state *, struct pic_port *);
void pic_load_cstr(pic_state *, const char *);
pic_value pic_eval(pic_state *, pic_value, struct pic_lib *);
pic_value pic_eval(pic_state *, pic_value, const char *);
struct pic_proc *pic_make_var(pic_state *, pic_value, struct pic_proc *);
#define pic_deflibrary(pic, spec) do { \
pic_value libname = pic_read_cstr(pic, spec); \
if (pic_find_library(pic, libname) == NULL) { \
pic_make_library(pic, libname); \
} \
pic_in_library(pic, libname); \
#define pic_deflibrary(pic, lib) do { \
if (! pic_find_library(pic, lib)) { \
pic_make_library(pic, lib); \
} \
pic_in_library(pic, lib); \
} while (0)
void pic_warnf(pic_state *, const char *, ...);
@ -242,6 +241,8 @@ void pic_fprintf(pic_state *, struct pic_port *, const char *, ...);
pic_value pic_display(pic_state *, pic_value);
pic_value pic_fdisplay(pic_state *, pic_value, xFILE *);
struct pic_env *pic_library_environment(pic_state *, const char *);
#if DEBUG
# define pic_debug(pic,obj) pic_fwrite(pic,obj,xstderr)
# define pic_fdebug(pic,obj,file) pic_fwrite(pic,obj,file)

9
extlib/benz/include/picrin/khash.h
View File

@ -206,6 +206,15 @@ typedef khint_t khiter_t;
#define kh_ptr_hash_equal(a, b) ((a) == (b))
#define kh_int_hash_func(key) (int)(key)
#define kh_int_hash_equal(a, b) ((a) == (b))
PIC_INLINE int kh_str_hash_func(const char *s) {
int h = 0;
while (*s) {
h = (h << 5) - h + *s++;
}
return h;
}
#define kh_str_cmp_func(a, b) (strcmp((a), (b)) == 0)
/* --- END OF HASH FUNCTIONS --- */

26
extlib/benz/include/picrin/lib.h
View File

@ -1,26 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#ifndef PICRIN_LIB_H
#define PICRIN_LIB_H
#if defined(__cplusplus)
extern "C" {
#endif
struct pic_lib {
PIC_OBJECT_HEADER
pic_value name;
struct pic_env *env;
struct pic_dict *exports;
};
#define pic_lib_p(o) (pic_type(o) == PIC_TT_LIB)
#define pic_lib_ptr(o) ((struct pic_lib *)pic_ptr(o))
#if defined(__cplusplus)
}
#endif
#endif

2
extlib/benz/include/picrin/macro.h
View File

@ -15,7 +15,7 @@ struct pic_env {
PIC_OBJECT_HEADER
khash_t(env) map;
struct pic_env *up;
struct pic_string *prefix;
struct pic_string *lib;
};
#define pic_env_p(v) (pic_type(v) == PIC_TT_ENV)

14
extlib/benz/include/picrin/state.h
View File

@ -16,7 +16,11 @@ extern "C" {
#include "picrin/read.h"
#include "picrin/gc.h"
KHASH_DECLARE(oblist, struct pic_string *, pic_sym *)
struct pic_lib {
struct pic_string *name;
struct pic_env *env;
struct pic_dict *exports;
};
typedef struct pic_checkpoint {
PIC_OBJECT_HEADER
@ -37,6 +41,9 @@ typedef struct {
struct pic_context *up;
} pic_callinfo;
KHASH_DECLARE(oblist, struct pic_string *, pic_sym *)
KHASH_DECLARE(ltable, const char *, struct pic_lib)
struct pic_state {
pic_allocf allocf;
void *userdata;
@ -68,16 +75,13 @@ struct pic_state {
pic_sym *sCONS, *sCAR, *sCDR, *sNILP, *sSYMBOLP, *sPAIRP;
pic_sym *sADD, *sSUB, *sMUL, *sDIV, *sEQ, *sLT, *sLE, *sGT, *sGE, *sNOT;
struct pic_lib *PICRIN_BASE;
struct pic_lib *PICRIN_USER;
pic_value features;
khash_t(oblist) oblist; /* string to symbol */
int ucnt;
struct pic_weak *globals;
struct pic_weak *macros;
pic_value libs;
khash_t(ltable) ltable;
struct pic_list ireps; /* chain */
pic_reader reader;

4
extlib/benz/include/picrin/type.h
View File

@ -169,7 +169,6 @@ enum pic_tt {
PIC_TT_ERROR,
PIC_TT_ID,
PIC_TT_ENV,
PIC_TT_LIB,
PIC_TT_DATA,
PIC_TT_DICT,
PIC_TT_WEAK,
@ -197,7 +196,6 @@ struct pic_proc;
struct pic_port;
struct pic_error;
struct pic_env;
struct pic_lib;
/* set aliases to basic types */
typedef struct pic_symbol pic_sym;
@ -298,8 +296,6 @@ pic_type_repr(enum pic_tt tt)
return "proc";
case PIC_TT_ENV:
return "env";
case PIC_TT_LIB:
return "lib";
case PIC_TT_DATA:
return "data";
case PIC_TT_DICT:

176
extlib/benz/lib.c
View File

@ -4,22 +4,38 @@
#include "picrin.h"
KHASH_DEFINE(ltable, const char *, struct pic_lib, kh_str_hash_func, kh_str_cmp_func)
static struct pic_lib *
get_library_opt(pic_state *pic, const char *lib)
{
khash_t(ltable) *h = &pic->ltable;
khiter_t it;
it = kh_get(ltable, h, lib);
if (it == kh_end(h)) {
return NULL;
}
return &kh_val(h, it);
}
static struct pic_lib *
get_library(pic_state *pic, const char *lib)
{
struct pic_lib *libp;
if ((libp = get_library_opt(pic, lib)) == NULL) {
pic_errorf(pic, "library not found: %s", lib);
}
return libp;
}
static struct pic_env *
make_library_env(pic_state *pic, pic_value name)
make_library_env(pic_state *pic, struct pic_string *name)
{
struct pic_env *env;
pic_value dir, it;
struct pic_string *prefix = NULL;
pic_for_each (dir, name, it) {
if (prefix == NULL) {
prefix = pic_format(pic, "~a", dir);
} else {
prefix = pic_format(pic, "~a.~a", pic_obj_value(prefix), dir);
}
}
env = pic_make_topenv(pic, prefix);
env = pic_make_topenv(pic, name);
/* set up default environment */
pic_put_identifier(pic, (pic_id *)pic->sDEFINE_LIBRARY, pic->sDEFINE_LIBRARY, env);
@ -30,64 +46,76 @@ make_library_env(pic_state *pic, pic_value name)
return env;
}
struct pic_lib *
pic_make_library(pic_state *pic, pic_value name)
void
pic_make_library(pic_state *pic, const char *lib)
{
struct pic_lib *lib;
khash_t(ltable) *h = &pic->ltable;
const char *old_lib;
struct pic_string *name;
struct pic_env *env;
struct pic_dict *exports;
khiter_t it;
int ret;
if ((lib = pic_find_library(pic, name)) != NULL) {
pic_errorf(pic, "library name already in use: ~s", name);
if (pic->lib) {
old_lib = pic_current_library(pic);
}
name = pic_make_cstr(pic, lib);
env = make_library_env(pic, name);
exports = pic_make_dict(pic);
lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB);
lib->name = name;
lib->env = env;
lib->exports = exports;
it = kh_put(ltable, h, pic_str_cstr(pic, name), &ret);
if (ret == 0) { /* if exists */
pic_errorf(pic, "library name already in use: %s", lib);
}
/* register! */
pic->libs = pic_acons(pic, name, pic_obj_value(lib), pic->libs);
kh_val(h, it).name = name;
kh_val(h, it).env = env;
kh_val(h, it).exports = exports;
return lib;
if (pic->lib) {
pic->lib = get_library(pic, old_lib); /* ltable might be rehashed */
}
}
void
pic_in_library(pic_state *pic, pic_value name)
pic_in_library(pic_state *pic, const char *lib)
{
struct pic_lib *lib;
if ((lib = pic_find_library(pic, name)) == NULL) {
pic_errorf(pic, "library not found ~s", name);
}
pic->lib = lib;
pic->lib = get_library(pic, lib);
}
struct pic_lib *
pic_find_library(pic_state *pic, pic_value spec)
bool
pic_find_library(pic_state *pic, const char *lib)
{
pic_value v;
return get_library_opt(pic, lib) != NULL;
}
v = pic_assoc(pic, spec, pic->libs, NULL);
if (pic_false_p(v)) {
return NULL;
}
return pic_lib_ptr(pic_cdr(pic, v));
const char *
pic_current_library(pic_state *pic)
{
return pic_str_cstr(pic, pic->lib->name);
}
struct pic_env *
pic_library_environment(pic_state *pic, const char *lib)
{
return get_library(pic, lib)->env;
}
void
pic_import(pic_state *pic, struct pic_lib *lib)
pic_import(pic_state *pic, const char *lib)
{
pic_sym *name, *realname, *uid;
khiter_t it;
struct pic_lib *libp;
pic_dict_for_each (name, lib->exports, it) {
realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name));
libp = get_library(pic, lib);
if ((uid = pic_find_identifier(pic, (pic_id *)realname, lib->env)) == NULL) {
pic_dict_for_each (name, libp->exports, it) {
realname = pic_sym_ptr(pic_dict_ref(pic, libp->exports, name));
if ((uid = pic_find_identifier(pic, (pic_id *)realname, libp->env)) == NULL) {
pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname));
}
pic_put_identifier(pic, (pic_id *)name, uid, pic->lib->env);
@ -103,42 +131,38 @@ pic_export(pic_state *pic, pic_sym *name)
static pic_value
pic_lib_make_library(pic_state *pic)
{
pic_value name;
const char *lib;
pic_get_args(pic, "o", &name);
pic_get_args(pic, "z", &lib);
return pic_obj_value(pic_make_library(pic, name));
pic_make_library(pic, lib);
return pic_undef_value();
}
static pic_value
pic_lib_find_library(pic_state *pic)
{
pic_value name;
struct pic_lib *lib;
const char *lib;
pic_get_args(pic, "o", &name);
pic_get_args(pic, "z", &lib);
if ((lib = pic_find_library(pic, name)) == NULL) {
return pic_false_value();
}
return pic_obj_value(lib);
return pic_bool_value(pic_find_library(pic, lib));
}
static pic_value
pic_lib_current_library(pic_state *pic)
{
pic_value lib;
const char *lib;
int n;
n = pic_get_args(pic, "|o", &lib);
n = pic_get_args(pic, "|z", &lib);
if (n == 0) {
return pic_obj_value(pic->lib);
return pic_obj_value(pic->lib->name);
}
else {
pic_assert_type(pic, lib, lib);
pic->lib = pic_lib_ptr(lib);
pic_in_library(pic, lib);
return pic_undef_value();
}
@ -147,27 +171,25 @@ pic_lib_current_library(pic_state *pic)
static pic_value
pic_lib_library_import(pic_state *pic)
{
pic_value lib_opt;
const char *lib;
pic_sym *name, *realname, *uid, *alias = NULL;
struct pic_lib *lib;
struct pic_lib *libp;
pic_get_args(pic, "om|m", &lib_opt, &name, &alias);
pic_assert_type(pic, lib_opt, lib);
pic_get_args(pic, "zm|m", &lib, &name, &alias);
if (alias == NULL) {
alias = name;
}
lib = pic_lib_ptr(lib_opt);
libp = get_library(pic, lib);
if (! pic_dict_has(pic, lib->exports, name)) {
if (! pic_dict_has(pic, libp->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));
realname = pic_sym_ptr(pic_dict_ref(pic, libp->exports, name));
}
if ((uid = pic_find_identifier(pic, (pic_id *)realname, lib->env)) == NULL) {
if ((uid = pic_find_identifier(pic, (pic_id *)realname, libp->env)) == NULL) {
pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname));
} else {
pic_put_identifier(pic, (pic_id *)alias, uid, pic->lib->env);
@ -195,15 +217,17 @@ pic_lib_library_export(pic_state *pic)
static pic_value
pic_lib_library_exports(pic_state *pic)
{
pic_value lib, exports = pic_nil_value();
const char *lib;
pic_value exports = pic_nil_value();
pic_sym *sym;
khiter_t it;
struct pic_lib *libp;
pic_get_args(pic, "o", &lib);
pic_get_args(pic, "z", &lib);
pic_assert_type(pic, lib, lib);
libp = get_library(pic, lib);
pic_dict_for_each (sym, pic_lib_ptr(lib)->exports, it) {
pic_dict_for_each (sym, libp->exports, it) {
pic_push(pic, pic_obj_value(sym), exports);
}
@ -213,13 +237,11 @@ pic_lib_library_exports(pic_state *pic)
static pic_value
pic_lib_library_environment(pic_state *pic)
{
pic_value lib;
const char *lib;
pic_get_args(pic, "o", &lib);
pic_get_args(pic, "z", &lib);
pic_assert_type(pic, lib, lib);
return pic_obj_value(pic_lib_ptr(lib)->env);
return pic_obj_value(get_library(pic, lib)->env);
}
void

2
extlib/benz/load.c
View File

@ -11,7 +11,7 @@ pic_load(pic_state *pic, struct pic_port *port)
size_t ai = pic_gc_arena_preserve(pic);
while (! pic_eof_p(form = pic_read(pic, port))) {
pic_eval(pic, form, pic->lib);
pic_eval(pic, form, pic_current_library(pic));
pic_gc_arena_restore(pic, ai);
}

8
extlib/benz/macro.c
View File

@ -15,19 +15,19 @@ pic_make_env(pic_state *pic, struct pic_env *up)
env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV);
env->up = up;
env->prefix = NULL;
env->lib = NULL;
kh_init(env, &env->map);
return env;
}
struct pic_env *
pic_make_topenv(pic_state *pic, struct pic_string *prefix)
pic_make_topenv(pic_state *pic, struct pic_string *lib)
{
struct pic_env *env;
env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV);
env->up = NULL;
env->prefix = prefix;
env->lib = lib;
kh_init(env, &env->map);
return env;
}
@ -42,7 +42,7 @@ pic_add_identifier(pic_state *pic, pic_id *id, struct pic_env *env)
name = pic_identifier_name(pic, id);
if (env->up == NULL && pic_sym_p(pic_obj_value(id))) { /* toplevel & public */
str = pic_format(pic, "%s/%s", pic_str_cstr(pic, env->prefix), name);
str = pic_format(pic, "%s/%s", pic_str_cstr(pic, env->lib), name);
} else {
str = pic_format(pic, ".%s.%d", name, pic->ucnt++);
}

2
extlib/benz/port.c
View File

@ -172,7 +172,7 @@ pic_define_standard_port(pic_state *pic, const char *name, xFILE *file, int dir)
{ \
pic_value obj; \
\
obj = pic_funcall(pic, pic->PICRIN_BASE, var, 0); \
obj = pic_funcall(pic, "picrin.base", var, 0); \
\
return pic_port_ptr(obj); \
}

54
extlib/benz/proc.c
View File

@ -856,14 +856,30 @@ pic_vlambda(pic_state *pic, pic_func_t f, int n, va_list ap)
}
void
pic_define(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val)
pic_defun(pic_state *pic, const char *name, pic_func_t f)
{
pic_define(pic, pic_current_library(pic), name, pic_obj_value(pic_make_proc(pic, f, 0, NULL)));
pic_export(pic, pic_intern_cstr(pic, name));
}
void
pic_defvar(pic_state *pic, const char *name, pic_value init, struct pic_proc *conv)
{
pic_define(pic, pic_current_library(pic), name, pic_obj_value(pic_make_var(pic, init, conv)));
pic_export(pic, pic_intern_cstr(pic, name));
}
void
pic_define(pic_state *pic, const char *lib, const char *name, pic_value val)
{
pic_sym *sym, *uid;
struct pic_env *env;
sym = pic_intern_cstr(pic, name);
if ((uid = pic_find_identifier(pic, (pic_id *)sym, lib->env)) == NULL) {
uid = pic_add_identifier(pic, (pic_id *)sym, lib->env);
env = pic_library_environment(pic, lib);
if ((uid = pic_find_identifier(pic, (pic_id *)sym, env)) == NULL) {
uid = pic_add_identifier(pic, (pic_id *)sym, env);
} else {
if (pic_weak_has(pic, pic->globals, uid)) {
pic_warnf(pic, "redefining variable: ~s", pic_obj_value(uid));
@ -873,43 +889,33 @@ pic_define(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val)
pic_set(pic, lib, name, val);
}
void
pic_defun(pic_state *pic, const char *name, pic_func_t f)
{
pic_define(pic, pic->lib, name, pic_obj_value(pic_make_proc(pic, f, 0, NULL)));
pic_export(pic, pic_intern_cstr(pic, name));
}
void
pic_defvar(pic_state *pic, const char *name, pic_value init, struct pic_proc *conv)
{
pic_define(pic, pic->lib, name, pic_obj_value(pic_make_var(pic, init, conv)));
pic_export(pic, pic_intern_cstr(pic, name));
}
pic_value
pic_ref(pic_state *pic, struct pic_lib *lib, const char *name)
pic_ref(pic_state *pic, const char *lib, const char *name)
{
pic_sym *sym, *uid;
struct pic_env *env;
sym = pic_intern_cstr(pic, name);
if ((uid = pic_find_identifier(pic, (pic_id *)sym, lib->env)) == NULL) {
pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name);
env = pic_library_environment(pic, lib);
if ((uid = pic_find_identifier(pic, (pic_id *)sym, env)) == NULL) {
pic_errorf(pic, "symbol \"%s\" not defined in library %s", name, lib);
}
return vm_gref(pic, uid);
}
void
pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val)
pic_set(pic_state *pic, const char *lib, const char *name, pic_value val)
{
pic_sym *sym, *uid;
struct pic_env *env;
sym = pic_intern_cstr(pic, name);
if ((uid = pic_find_identifier(pic, (pic_id *)sym, lib->env)) == NULL) {
pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name);
env = pic_library_environment(pic, lib);
if ((uid = pic_find_identifier(pic, (pic_id *)sym, env)) == NULL) {
pic_errorf(pic, "symbol \"%s\" not defined in library %s", name, lib);
}
vm_gset(pic, uid, val);
@ -946,7 +952,7 @@ pic_closure_set(pic_state *pic, int n, pic_value v)
}
pic_value
pic_funcall(pic_state *pic, struct pic_lib *lib, const char *name, int n, ...)
pic_funcall(pic_state *pic, const char *lib, const char *name, int n, ...)
{
pic_value proc, r;
va_list ap;

17
extlib/benz/state.c
View File

@ -120,7 +120,7 @@ pic_init_core(pic_state *pic)
pic_init_features(pic);
pic_deflibrary(pic, "(picrin base)");
pic_deflibrary(pic, "picrin.base");
ai = pic_gc_arena_preserve(pic);
@ -268,7 +268,7 @@ pic_open(pic_allocf allocf, void *userdata)
pic->features = pic_nil_value();
/* libraries */
pic->libs = pic_nil_value();
kh_init(ltable, &pic->ltable);
pic->lib = NULL;
/* ireps */
@ -346,9 +346,8 @@ pic_open(pic_allocf allocf, void *userdata)
pic->ptable = pic_cons(pic, pic_obj_value(pic_make_weak(pic)), pic->ptable);
/* standard libraries */
pic->PICRIN_BASE = pic_make_library(pic, pic_read_cstr(pic, "(picrin base)"));
pic->PICRIN_USER = pic_make_library(pic, pic_read_cstr(pic, "(picrin user)"));
pic->lib = pic->PICRIN_USER;
pic_make_library(pic, "picrin.user");
pic_in_library(pic, "picrin.user");
pic_gc_arena_restore(pic, ai);
@ -376,7 +375,6 @@ pic_open(pic_allocf allocf, void *userdata)
void
pic_close(pic_state *pic)
{
khash_t(oblist) *h = &pic->oblist;
pic_allocf allocf = pic->allocf;
/* clear out root objects */
@ -388,7 +386,9 @@ pic_close(pic_state *pic)
pic->globals = NULL;
pic->macros = NULL;
pic->features = pic_nil_value();
pic->libs = pic_nil_value();
/* free all libraries */
kh_clear(ltable, &pic->ltable);
/* free all heap objects */
pic_gc(pic);
@ -420,7 +420,8 @@ pic_close(pic_state *pic)
allocf(pic->userdata, pic->xpbase, 0);
/* free global stacks */
kh_destroy(oblist, h);
kh_destroy(oblist, &pic->oblist);
kh_destroy(ltable, &pic->ltable);
/* free GC arena */
allocf(pic->userdata, pic->arena, 0);

4
extlib/benz/string.c
View File

@ -578,7 +578,7 @@ pic_str_string_map(pic_state *pic)
for (j = 0; j < argc; ++j) {
pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals);
}
val = pic_funcall(pic, pic->PICRIN_BASE, "apply", 2, pic_obj_value(proc), vals);
val = pic_funcall(pic, "picrin.base", "apply", 2, pic_obj_value(proc), vals);
pic_assert_type(pic, val, char);
buf[i] = pic_char(val);
@ -623,7 +623,7 @@ pic_str_string_for_each(pic_state *pic)
for (j = 0; j < argc; ++j) {
pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals);
}
pic_funcall(pic, pic->PICRIN_BASE, "apply", 2, pic_obj_value(proc), vals);
pic_funcall(pic, "picrin.base", "apply", 2, pic_obj_value(proc), vals);
}
return pic_undef_value();

4
extlib/benz/vector.c
View File

@ -240,7 +240,7 @@ pic_vec_vector_map(pic_state *pic)
for (j = 0; j < argc; ++j) {
pic_push(pic, pic_vec_ptr(argv[j])->data[i], vals);
}
vec->data[i] = pic_funcall(pic, pic->PICRIN_BASE, "apply", 2, pic_obj_value(proc), vals);
vec->data[i] = pic_funcall(pic, "picrin.base", "apply", 2, pic_obj_value(proc), vals);
}
return pic_obj_value(vec);
@ -269,7 +269,7 @@ pic_vec_vector_for_each(pic_state *pic)
for (j = 0; j < argc; ++j) {
pic_push(pic, pic_vec_ptr(argv[j])->data[i], vals);
}
pic_funcall(pic, pic->PICRIN_BASE, "apply", 2, pic_obj_value(proc), vals);
pic_funcall(pic, "picrin.base", "apply", 2, pic_obj_value(proc), vals);
}
return pic_undef_value();

5
src/main.c
View File

@ -22,7 +22,6 @@ int
main(int argc, char *argv[], char **envp)
{
pic_state *pic;
struct pic_lib *PICRIN_MAIN;
int status;
pic = pic_open(pic_default_allocf, NULL);
@ -34,9 +33,7 @@ main(int argc, char *argv[], char **envp)
pic_try {
pic_init_picrin(pic);
PICRIN_MAIN = pic_find_library(pic, pic_read_cstr(pic, "(picrin main)"));
pic_funcall(pic, PICRIN_MAIN, "main", 0);
pic_funcall(pic, "picrin.main", "main", 0);
status = 0;
}