diff --git a/.gitmodules b/.gitmodules index 25d3e4f0..e69de29b 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +0,0 @@ -[submodule "extlib/benz"] - path = extlib/benz - url = git://github.com/picrin-scheme/benz.git diff --git a/extlib/benz b/extlib/benz deleted file mode 160000 index 569b1ace..00000000 --- a/extlib/benz +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 569b1ace02e6a066b21f94dff23c4e01b8748bf0 diff --git a/extlib/benz/README.md b/extlib/benz/README.md new file mode 100644 index 00000000..81722f44 --- /dev/null +++ b/extlib/benz/README.md @@ -0,0 +1,120 @@ +# Benz + +Benz is a super tiny scheme interpreter intended to be embedded in other applications such as game engine and network server. It provides a subset language of R7RS with several useful extensions. By default, Benz just contains some C files and headers and this README file. In embedding, you only need to copy the files into the project and add `include` dir to the include path. + +Originally, Benz used to be the core component of [Picrin Scheme](https://github.com/picrin-scheme/picrin). They are currently maintained at separate repositories. + +## Example + +```c +#include + +#include "picrin.h" + +/* Simple REPL program */ + +int +main(int argc, char *argv[]) +{ + pic_state *pic; + pic_value expr; + + pic = pic_open(argc, argv, NULL); + + while (1) { + printf("> "); + + expr = pic_read(pic, pic_stdin(pic)); + + if (pic_eof_p(expr)) { + break; + } + + pic_printf(pic, "~s\n", pic_eval(pic, expr, pic->lib)); + } + + pic_close(pic); + + return 0; +} +``` + +## More Example + +Function binding is also easy. `pic_defun` defines a scheme procedure converting from a C function. In the native function, callee arguments can be taken with `pic_get_args`. `pic_get_args` gets arguments according to the format string. If actual arguments does not match a number or incompatible types, it will raise an exception. + +```c +#include "picrin.h" + +int fact(int i) { + return i == 1 ? 1 : i * fact(i - 1); +} + +pic_value factorial(pic_state *pic) { + int i; + + pic_get_args(pic, "i", &i); + + return pic_int_value(fact(i)); +} + +int +main(int argc, char *argv[]) +{ + pic_state *pic = pic_open(argc, argv, NULL); + + pic_defun(pic, "fact", factorial); /* define fact procedure */ + + pic_load_cstr(pic, "(display (fact 10))"); + + pic_close(pic); + + return 0; +} +``` + +## Language + +All procedures and syntaces are exported from a single library named `(picrin base)`. The complete list is found at https://gist.github.com/wasabiz/344d802a2340d1f734b7 . + +### call/cc + +Full continuation has many problems in embbeding into applications. By default, Benz's call/cc operator does not support continuation that can handle re-entering (it only supports escape continuations). To remove this restriction, please use an add-on provided from [Picrin Scheme's repository](https://github.com/picrin-scheme/picrin/tree/master/contrib/03.callcc). + +### Strings + +Benz utilize rope data structure to implement string type. Thanks to the implementation, string-append is guaranteed to be done in a constant time (so do string-copy, when ascii-only mode is enabled). In return for that, strings in benz are immutable by default. It does not provide mutation API (string-set!, string-copy! and string-fill! in R7RS). This restriction can be also removed with an add-on in [Picrin Scheme's repository](https://github.com/picrin-scheme/picrin/tree/master/contrib/03.mutable-string). + +### Dictionaries + +Dictionary is a hash table object. Its equivalence is tested with equal? procedure. + +### Attribute + +Benz has an facility to get or set metadata to any heap object. + +## Authors + +See https://github.com/picrin-scheme/benz and https://github.com/picrin-scheme/picrin for details. + +## LICENSE + +Copyright (c) 2013-2014 Yuichi Nishiwaki and other picrin contributors + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR +COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + diff --git a/extlib/benz/attr.c b/extlib/benz/attr.c new file mode 100644 index 00000000..e005bec2 --- /dev/null +++ b/extlib/benz/attr.c @@ -0,0 +1,50 @@ +#include "picrin.h" +#include "picrin/dict.h" + +struct pic_dict * +pic_attr(pic_state *pic, pic_value obj) +{ + xh_entry *e; + + if (pic_vtype(obj) != PIC_VTYPE_HEAP) { + pic_errorf(pic, "attribute: expected heap object, but got immediate value ~s", obj); + } + + e = xh_get_ptr(&pic->attrs, pic_ptr(obj)); + if (e == NULL) { + struct pic_dict *dict = pic_make_dict(pic); + + e = xh_put_ptr(&pic->attrs, pic_ptr(obj), &dict); + + assert(dict == xh_val(e, struct pic_dict *)); + } + return xh_val(e, struct pic_dict *); +} + +pic_value +pic_attr_ref(pic_state *pic, pic_value obj, const char *key) +{ + return pic_dict_ref(pic, pic_attr(pic, obj), pic_sym_value(pic_intern_cstr(pic, key))); +} + +void +pic_attr_set(pic_state *pic, pic_value obj, const char *key, pic_value v) +{ + pic_dict_set(pic, pic_attr(pic, obj), pic_sym_value(pic_intern_cstr(pic, key)), v); +} + +static pic_value +pic_attr_attribute(pic_state *pic) +{ + pic_value obj; + + pic_get_args(pic, "o", &obj); + + return pic_obj_value(pic_attr(pic, obj)); +} + +void +pic_init_attr(pic_state *pic) +{ + pic_defun(pic, "attribute", pic_attr_attribute); +} diff --git a/extlib/benz/blob.c b/extlib/benz/blob.c new file mode 100644 index 00000000..3e5b7723 --- /dev/null +++ b/extlib/benz/blob.c @@ -0,0 +1,266 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#include "picrin.h" +#include "picrin/blob.h" +#include "picrin/pair.h" + +struct pic_blob * +pic_make_blob(pic_state *pic, size_t len) +{ + struct pic_blob *bv; + + bv = (struct pic_blob *)pic_obj_alloc(pic, sizeof(struct pic_blob), PIC_TT_BLOB); + bv->data = pic_alloc(pic, len); + bv->len = len; + return bv; +} + +static pic_value +pic_blob_bytevector_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_blob_p(v)); +} + +static pic_value +pic_blob_bytevector(pic_state *pic) +{ + pic_value *argv; + size_t argc, i; + pic_blob *blob; + unsigned char *data; + + pic_get_args(pic, "*", &argc, &argv); + + blob = pic_make_blob(pic, argc); + + data = blob->data; + + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], int); + + if (pic_int(argv[i]) < 0 || pic_int(argv[i]) > 255) { + pic_errorf(pic, "byte out of range"); + } + + *data++ = (unsigned char)pic_int(argv[i]); + } + + return pic_obj_value(blob); +} + +static pic_value +pic_blob_make_bytevector(pic_state *pic) +{ + pic_blob *blob; + size_t k, i; + int b = 0; + + pic_get_args(pic, "k|i", &k, &b); + + if (b < 0 || b > 255) + pic_errorf(pic, "byte out of range"); + + blob = pic_make_blob(pic, k); + for (i = 0; i < k; ++i) { + blob->data[i] = (unsigned char)b; + } + + return pic_obj_value(blob); +} + +static pic_value +pic_blob_bytevector_length(pic_state *pic) +{ + struct pic_blob *bv; + + pic_get_args(pic, "b", &bv); + + return pic_size_value(bv->len); +} + +static pic_value +pic_blob_bytevector_u8_ref(pic_state *pic) +{ + struct pic_blob *bv; + int k; + + pic_get_args(pic, "bi", &bv, &k); + + return pic_int_value(bv->data[k]); +} + +static pic_value +pic_blob_bytevector_u8_set(pic_state *pic) +{ + struct pic_blob *bv; + int k, v; + + pic_get_args(pic, "bii", &bv, &k, &v); + + if (v < 0 || v > 255) + pic_errorf(pic, "byte out of range"); + + bv->data[k] = (unsigned char)v; + return pic_none_value(); +} + +static pic_value +pic_blob_bytevector_copy_i(pic_state *pic) +{ + pic_blob *to, *from; + int n; + size_t at, start, end; + + n = pic_get_args(pic, "bkb|kk", &to, &at, &from, &start, &end); + + switch (n) { + case 3: + start = 0; + case 4: + end = from->len; + } + + if (to == from && (start <= at && at < end)) { + /* copy in reversed order */ + at += end - start; + while (start < end) { + to->data[--at] = from->data[--end]; + } + return pic_none_value(); + } + + while (start < end) { + to->data[at++] = from->data[start++]; + } + + return pic_none_value(); +} + +static pic_value +pic_blob_bytevector_copy(pic_state *pic) +{ + pic_blob *from, *to; + int n; + size_t start, end, i = 0; + + n = pic_get_args(pic, "b|kk", &from, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = from->len; + } + + if (end < start) { + pic_errorf(pic, "make-bytevector: end index must not be less than start index"); + } + + to = pic_make_blob(pic, end - start); + while (start < end) { + to->data[i++] = from->data[start++]; + } + + return pic_obj_value(to); +} + +static pic_value +pic_blob_bytevector_append(pic_state *pic) +{ + size_t argc, i, j, len; + pic_value *argv; + pic_blob *blob; + + pic_get_args(pic, "*", &argc, &argv); + + len = 0; + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], blob); + len += pic_blob_ptr(argv[i])->len; + } + + blob = pic_make_blob(pic, len); + + len = 0; + for (i = 0; i < argc; ++i) { + for (j = 0; j < pic_blob_ptr(argv[i])->len; ++j) { + blob->data[len + j] = pic_blob_ptr(argv[i])->data[j]; + } + len += pic_blob_ptr(argv[i])->len; + } + + return pic_obj_value(blob); +} + +static pic_value +pic_blob_list_to_bytevector(pic_state *pic) +{ + pic_blob *blob; + unsigned char *data; + pic_value list, e; + + pic_get_args(pic, "o", &list); + + blob = pic_make_blob(pic, pic_length(pic, list)); + + data = blob->data; + + pic_for_each (e, list) { + pic_assert_type(pic, e, int); + + if (pic_int(e) < 0 || pic_int(e) > 255) + pic_errorf(pic, "byte out of range"); + + *data++ = (unsigned char)pic_int(e); + } + return pic_obj_value(blob); +} + +static pic_value +pic_blob_bytevector_to_list(pic_state *pic) +{ + pic_blob *blob; + pic_value list; + int n; + size_t start, end, i; + + n = pic_get_args(pic, "b|kk", &blob, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = blob->len; + } + + list = pic_nil_value(); + + for (i = start; i < end; ++i) { + pic_push(pic, pic_int_value(blob->data[i]), list); + } + return pic_reverse(pic, list); +} + +void +pic_init_blob(pic_state *pic) +{ + pic_defun(pic, "bytevector?", pic_blob_bytevector_p); + pic_defun(pic, "bytevector", pic_blob_bytevector); + pic_defun(pic, "make-bytevector", pic_blob_make_bytevector); + pic_defun(pic, "bytevector-length", pic_blob_bytevector_length); + pic_defun(pic, "bytevector-u8-ref", pic_blob_bytevector_u8_ref); + pic_defun(pic, "bytevector-u8-set!", pic_blob_bytevector_u8_set); + pic_defun(pic, "bytevector-copy!", pic_blob_bytevector_copy_i); + pic_defun(pic, "bytevector-copy", pic_blob_bytevector_copy); + pic_defun(pic, "bytevector-append", pic_blob_bytevector_append); + pic_defun(pic, "bytevector->list", pic_blob_bytevector_to_list); + pic_defun(pic, "list->bytevector", pic_blob_list_to_bytevector); +} diff --git a/extlib/benz/bool.c b/extlib/benz/bool.c new file mode 100644 index 00000000..8f8c75f1 --- /dev/null +++ b/extlib/benz/bool.c @@ -0,0 +1,201 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#include "picrin.h" +#include "picrin/pair.h" +#include "picrin/vector.h" +#include "picrin/blob.h" +#include "picrin/string.h" + +static bool +str_equal_p(struct pic_string *str1, struct pic_string *str2) +{ + return pic_strcmp(str1, str2) == 0; +} + +static bool +blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2) +{ + size_t i; + + if (blob1->len != blob2->len) { + return false; + } + for (i = 0; i < blob1->len; ++i) { + if (blob1->data[i] != blob2->data[i]) + return false; + } + return true; +} + +static bool +internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *ht) +{ + pic_value local = pic_nil_value(); + size_t c; + + if (depth > 10) { + if (depth > 200) { + pic_errorf(pic, "Stack overflow in equal\n"); + } + if (pic_pair_p(x) || pic_vec_p(x)) { + if (xh_get_ptr(ht, pic_obj_ptr(x)) != NULL) { + return true; /* `x' was seen already. */ + } else { + xh_put_ptr(ht, pic_obj_ptr(x), NULL); + } + } + } + + c = 0; + + LOOP: + + if (pic_eqv_p(x, y)) + return true; + + if (pic_type(x) != pic_type(y)) + return false; + + switch (pic_type(x)) { + case PIC_TT_STRING: + return str_equal_p(pic_str_ptr(x), pic_str_ptr(y)); + + case PIC_TT_BLOB: + return blob_equal_p(pic_blob_ptr(x), pic_blob_ptr(y)); + + case PIC_TT_PAIR: { + if (pic_nil_p(local)) { + local = x; + } + if (internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, ht)) { + x = pic_cdr(pic, x); + y = pic_cdr(pic, y); + + c++; + + if (c == 2) { + c = 0; + local = pic_cdr(pic, local); + if (pic_eq_p(local, x)) { + return true; + } + } + goto LOOP; + } else { + return false; + } + } + case PIC_TT_VECTOR: { + size_t i; + struct pic_vector *u, *v; + + u = pic_vec_ptr(x); + v = pic_vec_ptr(y); + + if (u->len != v->len) { + return false; + } + for (i = 0; i < u->len; ++i) { + if (! internal_equal_p(pic, u->data[i], v->data[i], depth + 1, ht)) + return false; + } + return true; + } + default: + return false; + } +} + +bool +pic_equal_p(pic_state *pic, pic_value x, pic_value y){ + xhash ht; + + xh_init_ptr(&ht, 0); + + return internal_equal_p(pic, x, y, 0, &ht); +} + +static pic_value +pic_bool_eq_p(pic_state *pic) +{ + pic_value x, y; + + pic_get_args(pic, "oo", &x, &y); + + return pic_bool_value(pic_eq_p(x, y)); +} + +static pic_value +pic_bool_eqv_p(pic_state *pic) +{ + pic_value x, y; + + pic_get_args(pic, "oo", &x, &y); + + return pic_bool_value(pic_eqv_p(x, y)); +} + +static pic_value +pic_bool_equal_p(pic_state *pic) +{ + pic_value x, y; + + pic_get_args(pic, "oo", &x, &y); + + return pic_bool_value(pic_equal_p(pic, x, y)); +} + +static pic_value +pic_bool_not(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_false_p(v) ? pic_true_value() : pic_false_value(); +} + +static pic_value +pic_bool_boolean_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return (pic_true_p(v) || pic_false_p(v)) ? pic_true_value() : pic_false_value(); +} + +static pic_value +pic_bool_boolean_eq_p(pic_state *pic) +{ + size_t argc, i; + pic_value *argv; + + pic_get_args(pic, "*", &argc, &argv); + + for (i = 0; i < argc; ++i) { + if (! (pic_true_p(argv[i]) || pic_false_p(argv[i]))) { + return pic_false_value(); + } + if (! pic_eq_p(argv[i], argv[0])) { + return pic_false_value(); + } + } + return pic_true_value(); +} + +void +pic_init_bool(pic_state *pic) +{ + pic_defun(pic, "eq?", pic_bool_eq_p); + pic_defun(pic, "eqv?", pic_bool_eqv_p); + pic_defun(pic, "equal?", pic_bool_equal_p); + + pic_defun(pic, "not", pic_bool_not); + pic_defun(pic, "boolean?", pic_bool_boolean_p); + pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p); +} diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c new file mode 100644 index 00000000..2c0d06b6 --- /dev/null +++ b/extlib/benz/boot.c @@ -0,0 +1,769 @@ +#if 0 + +=pod +/* +=cut + +use strict; + +my $src = <<'EOL'; + +(define-library (picrin base) + + (define (memoize f) + "memoize on symbols" + (define cache (make-dictionary)) + (lambda (sym) + (call-with-values (lambda () (dictionary-ref cache sym)) + (lambda (value exists) + (if exists + value + (begin + (define val (f sym)) + (dictionary-set! cache sym val) + val)))))) + + (define (er-macro-transformer f) + (lambda (expr use-env mac-env) + + (define rename + (memoize + (lambda (sym) + (make-identifier sym mac-env)))) + + (define (compare x y) + (if (not (symbol? x)) + #f + (if (not (symbol? y)) + #f + (identifier=? use-env x use-env y)))) + + (f expr rename compare))) + + (define-syntax syntax-error + (er-macro-transformer + (lambda (expr rename compare) + (apply error (cdr expr))))) + + (define-syntax define-auxiliary-syntax + (er-macro-transformer + (lambda (expr r c) + (list (r 'define-syntax) (cadr expr) + (list (r 'lambda) '_ + (list (r 'error) "invalid use of auxiliary syntax")))))) + + (define-auxiliary-syntax else) + (define-auxiliary-syntax =>) + (define-auxiliary-syntax unquote) + (define-auxiliary-syntax unquote-splicing) + + (define-syntax let + (er-macro-transformer + (lambda (expr r compare) + (if (symbol? (cadr expr)) + (begin + (define name (car (cdr expr))) + (define bindings (car (cdr (cdr expr)))) + (define body (cdr (cdr (cdr expr)))) + (list (r 'let) '() + (list (r 'define) name + (cons (r 'lambda) (cons (map car bindings) body))) + (cons name (map cadr bindings)))) + (begin + (set! bindings (cadr expr)) + (set! body (cddr expr)) + (cons (cons (r 'lambda) (cons (map car bindings) body)) + (map cadr bindings))))))) + + (define-syntax cond + (er-macro-transformer + (lambda (expr r compare) + (let ((clauses (cdr expr))) + (if (null? clauses) + #f + (begin + (define clause (car clauses)) + (if (compare (r 'else) (car clause)) + (cons (r 'begin) (cdr clause)) + (if (if (>= (length clause) 2) + (compare (r '=>) (list-ref clause 1)) + #f) + (list (r 'let) (list (list (r 'x) (car clause))) + (list (r 'if) (r 'x) + (list (list-ref clause 2) (r 'x)) + (cons (r 'cond) (cdr clauses)))) + (list (r 'if) (car clause) + (cons (r 'begin) (cdr clause)) + (cons (r 'cond) (cdr clauses))))))))))) + + (define-syntax and + (er-macro-transformer + (lambda (expr r compare) + (let ((exprs (cdr expr))) + (cond + ((null? exprs) + #t) + ((= (length exprs) 1) + (car exprs)) + (else + (list (r 'let) (list (list (r 'it) (car exprs))) + (list (r 'if) (r 'it) + (cons (r 'and) (cdr exprs)) + (r 'it))))))))) + + (define-syntax or + (er-macro-transformer + (lambda (expr r compare) + (let ((exprs (cdr expr))) + (cond + ((null? exprs) + #t) + ((= (length exprs) 1) + (car exprs)) + (else + (list (r 'let) (list (list (r 'it) (car exprs))) + (list (r 'if) (r 'it) + (r 'it) + (cons (r 'or) (cdr exprs)))))))))) + + (define-syntax quasiquote + (er-macro-transformer + (lambda (form rename compare) + + (define (quasiquote? form) + (and (pair? form) (compare (car form) (rename 'quasiquote)))) + + (define (unquote? form) + (and (pair? form) (compare (car form) (rename 'unquote)))) + + (define (unquote-splicing? form) + (and (pair? form) (pair? (car form)) + (compare (car (car form)) (rename 'unquote-splicing)))) + + (define (qq depth expr) + (cond + ;; unquote + ((unquote? expr) + (if (= depth 1) + (car (cdr expr)) + (list (rename 'list) + (list (rename 'quote) (rename 'unquote)) + (qq (- depth 1) (car (cdr expr)))))) + ;; unquote-splicing + ((unquote-splicing? expr) + (if (= depth 1) + (list (rename 'append) + (car (cdr (car expr))) + (qq depth (cdr expr))) + (list (rename 'cons) + (list (rename 'list) + (list (rename 'quote) (rename 'unquote-splicing)) + (qq (- depth 1) (car (cdr (car expr))))) + (qq depth (cdr expr))))) + ;; quasiquote + ((quasiquote? expr) + (list (rename 'list) + (list (rename 'quote) (rename 'quasiquote)) + (qq (+ depth 1) (car (cdr expr))))) + ;; list + ((pair? expr) + (list (rename 'cons) + (qq depth (car expr)) + (qq depth (cdr expr)))) + ;; vector + ((vector? expr) + (list (rename 'list->vector) (qq depth (vector->list expr)))) + ;; simple datum + (else + (list (rename 'quote) expr)))) + + (let ((x (cadr form))) + (qq 1 x))))) + + (define-syntax let* + (er-macro-transformer + (lambda (form r compare) + (let ((bindings (cadr form)) + (body (cddr form))) + (if (null? bindings) + `(,(r 'let) () ,@body) + `(,(r 'let) ((,(caar bindings) + ,@(cdar bindings))) + (,(r 'let*) (,@(cdr bindings)) + ,@body))))))) + + (define-syntax letrec* + (er-macro-transformer + (lambda (form r compare) + (let ((bindings (cadr form)) + (body (cddr form))) + (let ((vars (map (lambda (v) `(,v #f)) (map car bindings))) + (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings))) + `(,(r 'let) (,@vars) + ,@initials + ,@body)))))) + + (define-syntax letrec + (er-macro-transformer + (lambda (form rename compare) + `(,(rename 'letrec*) ,@(cdr form))))) + + (define-syntax let*-values + (er-macro-transformer + (lambda (form r c) + (let ((formals (cadr form))) + (if (null? formals) + `(,(r 'let) () ,@(cddr form)) + `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals)) + (,(r 'lambda) (,@(caar formals)) + (,(r 'let*-values) (,@(cdr formals)) + ,@(cddr form))))))))) + + (define-syntax let-values + (er-macro-transformer + (lambda (form r c) + `(,(r 'let*-values) ,@(cdr form))))) + + (define-syntax define-values + (er-macro-transformer + (lambda (form r compare) + (let ((formal (cadr form)) + (exprs (cddr form))) + `(,(r 'begin) + ,@(let loop ((formal formal)) + (if (not (pair? formal)) + (if (symbol? formal) + `((,(r 'define) ,formal #f)) + '()) + `((,(r 'define) ,(car formal) #f) . ,(loop (cdr formal))))) + (,(r 'call-with-values) (,(r 'lambda) () ,@exprs) + (,(r 'lambda) ,(r 'args) + ,@(let loop ((formal formal) (args (r 'args))) + (if (not (pair? formal)) + (if (symbol? formal) + `((,(r 'set!) ,formal ,args)) + '()) + `((,(r 'set!) ,(car formal) (,(r 'car) ,args)) + ,@(loop (cdr formal) `(,(r 'cdr) ,args)))))))))))) + + (define-syntax do + (er-macro-transformer + (lambda (form r compare) + (let ((bindings (car (cdr form))) + (finish (car (cdr (cdr form)))) + (body (cdr (cdr (cdr form))))) + `(,(r 'let) ,(r 'loop) ,(map (lambda (x) + (list (car x) (cadr x))) + bindings) + (,(r 'if) ,(car finish) + (,(r 'begin) ,@(cdr finish)) + (,(r 'begin) ,@body + (,(r 'loop) ,@(map (lambda (x) + (if (null? (cddr x)) + (car x) + (car (cddr x)))) + bindings))))))))) + + (define-syntax when + (er-macro-transformer + (lambda (expr rename compare) + (let ((test (cadr expr)) + (body (cddr expr))) + `(,(rename 'if) ,test + (,(rename 'begin) ,@body) + #f))))) + + (define-syntax unless + (er-macro-transformer + (lambda (expr rename compare) + (let ((test (cadr expr)) + (body (cddr expr))) + `(,(rename 'if) ,test + #f + (,(rename 'begin) ,@body)))))) + + (define-syntax case + (er-macro-transformer + (lambda (expr r compare) + (let ((key (cadr expr)) + (clauses (cddr expr))) + `(,(r 'let) ((,(r 'key) ,key)) + ,(let loop ((clauses clauses)) + (if (null? clauses) + #f + (begin + (define clause (car clauses)) + `(,(r 'if) ,(if (compare (r 'else) (car clause)) + '#t + `(,(r 'or) + ,@(map (lambda (x) + `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x))) + (car clause)))) + ,(if (compare (r '=>) (list-ref clause 1)) + `(,(list-ref clause 2) ,(r 'key)) + `(,(r 'begin) ,@(cdr clause))) + ,(loop (cdr clauses))))))))))) + + (define (dynamic-bind parameters values body) + (let* ((old-bindings + (current-dynamic-environment)) + (binding + (let ((dict (dictionary))) + (for-each + (lambda (parameter value) + (dictionary-set! dict parameter (list (parameter value #f)))) + parameters + values) + dict)) + (new-bindings + (cons binding old-bindings))) + (dynamic-wind + (lambda () (current-dynamic-environment new-bindings)) + body + (lambda () (current-dynamic-environment old-bindings))))) + + (define-syntax parameterize + (er-macro-transformer + (lambda (form r compare) + (let ((formal (cadr form)) + (body (cddr form))) + `(,(r 'dynamic-bind) + (list ,@(map car formal)) + (list ,@(map cadr formal)) + (,(r 'lambda) () ,@body)))))) + + (define-syntax letrec-syntax + (er-macro-transformer + (lambda (form r c) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + `(let () + ,@(map (lambda (x) + `(,(r 'define-syntax) ,(car x) ,(cadr x))) + formal) + ,@body))))) + + (define-syntax let-syntax + (er-macro-transformer + (lambda (form r c) + `(,(r '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 + let-syntax letrec-syntax + syntax-error)) + +EOL + +open IN, "./boot.c"; +my @data = ; +close IN; + +open STDOUT, ">", "./boot.c"; + +foreach (@data) { + print; + last if $_ eq "#---END---\n"; +} + +print "\n#endif\n\n"; + +print <)\n" +" (define-auxiliary-syntax unquote)\n" +" (define-auxiliary-syntax unquote-splicing)\n" +"\n" +" (define-syntax let\n" +" (er-macro-transformer\n" +" (lambda (expr r compare)\n" +" (if (symbol? (cadr expr))\n" +" (begin\n" +" (define name (car (cdr expr)))\n" +" (define bindings (car (cdr (cdr expr))))\n" +" (define body (cdr (cdr (cdr expr))))\n" +" (list (r 'let) '()\n" +" (list (r 'define) name\n" +" (cons (r 'lambda) (cons (map car bindings) body)))\n" +" (cons name (map cadr bindings))))\n" +" (begin\n" +" (set! bindings (cadr expr))\n" +" (set! body (cddr expr))\n" +" (cons (cons (r 'lambda) (cons (map car bindings) body))\n" +" (map cadr bindings)))))))\n" +"\n" +" (define-syntax cond\n" +" (er-macro-transformer\n" +" (lambda (expr r compare)\n" +" (let ((clauses (cdr expr)))\n" +" (if (null? clauses)\n" +" #f\n" +" (begin\n" +" (define clause (car clauses))\n" +" (if (compare (r 'else) (car clause))\n" +" (cons (r 'begin) (cdr clause))\n" +" (if (if (>= (length clause) 2)\n" +" (compare (r '=>) (list-ref clause 1))\n" +" #f)\n" +" (list (r 'let) (list (list (r 'x) (car clause)))\n" +" (list (r 'if) (r 'x)\n" +" (list (list-ref clause 2) (r 'x))\n" +" (cons (r 'cond) (cdr clauses))))\n" +" (list (r 'if) (car clause)\n" +" (cons (r 'begin) (cdr clause))\n" +" (cons (r 'cond) (cdr clauses)))))))))))\n" +"\n" +" (define-syntax and\n" +" (er-macro-transformer\n" +" (lambda (expr r compare)\n" +" (let ((exprs (cdr expr)))\n" +" (cond\n" +" ((null? exprs)\n" +" #t)\n" +" ((= (length exprs) 1)\n" +" (car exprs))\n" +" (else\n" +" (list (r 'let) (list (list (r 'it) (car exprs)))\n" +" (list (r 'if) (r 'it)\n" +" (cons (r 'and) (cdr exprs))\n" +" (r 'it)))))))))\n" +"\n" +" (define-syntax or\n" +" (er-macro-transformer\n" +" (lambda (expr r compare)\n" +" (let ((exprs (cdr expr)))\n" +" (cond\n" +" ((null? exprs)\n" +" #t)\n" +" ((= (length exprs) 1)\n" +" (car exprs))\n" +" (else\n" +" (list (r 'let) (list (list (r 'it) (car exprs)))\n" +" (list (r 'if) (r 'it)\n" +" (r 'it)\n" +" (cons (r 'or) (cdr exprs))))))))))\n" +"\n" +" (define-syntax quasiquote\n" +" (er-macro-transformer\n" +" (lambda (form rename compare)\n" +"\n" +" (define (quasiquote? form)\n" +" (and (pair? form) (compare (car form) (rename 'quasiquote))))\n" +"\n" +" (define (unquote? form)\n" +" (and (pair? form) (compare (car form) (rename 'unquote))))\n" +"\n" +" (define (unquote-splicing? form)\n" +" (and (pair? form) (pair? (car form))\n" +" (compare (car (car form)) (rename 'unquote-splicing))))\n" +"\n" +" (define (qq depth expr)\n" +" (cond\n" +" ;; unquote\n" +" ((unquote? expr)\n" +" (if (= depth 1)\n" +" (car (cdr expr))\n" +" (list (rename 'list)\n" +" (list (rename 'quote) (rename 'unquote))\n" +" (qq (- depth 1) (car (cdr expr))))))\n" +" ;; unquote-splicing\n" +" ((unquote-splicing? expr)\n" +" (if (= depth 1)\n" +" (list (rename 'append)\n" +" (car (cdr (car expr)))\n" +" (qq depth (cdr expr)))\n" +" (list (rename 'cons)\n" +" (list (rename 'list)\n" +" (list (rename 'quote) (rename 'unquote-splicing))\n" +" (qq (- depth 1) (car (cdr (car expr)))))\n" +" (qq depth (cdr expr)))))\n" +" ;; quasiquote\n" +" ((quasiquote? expr)\n" +" (list (rename 'list)\n" +" (list (rename 'quote) (rename 'quasiquote))\n" +" (qq (+ depth 1) (car (cdr expr)))))\n" +" ;; list\n" +" ((pair? expr)\n" +" (list (rename 'cons)\n" +" (qq depth (car expr))\n" +" (qq depth (cdr expr))))\n" +" ;; vector\n" +" ((vector? expr)\n" +" (list (rename 'list->vector) (qq depth (vector->list expr))))\n" +" ;; simple datum\n" +" (else\n" +" (list (rename 'quote) expr))))\n" +"\n" +" (let ((x (cadr form)))\n" +" (qq 1 x)))))\n" +"\n" +" (define-syntax let*\n" +" (er-macro-transformer\n" +" (lambda (form r compare)\n" +" (let ((bindings (cadr form))\n" +" (body (cddr form)))\n" +" (if (null? bindings)\n" +" `(,(r 'let) () ,@body)\n" +" `(,(r 'let) ((,(caar bindings)\n" +" ,@(cdar bindings)))\n" +" (,(r 'let*) (,@(cdr bindings))\n" +" ,@body)))))))\n" +"\n" +" (define-syntax letrec*\n" +" (er-macro-transformer\n" +" (lambda (form r compare)\n" +" (let ((bindings (cadr form))\n" +" (body (cddr form)))\n" +" (let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))\n" +" (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))\n" +" `(,(r 'let) (,@vars)\n" +" ,@initials\n" +" ,@body))))))\n" +"\n" +" (define-syntax letrec\n" +" (er-macro-transformer\n" +" (lambda (form rename compare)\n" +" `(,(rename 'letrec*) ,@(cdr form)))))\n" +"\n" +" (define-syntax let*-values\n" +" (er-macro-transformer\n" +" (lambda (form r c)\n" +" (let ((formals (cadr form)))\n" +" (if (null? formals)\n" +" `(,(r 'let) () ,@(cddr form))\n" +" `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals))\n" +" (,(r 'lambda) (,@(caar formals))\n" +" (,(r 'let*-values) (,@(cdr formals))\n" +" ,@(cddr form)))))))))\n" +"\n" +" (define-syntax let-values\n" +" (er-macro-transformer\n" +" (lambda (form r c)\n" +" `(,(r 'let*-values) ,@(cdr form)))))\n" +"\n" +" (define-syntax define-values\n" +" (er-macro-transformer\n" +" (lambda (form r compare)\n" +" (let ((formal (cadr form))\n" +" (exprs (cddr form)))\n" +" `(,(r 'begin)\n" +" ,@(let loop ((formal formal))\n" +" (if (not (pair? formal))\n" +" (if (symbol? formal)\n" +" `((,(r 'define) ,formal #f))\n" +" '())\n" +" `((,(r 'define) ,(car formal) #f) . ,(loop (cdr formal)))))\n" +" (,(r 'call-with-values) (,(r 'lambda) () ,@exprs)\n" +" (,(r 'lambda) ,(r 'args)\n" +" ,@(let loop ((formal formal) (args (r 'args)))\n" +" (if (not (pair? formal))\n" +" (if (symbol? formal)\n" +" `((,(r 'set!) ,formal ,args))\n" +" '())\n" +" `((,(r 'set!) ,(car formal) (,(r 'car) ,args))\n" +" ,@(loop (cdr formal) `(,(r 'cdr) ,args))))))))))))\n" +"\n" +" (define-syntax do\n" +" (er-macro-transformer\n" +" (lambda (form r compare)\n" +" (let ((bindings (car (cdr form)))\n" +" (finish (car (cdr (cdr form))))\n" +" (body (cdr (cdr (cdr form)))))\n" +" `(,(r 'let) ,(r 'loop) ,(map (lambda (x)\n" +" (list (car x) (cadr x)))\n" +" bindings)\n" +" (,(r 'if) ,(car finish)\n" +" (,(r 'begin) ,@(cdr finish))\n" +" (,(r 'begin) ,@body\n" +" (,(r 'loop) ,@(map (lambda (x)\n" +" (if (null? (cddr x))\n" +" (car x)\n" +" (car (cddr x))))\n" +" bindings)))))))))\n" +"\n" +" (define-syntax when\n" +" (er-macro-transformer\n" +" (lambda (expr rename compare)\n" +" (let ((test (cadr expr))\n" +" (body (cddr expr)))\n" +" `(,(rename 'if) ,test\n" +" (,(rename 'begin) ,@body)\n" +" #f)))))\n" +"\n" +" (define-syntax unless\n" +" (er-macro-transformer\n" +" (lambda (expr rename compare)\n" +" (let ((test (cadr expr))\n" +" (body (cddr expr)))\n" +" `(,(rename 'if) ,test\n" +" #f\n" +" (,(rename 'begin) ,@body))))))\n" +"\n" +" (define-syntax case\n" +" (er-macro-transformer\n" +" (lambda (expr r compare)\n" +" (let ((key (cadr expr))\n" +" (clauses (cddr expr)))\n" +" `(,(r 'let) ((,(r 'key) ,key))\n" +" ,(let loop ((clauses clauses))\n" +" (if (null? clauses)\n" +" #f\n" +" (begin\n" +" (define clause (car clauses))\n" +" `(,(r 'if) ,(if (compare (r 'else) (car clause))\n" +" '#t\n" +" `(,(r 'or)\n" +" ,@(map (lambda (x)\n" +" `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))\n" +" (car clause))))\n" +" ,(if (compare (r '=>) (list-ref clause 1))\n" +" `(,(list-ref clause 2) ,(r 'key))\n" +" `(,(r 'begin) ,@(cdr clause)))\n" +" ,(loop (cdr clauses)))))))))))\n" +"\n" +" (define (dynamic-bind parameters values body)\n" +" (let* ((old-bindings\n" +" (current-dynamic-environment))\n" +" (binding\n" +" (let ((dict (dictionary)))\n" +" (for-each\n" +" (lambda (parameter value)\n" +" (dictionary-set! dict parameter (list (parameter value #f))))\n" +" parameters\n" +" values)\n" +" dict))\n" +" (new-bindings\n" +" (cons binding old-bindings)))\n" +" (dynamic-wind\n" +" (lambda () (current-dynamic-environment new-bindings))\n" +" body\n" +" (lambda () (current-dynamic-environment old-bindings)))))\n" +"\n" +" (define-syntax parameterize\n" +" (er-macro-transformer\n" +" (lambda (form r compare)\n" +" (let ((formal (cadr form))\n" +" (body (cddr form)))\n" +" `(,(r 'dynamic-bind)\n" +" (list ,@(map car formal))\n" +" (list ,@(map cadr formal))\n" +" (,(r 'lambda) () ,@body))))))\n" +"\n" +" (define-syntax letrec-syntax\n" +" (er-macro-transformer\n" +" (lambda (form r c)\n" +" (let ((formal (car (cdr form)))\n" +" (body (cdr (cdr form))))\n" +" `(let ()\n" +" ,@(map (lambda (x)\n" +" `(,(r 'define-syntax) ,(car x) ,(cadr x)))\n" +" formal)\n" +" ,@body)))))\n" +"\n" +" (define-syntax let-syntax\n" +" (er-macro-transformer\n" +" (lambda (form r c)\n" +" `(,(r 'letrec-syntax) ,@(cdr 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" +" let-syntax letrec-syntax\n" +" syntax-error))\n" +; + +#if 0 +Local Variables: +mode: scheme +End: + +=cut +#endif diff --git a/extlib/benz/char.c b/extlib/benz/char.c new file mode 100644 index 00000000..d9c675e7 --- /dev/null +++ b/extlib/benz/char.c @@ -0,0 +1,85 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" + +static pic_value +pic_char_char_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_char_p(v) ? pic_true_value() : pic_false_value(); +} + +static pic_value +pic_char_char_to_integer(pic_state *pic) +{ + char c; + + pic_get_args(pic, "c", &c); + + return pic_int_value(c); +} + +static pic_value +pic_char_integer_to_char(pic_state *pic) +{ + int i; + + pic_get_args(pic, "i", &i); + + if (i < 0 || i > 127) { + pic_errorf(pic, "integer->char: integer out of char range: %d", i); + } + + return pic_char_value((char)i); +} + +#define DEFINE_CHAR_CMP(op, name) \ + static pic_value \ + pic_char_##name##_p(pic_state *pic) \ + { \ + size_t argc, i; \ + pic_value *argv; \ + char c, d; \ + \ + pic_get_args(pic, "cc*", &c, &d, &argc, &argv); \ + \ + if (! (c op d)) \ + return pic_false_value(); \ + \ + for (i = 0; i < argc; ++i) { \ + c = d; \ + if (pic_char_p(argv[i])) \ + d = pic_char(argv[i]); \ + else \ + pic_errorf(pic, #op ": char required"); \ + \ + if (! (c op d)) \ + return pic_false_value(); \ + } \ + \ + return pic_true_value(); \ + } + +DEFINE_CHAR_CMP(==, eq) +DEFINE_CHAR_CMP(<, lt) +DEFINE_CHAR_CMP(>, gt) +DEFINE_CHAR_CMP(<=, le) +DEFINE_CHAR_CMP(>=, ge) + +void +pic_init_char(pic_state *pic) +{ + pic_defun(pic, "char?", pic_char_char_p); + pic_defun(pic, "char->integer", pic_char_char_to_integer); + pic_defun(pic, "integer->char", pic_char_integer_to_char); + pic_defun(pic, "char=?", pic_char_eq_p); + pic_defun(pic, "char?", pic_char_gt_p); + pic_defun(pic, "char<=?", pic_char_le_p); + pic_defun(pic, "char>=?", pic_char_ge_p); +} diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c new file mode 100644 index 00000000..f6183278 --- /dev/null +++ b/extlib/benz/codegen.c @@ -0,0 +1,1503 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/pair.h" +#include "picrin/irep.h" +#include "picrin/proc.h" +#include "picrin/lib.h" +#include "picrin/macro.h" + +#if PIC_NONE_IS_FALSE +# define OP_PUSHNONE OP_PUSHFALSE +#else +# error enable PIC_NONE_IS_FALSE +#endif + +/** + * scope object + */ + +typedef struct analyze_scope { + int depth; + bool varg; + xvect args, locals, captures; /* rest args variable is counted as a local */ + pic_value defer; + struct analyze_scope *up; +} analyze_scope; + +/** + * global analyzer state + */ + +typedef struct analyze_state { + pic_state *pic; + analyze_scope *scope; + pic_sym rCONS, rCAR, rCDR, rNILP; + pic_sym rADD, rSUB, rMUL, rDIV; + pic_sym rEQ, rLT, rLE, rGT, rGE, rNOT; + pic_sym rVALUES, rCALL_WITH_VALUES; + pic_sym sCALL, sTAILCALL, sCALL_WITH_VALUES, sTAILCALL_WITH_VALUES; + pic_sym sGREF, sLREF, sCREF, sRETURN; +} analyze_state; + +static bool push_scope(analyze_state *, pic_value); +static void pop_scope(analyze_state *); + +#define register_symbol(pic, state, slot, name) do { \ + state->slot = pic_intern_cstr(pic, name); \ + } while (0) + +#define register_renamed_symbol(pic, state, slot, lib, id) do { \ + pic_sym sym, gsym; \ + sym = pic_intern_cstr(pic, id); \ + if (! pic_find_rename(pic, lib->env, sym, &gsym)) { \ + pic_errorf(pic, "internal error! native VM procedure not found: %s", id); \ + } \ + state->slot = gsym; \ + } while (0) + +static analyze_state * +new_analyze_state(pic_state *pic) +{ + analyze_state *state; + xh_entry *it; + + state = pic_alloc(pic, sizeof(analyze_state)); + state->pic = pic; + state->scope = NULL; + + /* native VM procedures */ + register_renamed_symbol(pic, state, rCONS, pic->PICRIN_BASE, "cons"); + register_renamed_symbol(pic, state, rCAR, pic->PICRIN_BASE, "car"); + register_renamed_symbol(pic, state, rCDR, pic->PICRIN_BASE, "cdr"); + register_renamed_symbol(pic, state, rNILP, pic->PICRIN_BASE, "null?"); + register_renamed_symbol(pic, state, rADD, pic->PICRIN_BASE, "+"); + register_renamed_symbol(pic, state, rSUB, pic->PICRIN_BASE, "-"); + register_renamed_symbol(pic, state, rMUL, pic->PICRIN_BASE, "*"); + register_renamed_symbol(pic, state, rDIV, pic->PICRIN_BASE, "/"); + register_renamed_symbol(pic, state, rEQ, pic->PICRIN_BASE, "="); + register_renamed_symbol(pic, state, rLT, pic->PICRIN_BASE, "<"); + register_renamed_symbol(pic, state, rLE, pic->PICRIN_BASE, "<="); + register_renamed_symbol(pic, state, rGT, pic->PICRIN_BASE, ">"); + register_renamed_symbol(pic, state, rGE, pic->PICRIN_BASE, ">="); + register_renamed_symbol(pic, state, rNOT, pic->PICRIN_BASE, "not"); + register_renamed_symbol(pic, state, rVALUES, pic->PICRIN_BASE, "values"); + register_renamed_symbol(pic, state, rCALL_WITH_VALUES, pic->PICRIN_BASE, "call-with-values"); + + register_symbol(pic, state, sCALL, "call"); + register_symbol(pic, state, sTAILCALL, "tail-call"); + register_symbol(pic, state, sCALL_WITH_VALUES, "call-with-values"); + register_symbol(pic, state, sTAILCALL_WITH_VALUES, "tailcall-with-values"); + register_symbol(pic, state, sGREF, "gref"); + register_symbol(pic, state, sLREF, "lref"); + register_symbol(pic, state, sCREF, "cref"); + register_symbol(pic, state, sRETURN, "return"); + + /* push initial scope */ + push_scope(state, pic_nil_value()); + + for (it = xh_begin(&pic->globals); it != NULL; it = xh_next(it)) { + pic_sym sym = xh_key(it, pic_sym); + xv_push(&state->scope->locals, &sym); + } + + return state; +} + +static void +destroy_analyze_state(analyze_state *state) +{ + pop_scope(state); + pic_free(state->pic, state); +} + +static bool +analyze_args(pic_state *pic, pic_value formals, bool *varg, xvect *args, xvect *locals) +{ + pic_value v, t; + pic_sym sym; + + for (v = formals; pic_pair_p(v); v = pic_cdr(pic, v)) { + t = pic_car(pic, v); + if (! pic_sym_p(t)) { + return false; + } + sym = pic_sym(t); + xv_push(args, &sym); + } + if (pic_nil_p(v)) { + *varg = false; + } + else if (pic_sym_p(v)) { + *varg = true; + sym = pic_sym(v); + xv_push(locals, &sym); + } + else { + return false; + } + + return true; +} + +static bool +push_scope(analyze_state *state, pic_value formals) +{ + pic_state *pic = state->pic; + analyze_scope *scope; + bool varg; + xvect args, locals, captures; + + xv_init(&args, sizeof(pic_sym)); + xv_init(&locals, sizeof(pic_sym)); + xv_init(&captures, sizeof(pic_sym)); + + if (analyze_args(pic, formals, &varg, &args, &locals)) { + scope = pic_alloc(pic, sizeof(analyze_scope)); + scope->up = state->scope; + scope->depth = scope->up ? scope->up->depth + 1 : 0; + scope->varg = varg; + scope->args = args; + scope->locals = locals; + scope->captures = captures; + scope->defer = pic_nil_value(); + + state->scope = scope; + + return true; + } + else { + xv_destroy(&args); + xv_destroy(&locals); + return false; + } +} + +static void +pop_scope(analyze_state *state) +{ + analyze_scope *scope; + + scope = state->scope; + xv_destroy(&scope->args); + xv_destroy(&scope->locals); + xv_destroy(&scope->captures); + + scope = scope->up; + pic_free(state->pic, state->scope); + state->scope = scope; +} + +static bool +lookup_scope(analyze_scope *scope, pic_sym sym) +{ + pic_sym *arg, *local; + size_t i; + + /* args */ + for (i = 0; i < xv_size(&scope->args); ++i) { + arg = xv_get(&scope->args, i); + if (*arg == sym) + return true; + } + /* locals */ + for (i = 0; i < xv_size(&scope->locals); ++i) { + local = xv_get(&scope->locals, i); + if (*local == sym) + return true; + } + return false; +} + +static void +capture_var(analyze_scope *scope, pic_sym sym) +{ + pic_sym *var; + size_t i; + + for (i = 0; i < xv_size(&scope->captures); ++i) { + var = xv_get(&scope->captures, i); + if (*var == sym) { + break; + } + } + if (i == xv_size(&scope->captures)) { + xv_push(&scope->captures, &sym); + } +} + +static int +find_var(analyze_state *state, pic_sym sym) +{ + analyze_scope *scope = state->scope; + int depth = 0; + + while (scope) { + if (lookup_scope(scope, sym)) { + if (depth > 0) { + capture_var(scope, sym); + } + return depth; + } + depth++; + scope = scope->up; + } + return -1; +} + +static void +define_var(analyze_state *state, pic_sym sym) +{ + pic_state *pic = state->pic; + analyze_scope *scope = state->scope; + + if (lookup_scope(scope, sym)) { + pic_warnf(pic, "redefining variable: ~s", pic_sym_value(sym)); + return; + } + + xv_push(&scope->locals, &sym); +} + +static pic_value analyze_node(analyze_state *, pic_value, bool); +static pic_value analyze_procedure(analyze_state *, pic_value, pic_value, pic_value); + +static pic_value +analyze(analyze_state *state, pic_value obj, bool tailpos) +{ + pic_state *pic = state->pic; + size_t ai = pic_gc_arena_preserve(pic); + pic_value res; + pic_sym tag; + + res = analyze_node(state, obj, tailpos); + + tag = pic_sym(pic_car(pic, res)); + if (tailpos) { + if (tag == pic->sIF || tag == pic->sBEGIN || tag == state->sTAILCALL || tag == state->sTAILCALL_WITH_VALUES || tag == state->sRETURN) { + /* pass through */ + } + else { + res = pic_list2(pic, pic_symbol_value(state->sRETURN), res); + } + } + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, res); + pic_gc_protect(pic, state->scope->defer); + return res; +} + +static pic_value +analyze_global_var(analyze_state *state, pic_sym sym) +{ + pic_state *pic = state->pic; + + return pic_list2(pic, pic_symbol_value(state->sGREF), pic_sym_value(sym)); +} + +static pic_value +analyze_local_var(analyze_state *state, pic_sym sym) +{ + pic_state *pic = state->pic; + + return pic_list2(pic, pic_symbol_value(state->sLREF), pic_sym_value(sym)); +} + +static pic_value +analyze_free_var(analyze_state *state, pic_sym sym, int depth) +{ + pic_state *pic = state->pic; + + return pic_list3(pic, pic_symbol_value(state->sCREF), pic_int_value(depth), pic_sym_value(sym)); +} + +static pic_value +analyze_var(analyze_state *state, pic_sym sym) +{ + pic_state *pic = state->pic; + int depth; + + if ((depth = find_var(state, sym)) == -1) { + pic_errorf(pic, "unbound variable %s", pic_symbol_name(pic, sym)); + } + + if (depth == state->scope->depth) { + return analyze_global_var(state, sym); + } else if (depth == 0) { + return analyze_local_var(state, sym); + } else { + return analyze_free_var(state, sym, depth); + } +} + +static pic_value +analyze_defer(analyze_state *state, pic_value name, pic_value formal, pic_value body) +{ + pic_state *pic = state->pic; + const pic_sym sNOWHERE = pic_intern_cstr(pic, " nowhere "); + pic_value skel; + + skel = pic_list2(pic, pic_sym_value(state->sGREF), pic_sym_value(sNOWHERE)); + + pic_push(pic, pic_list4(pic, name, formal, body, skel), state->scope->defer); + + return skel; +} + +static void +analyze_deferred(analyze_state *state) +{ + pic_state *pic = state->pic; + pic_value defer, val, name, formal, body, dst; + + pic_for_each (defer, pic_reverse(pic, state->scope->defer)) { + name = pic_list_ref(pic, defer, 0); + formal = pic_list_ref(pic, defer, 1); + body = pic_list_ref(pic, defer, 2); + dst = pic_list_ref(pic, defer, 3); + + val = analyze_procedure(state, name, formal, body); + + /* copy */ + pic_pair_ptr(dst)->car = pic_car(pic, val); + pic_pair_ptr(dst)->cdr = pic_cdr(pic, val); + } + + state->scope->defer = pic_nil_value(); +} + +static pic_value +analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_value body_exprs) +{ + pic_state *pic = state->pic; + pic_value args, locals, varg, captures, body; + + assert(pic_sym_p(name) || pic_false_p(name)); + + if (push_scope(state, formals)) { + analyze_scope *scope = state->scope; + pic_sym *var; + size_t i; + + args = pic_nil_value(); + for (i = xv_size(&scope->args); i > 0; --i) { + var = xv_get(&scope->args, i - 1); + pic_push(pic, pic_sym_value(*var), args); + } + + varg = scope->varg + ? pic_true_value() + : pic_false_value(); + + /* To know what kind of local variables are defined, analyze body at first. */ + body = analyze(state, pic_cons(pic, pic_sym_value(pic->rBEGIN), body_exprs), true); + + analyze_deferred(state); + + locals = pic_nil_value(); + for (i = xv_size(&scope->locals); i > 0; --i) { + var = xv_get(&scope->locals, i - 1); + pic_push(pic, pic_sym_value(*var), locals); + } + + captures = pic_nil_value(); + for (i = xv_size(&scope->captures); i > 0; --i) { + var = xv_get(&scope->captures, i - 1); + pic_push(pic, pic_sym_value(*var), captures); + } + + pop_scope(state); + } + else { + pic_errorf(pic, "invalid formal syntax: ~s", args); + } + + return pic_list7(pic, pic_sym_value(pic->sLAMBDA), name, args, locals, varg, captures, body); +} + +static pic_value +analyze_lambda(analyze_state *state, pic_value obj) +{ + pic_state *pic = state->pic; + pic_value formals, body_exprs; + + if (pic_length(pic, obj) < 2) { + pic_errorf(pic, "syntax error"); + } + + formals = pic_list_ref(pic, obj, 1); + body_exprs = pic_list_tail(pic, obj, 2); + + return analyze_defer(state, pic_false_value(), formals, body_exprs); +} + +static pic_value +analyze_declare(analyze_state *state, pic_sym var) +{ + define_var(state, var); + + return analyze_var(state, var); +} + +static pic_value +analyze_define(analyze_state *state, pic_value obj) +{ + pic_state *pic = state->pic; + pic_value var, val; + pic_sym sym; + + if (pic_length(pic, obj) != 3) { + pic_errorf(pic, "syntax error"); + } + + var = pic_list_ref(pic, obj, 1); + if (! pic_sym_p(var)) { + pic_errorf(pic, "syntax error"); + } else { + sym = pic_sym(var); + } + var = analyze_declare(state, sym); + + if (pic_pair_p(pic_list_ref(pic, obj, 2)) + && pic_sym_p(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) + && pic_sym(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->rLAMBDA) { + pic_value formals, body_exprs; + + formals = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 1); + body_exprs = pic_list_tail(pic, pic_list_ref(pic, obj, 2), 2); + + val = analyze_defer(state, pic_sym_value(sym), formals, body_exprs); + } else { + if (pic_length(pic, obj) != 3) { + pic_errorf(pic, "syntax error"); + } + val = analyze(state, pic_list_ref(pic, obj, 2), false); + } + + return pic_list3(pic, pic_symbol_value(pic->sSETBANG), var, val); +} + +static pic_value +analyze_if(analyze_state *state, pic_value obj, bool tailpos) +{ + pic_state *pic = state->pic; + pic_value cond, if_true, if_false; + + if_false = pic_none_value(); + switch (pic_length(pic, obj)) { + default: + pic_errorf(pic, "syntax error"); + case 4: + if_false = pic_list_ref(pic, obj, 3); + FALLTHROUGH; + case 3: + if_true = pic_list_ref(pic, obj, 2); + } + + /* analyze in order */ + cond = analyze(state, pic_list_ref(pic, obj, 1), false); + if_true = analyze(state, if_true, tailpos); + if_false = analyze(state, if_false, tailpos); + + return pic_list4(pic, pic_symbol_value(pic->sIF), cond, if_true, if_false); +} + +static pic_value +analyze_begin(analyze_state *state, pic_value obj, bool tailpos) +{ + pic_state *pic = state->pic; + pic_value seq; + bool tail; + + switch (pic_length(pic, obj)) { + case 1: + return analyze(state, pic_none_value(), tailpos); + case 2: + return analyze(state, pic_list_ref(pic, obj, 1), tailpos); + default: + seq = pic_list1(pic, pic_symbol_value(pic->sBEGIN)); + for (obj = pic_cdr(pic, obj); ! pic_nil_p(obj); obj = pic_cdr(pic, obj)) { + if (pic_nil_p(pic_cdr(pic, obj))) { + tail = tailpos; + } else { + tail = false; + } + seq = pic_cons(pic, analyze(state, pic_car(pic, obj), tail), seq); + } + return pic_reverse(pic, seq); + } +} + +static pic_value +analyze_set(analyze_state *state, pic_value obj) +{ + pic_state *pic = state->pic; + pic_value var, val; + + if (pic_length(pic, obj) != 3) { + pic_errorf(pic, "syntax error"); + } + + var = pic_list_ref(pic, obj, 1); + if (! pic_sym_p(var)) { + pic_errorf(pic, "syntax error"); + } + + val = pic_list_ref(pic, obj, 2); + + var = analyze(state, var, false); + val = analyze(state, val, false); + + return pic_list3(pic, pic_symbol_value(pic->sSETBANG), var, val); +} + +static pic_value +analyze_quote(analyze_state *state, pic_value obj) +{ + pic_state *pic = state->pic; + + if (pic_length(pic, obj) != 2) { + pic_errorf(pic, "syntax error"); + } + return pic_list2(pic, pic_sym_value(pic->sQUOTE), pic_list_ref(pic, obj, 1)); +} + +#define ARGC_ASSERT_GE(n) do { \ + if (pic_length(pic, obj) < (n) + 1) { \ + pic_errorf(pic, "wrong number of arguments"); \ + } \ + } while (0) + +#define FOLD_ARGS(sym) do { \ + obj = analyze(state, pic_car(pic, args), false); \ + pic_for_each (arg, pic_cdr(pic, args)) { \ + obj = pic_list3(pic, pic_symbol_value(sym), obj, \ + analyze(state, arg, false)); \ + } \ + } while (0) + +static pic_value +analyze_add(analyze_state *state, pic_value obj, bool tailpos) +{ + pic_state *pic = state->pic; + pic_value args, arg; + + ARGC_ASSERT_GE(0); + switch (pic_length(pic, obj)) { + case 1: + return pic_list2(pic, pic_symbol_value(pic->sQUOTE), pic_int_value(0)); + case 2: + return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos); + default: + args = pic_cdr(pic, obj); + FOLD_ARGS(pic->sADD); + return obj; + } +} + +static pic_value +analyze_sub(analyze_state *state, pic_value obj) +{ + pic_state *pic = state->pic; + pic_value args, arg; + + ARGC_ASSERT_GE(1); + switch (pic_length(pic, obj)) { + case 2: + return pic_list2(pic, pic_symbol_value(pic->sMINUS), + analyze(state, pic_car(pic, pic_cdr(pic, obj)), false)); + default: + args = pic_cdr(pic, obj); + FOLD_ARGS(pic->sSUB); + return obj; + } +} + +static pic_value +analyze_mul(analyze_state *state, pic_value obj, bool tailpos) +{ + pic_state *pic = state->pic; + pic_value args, arg; + + ARGC_ASSERT_GE(0); + switch (pic_length(pic, obj)) { + case 1: + return pic_list2(pic, pic_symbol_value(pic->sQUOTE), pic_int_value(1)); + case 2: + return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos); + default: + args = pic_cdr(pic, obj); + FOLD_ARGS(pic->sMUL); + return obj; + } +} + +static pic_value +analyze_div(analyze_state *state, pic_value obj) +{ + pic_state *pic = state->pic; + pic_value args, arg; + + ARGC_ASSERT_GE(1); + switch (pic_length(pic, obj)) { + case 2: + args = pic_cdr(pic, obj); + obj = pic_list3(pic, pic_car(pic, obj), pic_float_value(1), pic_car(pic, args)); + return analyze(state, obj, false); + default: + args = pic_cdr(pic, obj); + FOLD_ARGS(pic->sDIV); + return obj; + } +} + +static pic_value +analyze_call(analyze_state *state, pic_value obj, bool tailpos) +{ + pic_state *pic = state->pic; + pic_value seq, elt; + pic_sym call; + + if (! tailpos) { + call = state->sCALL; + } else { + call = state->sTAILCALL; + } + seq = pic_list1(pic, pic_symbol_value(call)); + pic_for_each (elt, obj) { + seq = pic_cons(pic, analyze(state, elt, false), seq); + } + return pic_reverse(pic, seq); +} + +static pic_value +analyze_values(analyze_state *state, pic_value obj, bool tailpos) +{ + pic_state *pic = state->pic; + pic_value v, seq; + + if (! tailpos) { + return analyze_call(state, obj, false); + } + + seq = pic_list1(pic, pic_symbol_value(state->sRETURN)); + pic_for_each (v, pic_cdr(pic, obj)) { + seq = pic_cons(pic, analyze(state, v, false), seq); + } + return pic_reverse(pic, seq); +} + +static pic_value +analyze_call_with_values(analyze_state *state, pic_value obj, bool tailpos) +{ + pic_state *pic = state->pic; + pic_value prod, cnsm; + pic_sym call; + + if (pic_length(pic, obj) != 3) { + pic_errorf(pic, "wrong number of arguments"); + } + + if (! tailpos) { + call = state->sCALL_WITH_VALUES; + } else { + call = state->sTAILCALL_WITH_VALUES; + } + prod = analyze(state, pic_list_ref(pic, obj, 1), false); + cnsm = analyze(state, pic_list_ref(pic, obj, 2), false); + return pic_list3(pic, pic_symbol_value(call), prod, cnsm); +} + +#define ARGC_ASSERT(n) do { \ + if (pic_length(pic, obj) != (n) + 1) { \ + pic_errorf(pic, "wrong number of arguments"); \ + } \ + } while (0) + +#define ARGC_ASSERT_WITH_FALLBACK(n) do { \ + if (pic_length(pic, obj) != (n) + 1) { \ + goto fallback; \ + } \ + } while (0) + +#define CONSTRUCT_OP1(op) \ + pic_list2(pic, \ + pic_symbol_value(op), \ + analyze(state, pic_list_ref(pic, obj, 1), false)) + +#define CONSTRUCT_OP2(op) \ + pic_list3(pic, \ + pic_symbol_value(op), \ + analyze(state, pic_list_ref(pic, obj, 1), false), \ + analyze(state, pic_list_ref(pic, obj, 2), false)) + +static pic_value +analyze_node(analyze_state *state, pic_value obj, bool tailpos) +{ + pic_state *pic = state->pic; + + switch (pic_type(obj)) { + case PIC_TT_SYMBOL: { + return analyze_var(state, pic_sym(obj)); + } + case PIC_TT_PAIR: { + pic_value proc; + + if (! pic_list_p(obj)) { + pic_errorf(pic, "invalid expression given: ~s", obj); + } + + proc = pic_list_ref(pic, obj, 0); + if (pic_sym_p(proc)) { + pic_sym sym = pic_sym(proc); + + if (sym == pic->rDEFINE) { + return analyze_define(state, obj); + } + else if (sym == pic->rLAMBDA) { + return analyze_lambda(state, obj); + } + else if (sym == pic->rIF) { + return analyze_if(state, obj, tailpos); + } + else if (sym == pic->rBEGIN) { + return analyze_begin(state, obj, tailpos); + } + else if (sym == pic->rSETBANG) { + return analyze_set(state, obj); + } + else if (sym == pic->rQUOTE) { + return analyze_quote(state, obj); + } + else if (sym == state->rCONS) { + ARGC_ASSERT(2); + return CONSTRUCT_OP2(pic->sCONS); + } + else if (sym == state->rCAR) { + ARGC_ASSERT(1); + return CONSTRUCT_OP1(pic->sCAR); + } + else if (sym == state->rCDR) { + ARGC_ASSERT(1); + return CONSTRUCT_OP1(pic->sCDR); + } + else if (sym == state->rNILP) { + ARGC_ASSERT(1); + return CONSTRUCT_OP1(pic->sNILP); + } + else if (sym == state->rADD) { + return analyze_add(state, obj, tailpos); + } + else if (sym == state->rSUB) { + return analyze_sub(state, obj); + } + else if (sym == state->rMUL) { + return analyze_mul(state, obj, tailpos); + } + else if (sym == state->rDIV) { + return analyze_div(state, obj); + } + else if (sym == state->rEQ) { + ARGC_ASSERT_WITH_FALLBACK(2); + return CONSTRUCT_OP2(pic->sEQ); + } + else if (sym == state->rLT) { + ARGC_ASSERT_WITH_FALLBACK(2); + return CONSTRUCT_OP2(pic->sLT); + } + else if (sym == state->rLE) { + ARGC_ASSERT_WITH_FALLBACK(2); + return CONSTRUCT_OP2(pic->sLE); + } + else if (sym == state->rGT) { + ARGC_ASSERT_WITH_FALLBACK(2); + return CONSTRUCT_OP2(pic->sGT); + } + else if (sym == state->rGE) { + ARGC_ASSERT_WITH_FALLBACK(2); + return CONSTRUCT_OP2(pic->sGE); + } + else if (sym == state->rNOT) { + ARGC_ASSERT(1); + return CONSTRUCT_OP1(pic->sNOT); + } + else if (sym == state->rVALUES) { + return analyze_values(state, obj, tailpos); + } + else if (sym == state->rCALL_WITH_VALUES) { + return analyze_call_with_values(state, obj, tailpos); + } + } + fallback: + + return analyze_call(state, obj, tailpos); + } + default: + return pic_list2(pic, pic_symbol_value(pic->sQUOTE), obj); + } +} + +pic_value +pic_analyze(pic_state *pic, pic_value obj) +{ + analyze_state *state; + + state = new_analyze_state(pic); + + obj = analyze(state, obj, true); + + analyze_deferred(state); + + destroy_analyze_state(state); + return obj; +} + +/** + * scope object + */ + +typedef struct codegen_context { + pic_sym name; + /* rest args variable is counted as a local */ + bool varg; + xvect args, locals, captures; + /* actual bit code sequence */ + pic_code *code; + size_t clen, ccapa; + /* child ireps */ + struct pic_irep **irep; + size_t ilen, icapa; + /* constant object pool */ + pic_value *pool; + size_t plen, pcapa; + + struct codegen_context *up; +} codegen_context; + +/** + * global codegen state + */ + +typedef struct codegen_state { + pic_state *pic; + codegen_context *cxt; + pic_sym sGREF, sCREF, sLREF; + pic_sym sCALL, sTAILCALL, sRETURN; + pic_sym sCALL_WITH_VALUES, sTAILCALL_WITH_VALUES; +} codegen_state; + +static void push_codegen_context(codegen_state *, pic_value, pic_value, pic_value, bool, pic_value); +static struct pic_irep *pop_codegen_context(codegen_state *); + +static codegen_state * +new_codegen_state(pic_state *pic) +{ + codegen_state *state; + + state = pic_alloc(pic, sizeof(codegen_state)); + state->pic = pic; + state->cxt = NULL; + + register_symbol(pic, state, sCALL, "call"); + register_symbol(pic, state, sTAILCALL, "tail-call"); + register_symbol(pic, state, sGREF, "gref"); + register_symbol(pic, state, sLREF, "lref"); + register_symbol(pic, state, sCREF, "cref"); + register_symbol(pic, state, sRETURN, "return"); + register_symbol(pic, state, sCALL_WITH_VALUES, "call-with-values"); + register_symbol(pic, state, sTAILCALL_WITH_VALUES, "tailcall-with-values"); + + push_codegen_context(state, pic_false_value(), pic_nil_value(), pic_nil_value(), false, pic_nil_value()); + + return state; +} + +static struct pic_irep * +destroy_codegen_state(codegen_state *state) +{ + pic_state *pic = state->pic; + struct pic_irep *irep; + + irep = pop_codegen_context(state); + pic_free(pic, state); + + return irep; +} + +static void +create_activation(codegen_context *cxt) +{ + size_t i, n; + xhash regs; + pic_sym *var; + size_t offset; + + xh_init_int(®s, sizeof(size_t)); + + offset = 1; + for (i = 0; i < xv_size(&cxt->args); ++i) { + var = xv_get(&cxt->args, i); + n = i + offset; + xh_put_int(®s, *var, &n); + } + offset += i; + for (i = 0; i < xv_size(&cxt->locals); ++i) { + var = xv_get(&cxt->locals, i); + n = i + offset; + xh_put_int(®s, *var, &n); + } + + for (i = 0; i < xv_size(&cxt->captures); ++i) { + var = xv_get(&cxt->captures, i); + if ((n = xh_val(xh_get_int(®s, *var), size_t)) <= xv_size(&cxt->args) || (cxt->varg && n == xv_size(&cxt->args) + 1)) { + /* copy arguments to capture variable area */ + cxt->code[cxt->clen].insn = OP_LREF; + cxt->code[cxt->clen].u.i = (int)n; + cxt->clen++; + } else { + /* otherwise, just extend the stack */ + cxt->code[cxt->clen].insn = OP_PUSHNONE; + cxt->clen++; + } + } + + xh_destroy(®s); +} + +static void +push_codegen_context(codegen_state *state, pic_value name, pic_value args, pic_value locals, bool varg, pic_value captures) +{ + pic_state *pic = state->pic; + codegen_context *cxt; + pic_value var; + pic_sym sym; + + assert(pic_sym_p(name) || pic_false_p(name)); + + cxt = pic_alloc(pic, sizeof(codegen_context)); + cxt->up = state->cxt; + cxt->name = pic_false_p(name) + ? pic_intern_cstr(pic, "(anonymous lambda)") + : pic_sym(name); + cxt->varg = varg; + + xv_init(&cxt->args, sizeof(pic_sym)); + xv_init(&cxt->locals, sizeof(pic_sym)); + xv_init(&cxt->captures, sizeof(pic_sym)); + + pic_for_each (var, args) { + sym = pic_sym(var); + xv_push(&cxt->args, &sym); + } + pic_for_each (var, locals) { + sym = pic_sym(var); + xv_push(&cxt->locals, &sym); + } + pic_for_each (var, captures) { + sym = pic_sym(var); + xv_push(&cxt->captures, &sym); + } + + cxt->code = pic_calloc(pic, PIC_ISEQ_SIZE, sizeof(pic_code)); + cxt->clen = 0; + cxt->ccapa = PIC_ISEQ_SIZE; + + cxt->irep = pic_calloc(pic, PIC_IREP_SIZE, sizeof(struct pic_irep *)); + cxt->ilen = 0; + cxt->icapa = PIC_IREP_SIZE; + + cxt->pool = pic_calloc(pic, PIC_POOL_SIZE, sizeof(pic_value)); + cxt->plen = 0; + cxt->pcapa = PIC_POOL_SIZE; + + state->cxt = cxt; + + create_activation(cxt); +} + +static struct pic_irep * +pop_codegen_context(codegen_state *state) +{ + pic_state *pic = state->pic; + codegen_context *cxt = state->cxt; + struct pic_irep *irep; + + /* create irep */ + irep = (struct pic_irep *)pic_obj_alloc(pic, sizeof(struct pic_irep), PIC_TT_IREP); + irep->name = state->cxt->name; + irep->varg = state->cxt->varg; + irep->argc = (int)xv_size(&state->cxt->args) + 1; + irep->localc = (int)xv_size(&state->cxt->locals); + irep->capturec = (int)xv_size(&state->cxt->captures); + irep->code = pic_realloc(pic, state->cxt->code, sizeof(pic_code) * state->cxt->clen); + irep->clen = state->cxt->clen; + irep->irep = pic_realloc(pic, state->cxt->irep, sizeof(struct pic_irep *) * state->cxt->ilen); + irep->ilen = state->cxt->ilen; + irep->pool = pic_realloc(pic, state->cxt->pool, sizeof(pic_value) * state->cxt->plen); + irep->plen = state->cxt->plen; + + /* finalize */ + xv_destroy(&cxt->args); + xv_destroy(&cxt->locals); + xv_destroy(&cxt->captures); + + /* destroy context */ + cxt = cxt->up; + pic_free(pic, state->cxt); + state->cxt = cxt; + + return irep; +} + +static int +index_capture(codegen_state *state, pic_sym sym, int depth) +{ + codegen_context *cxt = state->cxt; + size_t i; + pic_sym *var; + + while (depth-- > 0) { + cxt = cxt->up; + } + + for (i = 0; i < xv_size(&cxt->captures); ++i) { + var = xv_get(&cxt->captures, i); + if (*var == sym) + return (int)i; + } + return -1; +} + +static int +index_local(codegen_state *state, pic_sym sym) +{ + codegen_context *cxt = state->cxt; + size_t i, offset; + pic_sym *var; + + offset = 1; + for (i = 0; i < xv_size(&cxt->args); ++i) { + var = xv_get(&cxt->args, i); + if (*var == sym) + return (int)(i + offset); + } + offset += i; + for (i = 0; i < xv_size(&cxt->locals); ++i) { + var = xv_get(&cxt->locals, i); + if (*var == sym) + return (int)(i + offset); + } + return -1; +} + +static struct pic_irep *codegen_lambda(codegen_state *, pic_value); + +static void +codegen(codegen_state *state, pic_value obj) +{ + pic_state *pic = state->pic; + codegen_context *cxt = state->cxt; + pic_sym sym; + + sym = pic_sym(pic_car(pic, obj)); + if (sym == state->sGREF) { + cxt->code[cxt->clen].insn = OP_GREF; + cxt->code[cxt->clen].u.i = pic_sym(pic_list_ref(pic, obj, 1)); + cxt->clen++; + return; + } else if (sym == state->sCREF) { + pic_sym name; + int depth; + + depth = pic_int(pic_list_ref(pic, obj, 1)); + name = pic_sym(pic_list_ref(pic, obj, 2)); + cxt->code[cxt->clen].insn = OP_CREF; + cxt->code[cxt->clen].u.r.depth = depth; + cxt->code[cxt->clen].u.r.idx = index_capture(state, name, depth); + cxt->clen++; + return; + } else if (sym == state->sLREF) { + pic_sym name; + int i; + + name = pic_sym(pic_list_ref(pic, obj, 1)); + if ((i = index_capture(state, name, 0)) != -1) { + cxt->code[cxt->clen].insn = OP_LREF; + cxt->code[cxt->clen].u.i = i + (int)xv_size(&cxt->args) + (int)xv_size(&cxt->locals) + 1; + cxt->clen++; + return; + } + cxt->code[cxt->clen].insn = OP_LREF; + cxt->code[cxt->clen].u.i = index_local(state, name); + cxt->clen++; + return; + } else if (sym == pic->sSETBANG) { + pic_value var, val; + pic_sym type; + + val = pic_list_ref(pic, obj, 2); + codegen(state, val); + + var = pic_list_ref(pic, obj, 1); + type = pic_sym(pic_list_ref(pic, var, 0)); + if (type == state->sGREF) { + cxt->code[cxt->clen].insn = OP_GSET; + cxt->code[cxt->clen].u.i = pic_int(pic_list_ref(pic, var, 1)); + cxt->clen++; + cxt->code[cxt->clen].insn = OP_PUSHNONE; + cxt->clen++; + return; + } + else if (type == state->sCREF) { + pic_sym name; + int depth; + + depth = pic_int(pic_list_ref(pic, var, 1)); + name = pic_sym(pic_list_ref(pic, var, 2)); + cxt->code[cxt->clen].insn = OP_CSET; + cxt->code[cxt->clen].u.r.depth = depth; + cxt->code[cxt->clen].u.r.idx = index_capture(state, name, depth); + cxt->clen++; + cxt->code[cxt->clen].insn = OP_PUSHNONE; + cxt->clen++; + return; + } + else if (type == state->sLREF) { + pic_sym name; + int i; + + name = pic_sym(pic_list_ref(pic, var, 1)); + if ((i = index_capture(state, name, 0)) != -1) { + cxt->code[cxt->clen].insn = OP_LSET; + cxt->code[cxt->clen].u.i = i + (int)xv_size(&cxt->args) + (int)xv_size(&cxt->locals) + 1; + cxt->clen++; + cxt->code[cxt->clen].insn = OP_PUSHNONE; + cxt->clen++; + return; + } + cxt->code[cxt->clen].insn = OP_LSET; + cxt->code[cxt->clen].u.i = index_local(state, name); + cxt->clen++; + cxt->code[cxt->clen].insn = OP_PUSHNONE; + cxt->clen++; + return; + } + } + else if (sym == pic->sLAMBDA) { + int k; + + if (cxt->ilen >= cxt->icapa) { + cxt->icapa *= 2; + cxt->irep = pic_realloc(pic, cxt->irep, sizeof(struct pic_irep *) * cxt->icapa); + } + k = (int)cxt->ilen++; + cxt->code[cxt->clen].insn = OP_LAMBDA; + cxt->code[cxt->clen].u.i = k; + cxt->clen++; + + cxt->irep[k] = codegen_lambda(state, obj); + return; + } + else if (sym == pic->sIF) { + int s, t; + + codegen(state, pic_list_ref(pic, obj, 1)); + + cxt->code[cxt->clen].insn = OP_JMPIF; + s = (int)cxt->clen++; + + /* if false branch */ + codegen(state, pic_list_ref(pic, obj, 3)); + cxt->code[cxt->clen].insn = OP_JMP; + t = (int)cxt->clen++; + + cxt->code[s].u.i = (int)cxt->clen - s; + + /* if true branch */ + codegen(state, pic_list_ref(pic, obj, 2)); + cxt->code[t].u.i = (int)cxt->clen - t; + return; + } + else if (sym == pic->sBEGIN) { + pic_value elt; + int i = 0; + + pic_for_each (elt, pic_cdr(pic, obj)) { + if (i++ != 0) { + cxt->code[cxt->clen].insn = OP_POP; + cxt->clen++; + } + codegen(state, elt); + } + return; + } + else if (sym == pic->sQUOTE) { + int pidx; + + obj = pic_list_ref(pic, obj, 1); + switch (pic_type(obj)) { + case PIC_TT_BOOL: + if (pic_true_p(obj)) { + cxt->code[cxt->clen].insn = OP_PUSHTRUE; + } else { + cxt->code[cxt->clen].insn = OP_PUSHFALSE; + } + cxt->clen++; + return; + case PIC_TT_INT: + cxt->code[cxt->clen].insn = OP_PUSHINT; + cxt->code[cxt->clen].u.i = pic_int(obj); + cxt->clen++; + return; + case PIC_TT_NIL: + cxt->code[cxt->clen].insn = OP_PUSHNIL; + cxt->clen++; + return; + case PIC_TT_CHAR: + cxt->code[cxt->clen].insn = OP_PUSHCHAR; + cxt->code[cxt->clen].u.c = pic_char(obj); + cxt->clen++; + return; + default: + if (cxt->plen >= cxt->pcapa) { + cxt->pcapa *= 2; + cxt->pool = pic_realloc(pic, cxt->pool, sizeof(pic_value) * cxt->pcapa); + } + pidx = (int)cxt->plen++; + cxt->pool[pidx] = obj; + cxt->code[cxt->clen].insn = OP_PUSHCONST; + cxt->code[cxt->clen].u.i = pidx; + cxt->clen++; + return; + } + } + else if (sym == pic->sCONS) { + codegen(state, pic_list_ref(pic, obj, 1)); + codegen(state, pic_list_ref(pic, obj, 2)); + cxt->code[cxt->clen].insn = OP_CONS; + cxt->clen++; + return; + } + else if (sym == pic->sCAR) { + codegen(state, pic_list_ref(pic, obj, 1)); + cxt->code[cxt->clen].insn = OP_CAR; + cxt->clen++; + return; + } + else if (sym == pic->sCDR) { + codegen(state, pic_list_ref(pic, obj, 1)); + cxt->code[cxt->clen].insn = OP_CDR; + cxt->clen++; + return; + } + else if (sym == pic->sNILP) { + codegen(state, pic_list_ref(pic, obj, 1)); + cxt->code[cxt->clen].insn = OP_NILP; + cxt->clen++; + return; + } + else if (sym == pic->sADD) { + codegen(state, pic_list_ref(pic, obj, 1)); + codegen(state, pic_list_ref(pic, obj, 2)); + cxt->code[cxt->clen].insn = OP_ADD; + cxt->clen++; + return; + } + else if (sym == pic->sSUB) { + codegen(state, pic_list_ref(pic, obj, 1)); + codegen(state, pic_list_ref(pic, obj, 2)); + cxt->code[cxt->clen].insn = OP_SUB; + cxt->clen++; + return; + } + else if (sym == pic->sMUL) { + codegen(state, pic_list_ref(pic, obj, 1)); + codegen(state, pic_list_ref(pic, obj, 2)); + cxt->code[cxt->clen].insn = OP_MUL; + cxt->clen++; + return; + } + else if (sym == pic->sDIV) { + codegen(state, pic_list_ref(pic, obj, 1)); + codegen(state, pic_list_ref(pic, obj, 2)); + cxt->code[cxt->clen].insn = OP_DIV; + cxt->clen++; + return; + } + else if (sym == pic->sMINUS) { + codegen(state, pic_list_ref(pic, obj, 1)); + cxt->code[cxt->clen].insn = OP_MINUS; + cxt->clen++; + return; + } + else if (sym == pic->sEQ) { + codegen(state, pic_list_ref(pic, obj, 1)); + codegen(state, pic_list_ref(pic, obj, 2)); + cxt->code[cxt->clen].insn = OP_EQ; + cxt->clen++; + return; + } + else if (sym == pic->sLT) { + codegen(state, pic_list_ref(pic, obj, 1)); + codegen(state, pic_list_ref(pic, obj, 2)); + cxt->code[cxt->clen].insn = OP_LT; + cxt->clen++; + return; + } + else if (sym == pic->sLE) { + codegen(state, pic_list_ref(pic, obj, 1)); + codegen(state, pic_list_ref(pic, obj, 2)); + cxt->code[cxt->clen].insn = OP_LE; + cxt->clen++; + return; + } + else if (sym == pic->sGT) { + codegen(state, pic_list_ref(pic, obj, 2)); + codegen(state, pic_list_ref(pic, obj, 1)); + cxt->code[cxt->clen].insn = OP_LT; + cxt->clen++; + return; + } + else if (sym == pic->sGE) { + codegen(state, pic_list_ref(pic, obj, 2)); + codegen(state, pic_list_ref(pic, obj, 1)); + cxt->code[cxt->clen].insn = OP_LE; + cxt->clen++; + return; + } + else if (sym == pic->sNOT) { + codegen(state, pic_list_ref(pic, obj, 1)); + cxt->code[cxt->clen].insn = OP_NOT; + cxt->clen++; + return; + } + else if (sym == state->sCALL || sym == state->sTAILCALL) { + int len = (int)pic_length(pic, obj); + pic_value elt; + + pic_for_each (elt, pic_cdr(pic, obj)) { + codegen(state, elt); + } + cxt->code[cxt->clen].insn = (sym == state->sCALL) ? OP_CALL : OP_TAILCALL; + cxt->code[cxt->clen].u.i = len - 1; + cxt->clen++; + return; + } + else if (sym == state->sCALL_WITH_VALUES || sym == state->sTAILCALL_WITH_VALUES) { + /* stack consumer at first */ + codegen(state, pic_list_ref(pic, obj, 2)); + codegen(state, pic_list_ref(pic, obj, 1)); + /* call producer */ + cxt->code[cxt->clen].insn = OP_CALL; + cxt->code[cxt->clen].u.i = 1; + cxt->clen++; + /* call consumer */ + cxt->code[cxt->clen].insn = (sym == state->sCALL_WITH_VALUES) ? OP_CALL : OP_TAILCALL; + cxt->code[cxt->clen].u.i = -1; + cxt->clen++; + return; + } + else if (sym == state->sRETURN) { + int len = (int)pic_length(pic, obj); + pic_value elt; + + pic_for_each (elt, pic_cdr(pic, obj)) { + codegen(state, elt); + } + cxt->code[cxt->clen].insn = OP_RET; + cxt->code[cxt->clen].u.i = len - 1; + cxt->clen++; + return; + } + pic_errorf(pic, "codegen: unknown AST type"); +} + +static struct pic_irep * +codegen_lambda(codegen_state *state, pic_value obj) +{ + pic_state *pic = state->pic; + pic_value name, args, locals, closes, body; + bool varg; + + name = pic_list_ref(pic, obj, 1); + args = pic_list_ref(pic, obj, 2); + locals = pic_list_ref(pic, obj, 3); + varg = pic_true_p(pic_list_ref(pic, obj, 4)); + closes = pic_list_ref(pic, obj, 5); + body = pic_list_ref(pic, obj, 6); + + /* inner environment */ + push_codegen_context(state, name, args, locals, varg, closes); + { + /* body */ + codegen(state, body); + } + return pop_codegen_context(state); +} + +struct pic_irep * +pic_codegen(pic_state *pic, pic_value obj) +{ + codegen_state *state; + + state = new_codegen_state(pic); + + codegen(state, obj); + + return destroy_codegen_state(state); +} + +struct pic_proc * +pic_compile(pic_state *pic, pic_value obj, struct pic_lib *lib) +{ + struct pic_irep *irep; + size_t ai = pic_gc_arena_preserve(pic); + +#if DEBUG + fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); + + fprintf(stdout, "# input expression\n"); + pic_debug(pic, obj); + fprintf(stdout, "\n"); + + fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); +#endif + + /* macroexpand */ + obj = pic_macroexpand(pic, obj, lib); +#if DEBUG + fprintf(stdout, "## macroexpand completed\n"); + pic_debug(pic, obj); + fprintf(stdout, "\n"); + fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); +#endif + + /* analyze */ + obj = pic_analyze(pic, obj); +#if DEBUG + fprintf(stdout, "## analyzer completed\n"); + pic_debug(pic, obj); + fprintf(stdout, "\n"); + fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); +#endif + + /* codegen */ + irep = pic_codegen(pic, obj); +#if DEBUG + fprintf(stdout, "## codegen completed\n"); + pic_dump_irep(irep); +#endif + +#if DEBUG + fprintf(stdout, "# compilation finished\n"); + puts(""); +#endif + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, pic_obj_value(irep)); + + return pic_make_proc_irep(pic, irep, NULL); +} diff --git a/extlib/benz/cont.c b/extlib/benz/cont.c new file mode 100644 index 00000000..4e38e8c6 --- /dev/null +++ b/extlib/benz/cont.c @@ -0,0 +1,286 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include +#include +#include + +#include "picrin.h" +#include "picrin/proc.h" +#include "picrin/cont.h" +#include "picrin/pair.h" +#include "picrin/data.h" +#include "picrin/error.h" + +void +pic_wind(pic_state *pic, struct pic_winder *here, struct pic_winder *there) +{ + if (here == there) + return; + + if (here->depth < there->depth) { + pic_wind(pic, here, there->prev); + pic_apply0(pic, there->in); + } + else { + pic_apply0(pic, there->out); + pic_wind(pic, here->prev, there); + } +} + +pic_value +pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out) +{ + struct pic_winder *here; + pic_value val; + + if (in != NULL) { + pic_apply0(pic, in); /* enter */ + } + + here = pic->wind; + pic->wind = pic_alloc(pic, sizeof(struct pic_winder)); + pic->wind->prev = here; + pic->wind->depth = here->depth + 1; + pic->wind->in = in; + pic->wind->out = out; + + val = pic_apply0(pic, thunk); + + pic->wind = here; + + if (out != NULL) { + pic_apply0(pic, out); /* exit */ + } + + return val; +} + +void +pic_save_point(pic_state *pic, struct pic_escape *escape) +{ + escape->valid = true; + + /* save runtime context */ + escape->wind = pic->wind; + escape->sp_offset = pic->sp - pic->stbase; + escape->ci_offset = pic->ci - pic->cibase; + escape->xp_offset = pic->xp - pic->xpbase; + escape->arena_idx = pic->arena_idx; + escape->ip = pic->ip; + + escape->results = pic_undef_value(); +} + +void +pic_load_point(pic_state *pic, struct pic_escape *escape) +{ + if (! escape->valid) { + pic_errorf(pic, "calling dead escape continuation"); + } + + pic_wind(pic, pic->wind, escape->wind); + + /* load runtime context */ + pic->wind = escape->wind; + pic->sp = pic->stbase + escape->sp_offset; + pic->ci = pic->cibase + escape->ci_offset; + pic->xp = pic->xpbase + escape->xp_offset; + pic->arena_idx = escape->arena_idx; + pic->ip = escape->ip; + + escape->valid = false; +} + +noreturn static pic_value +escape_call(pic_state *pic) +{ + size_t argc; + pic_value *argv; + struct pic_data *e; + + pic_get_args(pic, "*", &argc, &argv); + + e = pic_data_ptr(pic_attr_ref(pic, pic_obj_value(pic_get_proc(pic)), "@@escape")); + + pic_load_point(pic, e->data); + + longjmp(((struct pic_escape *)e->data)->jmp, 1); +} + +struct pic_proc * +pic_make_econt(pic_state *pic, struct pic_escape *escape) +{ + static const pic_data_type escape_type = { "escape", pic_free, NULL }; + struct pic_proc *cont; + struct pic_data *e; + + cont = pic_make_proc(pic, escape_call, ""); + + e = pic_data_alloc(pic, &escape_type, escape); + + /* save the escape continuation in proc */ + pic_attr_set(pic, pic_obj_value(cont), "@@escape", pic_obj_value(e)); + + return cont; +} + +pic_value +pic_escape(pic_state *pic, struct pic_proc *proc) +{ + struct pic_escape *escape = pic_alloc(pic, sizeof(struct pic_escape)); + + pic_save_point(pic, escape); + + if (setjmp(escape->jmp)) { + return pic_values_by_list(pic, escape->results); + } + else { + pic_value val; + + val = pic_apply1(pic, proc, pic_obj_value(pic_make_econt(pic, escape))); + + escape->valid = false; + + return val; + } +} + +pic_value +pic_values0(pic_state *pic) +{ + return pic_values_by_list(pic, pic_nil_value()); +} + +pic_value +pic_values1(pic_state *pic, pic_value arg1) +{ + return pic_values_by_list(pic, pic_list1(pic, arg1)); +} + +pic_value +pic_values2(pic_state *pic, pic_value arg1, pic_value arg2) +{ + return pic_values_by_list(pic, pic_list2(pic, arg1, arg2)); +} + +pic_value +pic_values3(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3) +{ + return pic_values_by_list(pic, pic_list3(pic, arg1, arg2, arg3)); +} + +pic_value +pic_values4(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4) +{ + return pic_values_by_list(pic, pic_list4(pic, arg1, arg2, arg3, arg4)); +} + +pic_value +pic_values5(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4, pic_value arg5) +{ + return pic_values_by_list(pic, pic_list5(pic, arg1, arg2, arg3, arg4, arg5)); +} + +pic_value +pic_values_by_array(pic_state *pic, size_t argc, pic_value *argv) +{ + size_t i; + + for (i = 0; i < argc; ++i) { + pic->sp[i] = argv[i]; + } + pic->ci->retc = (int)argc; + + return argc == 0 ? pic_none_value() : pic->sp[0]; +} + +pic_value +pic_values_by_list(pic_state *pic, pic_value list) +{ + pic_value v; + int i; + + i = 0; + pic_for_each (v, list) { + pic->sp[i++] = v; + } + pic->ci->retc = i; + + return pic_nil_p(list) ? pic_none_value() : pic->sp[0]; +} + +size_t +pic_receive(pic_state *pic, size_t n, pic_value *argv) +{ + pic_callinfo *ci; + size_t i, retc; + + /* take info from discarded frame */ + ci = pic->ci + 1; + retc = (size_t)ci->retc; + + for (i = 0; i < retc && i < n; ++i) { + argv[i] = ci->fp[i]; + } + + return retc; +} + +static pic_value +pic_cont_callcc(pic_state *pic) +{ + struct pic_proc *cb; + + pic_get_args(pic, "l", &cb); + + return pic_escape(pic, cb); +} + +static pic_value +pic_cont_dynamic_wind(pic_state *pic) +{ + struct pic_proc *in, *thunk, *out; + + pic_get_args(pic, "lll", &in, &thunk, &out); + + return pic_dynamic_wind(pic, in, thunk, out); +} + +static pic_value +pic_cont_values(pic_state *pic) +{ + size_t argc; + pic_value *argv; + + pic_get_args(pic, "*", &argc, &argv); + + return pic_values_by_array(pic, argc, argv); +} + +static pic_value +pic_cont_call_with_values(pic_state *pic) +{ + struct pic_proc *producer, *consumer; + size_t argc; + pic_value args[256]; + + pic_get_args(pic, "ll", &producer, &consumer); + + pic_apply(pic, producer, pic_nil_value()); + + argc = pic_receive(pic, 256, args); + + return pic_apply_trampoline(pic, consumer, pic_list_by_array(pic, argc, args)); +} + +void +pic_init_cont(pic_state *pic) +{ + pic_defun(pic, "call-with-current-continuation", pic_cont_callcc); + pic_defun(pic, "call/cc", pic_cont_callcc); + pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind); + pic_defun(pic, "values", pic_cont_values); + pic_defun(pic, "call-with-values", pic_cont_call_with_values); +} diff --git a/extlib/benz/data.c b/extlib/benz/data.c new file mode 100644 index 00000000..5d586c56 --- /dev/null +++ b/extlib/benz/data.c @@ -0,0 +1,15 @@ +#include "picrin.h" +#include "picrin/data.h" + +struct pic_data * +pic_data_alloc(pic_state *pic, const pic_data_type *type, void *userdata) +{ + struct pic_data *data; + + data = (struct pic_data *)pic_obj_alloc(pic, sizeof(struct pic_data), PIC_TT_DATA); + data->type = type; + data->data = userdata; + xh_init_str(&data->storage, sizeof(pic_value)); + + return data; +} diff --git a/extlib/benz/debug.c b/extlib/benz/debug.c new file mode 100644 index 00000000..bb9f711d --- /dev/null +++ b/extlib/benz/debug.c @@ -0,0 +1,69 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/string.h" +#include "picrin/error.h" +#include "picrin/proc.h" + +pic_str * +pic_get_backtrace(pic_state *pic) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_callinfo *ci; + pic_str *trace; + + trace = pic_make_str(pic, NULL, 0); + + for (ci = pic->ci; ci != pic->cibase; --ci) { + struct pic_proc *proc = pic_proc_ptr(ci->fp[0]); + + trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, " at ")); + trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, pic_symbol_name(pic, pic_proc_name(proc)))); + + if (pic_proc_func_p(proc)) { + trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, " (native function)\n")); + } else if (pic_proc_irep_p(proc)) { + trace = pic_strcat(pic, trace, pic_make_str_cstr(pic, " (unknown location)\n")); /* TODO */ + } + } + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, pic_obj_value(trace)); + + return trace; +} + +void +pic_print_backtrace(pic_state *pic) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_str *trace; + + assert(! pic_undef_p(pic->err)); + + if (! pic_error_p(pic->err)) { + trace = pic_format(pic, "raised: ~s", pic->err); + } else { + struct pic_error *e; + + e = pic_error_ptr(pic->err); + if (e->type != pic_intern_cstr(pic, "")) { + trace = pic_format(pic, "~s ", pic_sym_value(e->type)); + } else { + trace = pic_make_str(pic, NULL, 0); + } + trace = pic_strcat(pic, trace, pic_format(pic, "error: ~s", pic_obj_value(e->msg))); + + /* TODO: print error irritants */ + + trace = pic_strcat(pic, trace, pic_make_str(pic, "\n", 1)); + trace = pic_strcat(pic, trace, e->stack); + } + + /* print! */ + xfprintf(xstderr, "%s", pic_str_cstr(trace)); + + pic_gc_arena_restore(pic, ai); +} diff --git a/extlib/benz/dict.c b/extlib/benz/dict.c new file mode 100644 index 00000000..81bdea68 --- /dev/null +++ b/extlib/benz/dict.c @@ -0,0 +1,303 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/dict.h" +#include "picrin/cont.h" +#include "picrin/pair.h" + +static int +xh_value_hash(const void *key, void *data) +{ + union { double f; int i; } u; + pic_value val = *(pic_value *)key; + int hash, vtype; + + UNUSED(data); + + vtype = pic_vtype(val); + + switch (vtype) { + default: + hash = 0; + break; + case PIC_VTYPE_SYMBOL: + hash = pic_sym(val); + break; + case PIC_VTYPE_FLOAT: + u.f = pic_float(val); + hash = u.i; + break; + case PIC_VTYPE_INT: + hash = pic_int(val); + break; + case PIC_VTYPE_HEAP: + hash = (int)(intptr_t)pic_ptr(val); + break; + } + + return hash + vtype; +} + +static int +xh_value_equal(const void *key1, const void *key2, void *pic) +{ + return pic_equal_p(pic, *(pic_value *)key1, *(pic_value *)key2); +} + +static void +xh_init_value(pic_state *pic, xhash *x) +{ + xh_init_(x, sizeof(pic_value), sizeof(pic_value), xh_value_hash, xh_value_equal, pic); +} + +static inline xh_entry * +xh_get_value(xhash *x, pic_value key) +{ + return xh_get_(x, &key); +} + +static inline xh_entry * +xh_put_value(xhash *x, pic_value key, void *val) +{ + return xh_put_(x, &key, val); +} + +static inline void +xh_del_value(xhash *x, pic_value key) +{ + xh_del_(x, &key); +} + +struct pic_dict * +pic_make_dict(pic_state *pic) +{ + struct pic_dict *dict; + + dict = (struct pic_dict *)pic_obj_alloc(pic, sizeof(struct pic_dict), PIC_TT_DICT); + xh_init_value(pic, &dict->hash); + + return dict; +} + +pic_value +pic_dict_ref(pic_state *pic, struct pic_dict *dict, pic_value key) +{ + xh_entry *e; + + e = xh_get_value(&dict->hash, key); + if (! e) { + pic_errorf(pic, "element not found for a key: ~s", key); + } + return xh_val(e, pic_value); +} + +void +pic_dict_set(pic_state *pic, struct pic_dict *dict, pic_value key, pic_value val) +{ + UNUSED(pic); + + xh_put_value(&dict->hash, key, &val); +} + +size_t +pic_dict_size(pic_state *pic, struct pic_dict *dict) +{ + UNUSED(pic); + + return dict->hash.count; +} + +bool +pic_dict_has(pic_state *pic, struct pic_dict *dict, pic_value key) +{ + UNUSED(pic); + + return xh_get_value(&dict->hash, key) != NULL; +} + +void +pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_value key) +{ + if (xh_get_value(&dict->hash, key) == NULL) { + pic_errorf(pic, "no slot named ~s found in dictionary", key); + } + + xh_del_value(&dict->hash, key); +} + +static pic_value +pic_dict_make_dictionary(pic_state *pic) +{ + struct pic_dict *dict; + + pic_get_args(pic, ""); + + dict = pic_make_dict(pic); + + return pic_obj_value(dict); +} + +static pic_value +pic_dict_dictionary(pic_state *pic) +{ + struct pic_dict *dict; + pic_value *argv; + size_t argc, i; + + pic_get_args(pic, "*", &argc, &argv); + + dict = pic_make_dict(pic); + + for (i = 0; i < argc; i += 2) { + pic_dict_set(pic, dict, argv[i], argv[i+1]); + } + + return pic_obj_value(dict); +} + +static pic_value +pic_dict_dictionary_p(pic_state *pic) +{ + pic_value obj; + + pic_get_args(pic, "o", &obj); + + return pic_bool_value(pic_dict_p(obj)); +} + +static pic_value +pic_dict_dictionary_ref(pic_state *pic) +{ + struct pic_dict *dict; + pic_value key; + + pic_get_args(pic, "do", &dict, &key); + + if (pic_dict_has(pic, dict, key)) { + return pic_values2(pic, pic_dict_ref(pic, dict, key), pic_true_value()); + } else { + return pic_values2(pic, pic_none_value(), pic_false_value()); + } +} + +static pic_value +pic_dict_dictionary_set(pic_state *pic) +{ + struct pic_dict *dict; + pic_value key, val; + + pic_get_args(pic, "doo", &dict, &key, &val); + + pic_dict_set(pic, dict, key, val); + + return pic_none_value(); +} + +static pic_value +pic_dict_dictionary_del(pic_state *pic) +{ + struct pic_dict *dict; + pic_value key; + + pic_get_args(pic, "do", &dict, &key); + + pic_dict_del(pic, dict, key); + + return pic_none_value(); +} + +static pic_value +pic_dict_dictionary_size(pic_state *pic) +{ + struct pic_dict *dict; + + pic_get_args(pic, "d", &dict); + + return pic_size_value(pic_dict_size(pic, dict)); +} + +static pic_value +pic_dict_dictionary_to_alist(pic_state *pic) +{ + struct pic_dict *dict; + pic_value item, alist = pic_nil_value(); + xh_entry *it; + + pic_get_args(pic, "d", &dict); + + for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) { + item = pic_cons(pic, xh_key(it, pic_value), xh_val(it, pic_value)); + pic_push(pic, item, alist); + } + + return pic_reverse(pic, alist); +} + +static pic_value +pic_dict_alist_to_dictionary(pic_state *pic) +{ + struct pic_dict *dict; + pic_value alist, e; + + pic_get_args(pic, "o", &alist); + + dict = pic_make_dict(pic); + + pic_for_each (e, pic_reverse(pic, alist)) { + pic_dict_set(pic, dict, pic_car(pic, e), pic_cdr(pic, e)); + } + + return pic_obj_value(dict); +} + +static pic_value +pic_dict_dictionary_to_plist(pic_state *pic) +{ + struct pic_dict *dict; + pic_value plist = pic_nil_value(); + xh_entry *it; + + pic_get_args(pic, "d", &dict); + + for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) { + pic_push(pic, xh_key(it, pic_value), plist); + pic_push(pic, xh_val(it, pic_value), plist); + } + + return pic_reverse(pic, plist); +} + +static pic_value +pic_dict_plist_to_dictionary(pic_state *pic) +{ + struct pic_dict *dict; + pic_value plist, e; + + pic_get_args(pic, "o", &plist); + + dict = pic_make_dict(pic); + + for (e = pic_reverse(pic, plist); ! pic_nil_p(e); e = pic_cddr(pic, e)) { + pic_dict_set(pic, dict, pic_cadr(pic, e), pic_car(pic, e)); + } + + return pic_obj_value(dict); +} + +void +pic_init_dict(pic_state *pic) +{ + pic_defun(pic, "make-dictionary", pic_dict_make_dictionary); + pic_defun(pic, "dictionary?", pic_dict_dictionary_p); + pic_defun(pic, "dictionary", pic_dict_dictionary); + pic_defun(pic, "dictionary-ref", pic_dict_dictionary_ref); + pic_defun(pic, "dictionary-set!", pic_dict_dictionary_set); + pic_defun(pic, "dictionary-delete!", pic_dict_dictionary_del); + pic_defun(pic, "dictionary-size", pic_dict_dictionary_size); + pic_defun(pic, "dictionary->alist", pic_dict_dictionary_to_alist); + pic_defun(pic, "alist->dictionary", pic_dict_alist_to_dictionary); + pic_defun(pic, "dictionary->plist", pic_dict_dictionary_to_plist); + pic_defun(pic, "plist->dictionary", pic_dict_plist_to_dictionary); +} diff --git a/extlib/benz/error.c b/extlib/benz/error.c new file mode 100644 index 00000000..3b462969 --- /dev/null +++ b/extlib/benz/error.c @@ -0,0 +1,324 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include +#include +#include + +#include "picrin.h" +#include "picrin/pair.h" +#include "picrin/proc.h" +#include "picrin/cont.h" +#include "picrin/data.h" +#include "picrin/string.h" +#include "picrin/error.h" + +void +pic_panic(pic_state *pic, const char *msg) +{ + UNUSED(pic); + + fprintf(stderr, "abort: %s\n", msg); + abort(); +} + +void +pic_warnf(pic_state *pic, const char *fmt, ...) +{ + va_list ap; + pic_value err_line; + + va_start(ap, fmt); + err_line = pic_xvformat(pic, fmt, ap); + va_end(ap); + + fprintf(stderr, "warn: %s\n", pic_str_cstr(pic_str_ptr(pic_car(pic, err_line)))); +} + +void +pic_errorf(pic_state *pic, const char *fmt, ...) +{ + va_list ap; + pic_value err_line, irrs; + const char *msg; + + va_start(ap, fmt); + err_line = pic_xvformat(pic, fmt, ap); + va_end(ap); + + msg = pic_str_cstr(pic_str_ptr(pic_car(pic, err_line))); + irrs = pic_cdr(pic, err_line); + + pic_error(pic, msg, irrs); +} + +const char * +pic_errmsg(pic_state *pic) +{ + pic_str *str; + + assert(! pic_undef_p(pic->err)); + + if (! pic_error_p(pic->err)) { + str = pic_format(pic, "~s", pic->err); + } else { + str = pic_error_ptr(pic->err)->msg; + } + + return pic_str_cstr(str); +} + +noreturn static pic_value +native_exception_handler(pic_state *pic) +{ + pic_value err; + struct pic_proc *cont; + + pic_get_args(pic, "o", &err); + + pic->err = err; + + cont = pic_proc_ptr(pic_attr_ref(pic, pic_obj_value(pic_get_proc(pic)), "@@escape")); + + pic_apply1(pic, cont, pic_false_value()); + + UNREACHABLE(); +} + +void +pic_push_try(pic_state *pic, struct pic_escape *escape) +{ + struct pic_proc *cont, *handler; + size_t xp_len; + ptrdiff_t xp_offset; + + cont = pic_make_econt(pic, escape); + + handler = pic_make_proc(pic, native_exception_handler, "(native-exception-handler)"); + + pic_attr_set(pic, pic_obj_value(handler), "@@escape", pic_obj_value(cont)); + + if (pic->xp >= pic->xpend) { + xp_len = (size_t)(pic->xpend - pic->xpbase) * 2; + xp_offset = pic->xp - pic->xpbase; + pic->xpbase = pic_realloc(pic, pic->xpbase, sizeof(struct pic_proc *) * xp_len); + pic->xp = pic->xpbase + xp_offset; + pic->xpend = pic->xpbase + xp_len; + } + + *pic->xp++ = handler; +} + +void +pic_pop_try(pic_state *pic) +{ + pic_value cont, escape; + + assert(pic->xp > pic->xpbase); + + cont = pic_attr_ref(pic, pic_obj_value(*--pic->xp), "@@escape"); + + assert(pic_proc_p(cont)); + + escape = pic_attr_ref(pic, cont, "@@escape"); + + assert(pic_data_p(escape)); + + ((struct pic_escape *)pic_data_ptr(escape)->data)->valid = false; +} + +struct pic_error * +pic_make_error(pic_state *pic, pic_sym type, const char *msg, pic_value irrs) +{ + struct pic_error *e; + pic_str *stack; + + stack = pic_get_backtrace(pic); + + e = (struct pic_error *)pic_obj_alloc(pic, sizeof(struct pic_error), PIC_TT_ERROR); + e->type = type; + e->msg = pic_make_str_cstr(pic, msg); + e->irrs = irrs; + e->stack = stack; + + return e; +} + +pic_value +pic_raise_continuable(pic_state *pic, pic_value err) +{ + struct pic_proc *handler; + pic_value v; + + if (pic->xp == pic->xpbase) { + pic_panic(pic, "no exception handler registered"); + } + + handler = *--pic->xp; + + pic_gc_protect(pic, pic_obj_value(handler)); + + v = pic_apply1(pic, handler, err); + + *pic->xp++ = handler; + + return v; +} + +noreturn void +pic_raise(pic_state *pic, pic_value err) +{ + pic_value val; + + val = pic_raise_continuable(pic, err); + + pic_pop_try(pic); + + pic_errorf(pic, "error handler returned with ~s on error ~s", val, err); +} + +noreturn void +pic_throw(pic_state *pic, pic_sym type, const char *msg, pic_value irrs) +{ + struct pic_error *e; + + e = pic_make_error(pic, type, msg, irrs); + + pic_raise(pic, pic_obj_value(e)); +} + +noreturn void +pic_error(pic_state *pic, const char *msg, pic_value irrs) +{ + pic_throw(pic, pic_intern_cstr(pic, ""), msg, irrs); +} + +static pic_value +pic_error_with_exception_handler(pic_state *pic) +{ + struct pic_proc *handler, *thunk; + pic_value val; + size_t xp_len; + ptrdiff_t xp_offset; + + pic_get_args(pic, "ll", &handler, &thunk); + + if (pic->xp >= pic->xpend) { + xp_len = (size_t)(pic->xpend - pic->xpbase) * 2; + xp_offset = pic->xp - pic->xpbase; + pic->xpbase = pic_realloc(pic, pic->xpbase, sizeof(struct pic_proc *) * xp_len); + pic->xp = pic->xpbase + xp_offset; + pic->xpend = pic->xpbase + xp_len; + } + + *pic->xp++ = handler; + + val = pic_apply0(pic, thunk); + + --pic->xp; + + return val; +} + +noreturn static pic_value +pic_error_raise(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + pic_raise(pic, v); +} + +static pic_value +pic_error_raise_continuable(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_raise_continuable(pic, v); +} + +noreturn static pic_value +pic_error_error(pic_state *pic) +{ + const char *str; + size_t argc; + pic_value *argv; + + pic_get_args(pic, "z*", &str, &argc, &argv); + + pic_error(pic, str, pic_list_by_array(pic, argc, argv)); +} + +static pic_value +pic_error_make_error_object(pic_state *pic) +{ + struct pic_error *e; + pic_sym type; + pic_str *msg; + size_t argc; + pic_value *argv; + + pic_get_args(pic, "ms*", &type, &msg, &argc, &argv); + + e = pic_make_error(pic, type, pic_str_cstr(msg), pic_list_by_array(pic, argc, argv)); + + return pic_obj_value(e); +} + +static pic_value +pic_error_error_object_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_error_p(v)); +} + +static pic_value +pic_error_error_object_message(pic_state *pic) +{ + struct pic_error *e; + + pic_get_args(pic, "e", &e); + + return pic_obj_value(e->msg); +} + +static pic_value +pic_error_error_object_irritants(pic_state *pic) +{ + struct pic_error *e; + + pic_get_args(pic, "e", &e); + + return e->irrs; +} + +static pic_value +pic_error_error_object_type(pic_state *pic) +{ + struct pic_error *e; + + pic_get_args(pic, "e", &e); + + return pic_sym_value(e->type); +} + +void +pic_init_error(pic_state *pic) +{ + pic_defun(pic, "with-exception-handler", pic_error_with_exception_handler); + pic_defun(pic, "raise", pic_error_raise); + pic_defun(pic, "raise-continuable", pic_error_raise_continuable); + pic_defun(pic, "error", pic_error_error); + pic_defun(pic, "make-error-object", pic_error_make_error_object); + pic_defun(pic, "error-object?", pic_error_error_object_p); + pic_defun(pic, "error-object-message", pic_error_error_object_message); + pic_defun(pic, "error-object-irritants", pic_error_error_object_irritants); + pic_defun(pic, "error-object-type", pic_error_error_object_type); +} diff --git a/extlib/benz/eval.c b/extlib/benz/eval.c new file mode 100644 index 00000000..d8712760 --- /dev/null +++ b/extlib/benz/eval.c @@ -0,0 +1,37 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/macro.h" + +pic_value +pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib) +{ + struct pic_proc *proc; + + proc = pic_compile(pic, program, lib); + + return pic_apply(pic, proc, pic_nil_value()); +} + +static pic_value +pic_eval_eval(pic_state *pic) +{ + pic_value program, spec; + struct pic_lib *lib; + + pic_get_args(pic, "oo", &program, &spec); + + lib = pic_find_library(pic, spec); + if (lib == NULL) { + pic_errorf(pic, "no library found: ~s", spec); + } + return pic_eval(pic, program, lib); +} + +void +pic_init_eval(pic_state *pic) +{ + pic_defun(pic, "eval", pic_eval_eval); +} diff --git a/extlib/benz/file.c b/extlib/benz/file.c new file mode 100644 index 00000000..4a5f57d7 --- /dev/null +++ b/extlib/benz/file.c @@ -0,0 +1,117 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/port.h" +#include "picrin/error.h" + +static noreturn void +file_error(pic_state *pic, const char *msg) +{ + pic_throw(pic, pic->sFILE, msg, pic_nil_value()); +} + +static pic_value +generic_open_file(pic_state *pic, const char *fname, char *mode, short flags) +{ + struct pic_port *port; + xFILE *file; + + file = xfopen(fname, mode); + if (! file) { + file_error(pic, "could not open file"); + } + + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); + port->file = file; + port->flags = flags; + port->status = PIC_PORT_OPEN; + + return pic_obj_value(port); +} + +pic_value +pic_file_open_input_file(pic_state *pic) +{ + static const short flags = PIC_PORT_IN | PIC_PORT_TEXT; + char *fname; + + pic_get_args(pic, "z", &fname); + + return generic_open_file(pic, fname, "r", flags); +} + +pic_value +pic_file_open_binary_input_file(pic_state *pic) +{ + static const short flags = PIC_PORT_IN | PIC_PORT_BINARY; + char *fname; + + pic_get_args(pic, "z", &fname); + + return generic_open_file(pic, fname, "rb", flags); +} + +pic_value +pic_file_open_output_file(pic_state *pic) +{ + static const short flags = PIC_PORT_OUT | PIC_PORT_TEXT; + char *fname; + + pic_get_args(pic, "z", &fname); + + return generic_open_file(pic, fname, "w", flags); +} + +pic_value +pic_file_open_binary_output_file(pic_state *pic) +{ + static const short flags = PIC_PORT_OUT | PIC_PORT_BINARY; + char *fname; + + pic_get_args(pic, "z", &fname); + + return generic_open_file(pic, fname, "wb", flags); +} + +pic_value +pic_file_exists_p(pic_state *pic) +{ + char *fname; + FILE *fp; + + pic_get_args(pic, "z", &fname); + + fp = fopen(fname, "r"); + if (fp) { + fclose(fp); + return pic_true_value(); + } else { + return pic_false_value(); + } +} + +pic_value +pic_file_delete(pic_state *pic) +{ + char *fname; + + pic_get_args(pic, "z", &fname); + + if (remove(fname) != 0) { + file_error(pic, "file cannot be deleted"); + } + return pic_none_value(); +} + +void +pic_init_file(pic_state *pic) +{ + pic_defun(pic, "open-input-file", pic_file_open_input_file); + pic_defun(pic, "open-binary-input-file", pic_file_open_binary_input_file); + pic_defun(pic, "open-output-file", pic_file_open_output_file); + pic_defun(pic, "open-binary-output-file", pic_file_open_binary_output_file); + pic_defun(pic, "file-exists?", pic_file_exists_p); + pic_defun(pic, "delete-file", pic_file_delete); +} diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c new file mode 100644 index 00000000..7768f8b9 --- /dev/null +++ b/extlib/benz/gc.c @@ -0,0 +1,853 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/gc.h" +#include "picrin/pair.h" +#include "picrin/string.h" +#include "picrin/vector.h" +#include "picrin/irep.h" +#include "picrin/proc.h" +#include "picrin/port.h" +#include "picrin/blob.h" +#include "picrin/cont.h" +#include "picrin/error.h" +#include "picrin/macro.h" +#include "picrin/lib.h" +#include "picrin/data.h" +#include "picrin/dict.h" +#include "picrin/record.h" +#include "picrin/read.h" + +#if GC_DEBUG +# include +#endif + +union header { + struct { + union header *ptr; + size_t size; + unsigned int mark : 1; + } s; + long alignment[4]; +}; + +struct heap_page { + union header *basep, *endp; + struct heap_page *next; +}; + +struct pic_heap { + union header base, *freep; + struct heap_page *pages; +}; + + +static void +heap_init(struct pic_heap *heap) +{ + heap->base.s.ptr = &heap->base; + heap->base.s.size = 0; /* not 1, since it must never be used for allocation */ + heap->base.s.mark = PIC_GC_UNMARK; + + heap->freep = &heap->base; + heap->pages = NULL; + +#if GC_DEBUG + printf("freep = %p\n", (void *)heap->freep); +#endif +} + +struct pic_heap * +pic_heap_open() +{ + struct pic_heap *heap; + + heap = (struct pic_heap *)calloc(1, sizeof(struct pic_heap)); + heap_init(heap); + return heap; +} + +void +pic_heap_close(struct pic_heap *heap) +{ + struct heap_page *page; + + while (heap->pages) { + page = heap->pages; + heap->pages = heap->pages->next; + free(page); + } +} + +static void gc_free(pic_state *, union header *); + +static void +add_heap_page(pic_state *pic) +{ + union header *up, *np; + struct heap_page *page; + size_t nu; + +#if GC_DEBUG + puts("adding heap page!"); +#endif + + nu = (PIC_HEAP_PAGE_SIZE + sizeof(union header) - 1) / sizeof(union header) + 1; + + up = (union header *)pic_calloc(pic, 1 + nu + 1, sizeof(union header)); + up->s.size = nu + 1; + up->s.mark = PIC_GC_UNMARK; + gc_free(pic, up); + + np = up + 1; + np->s.size = nu; + np->s.ptr = up->s.ptr; + up->s.size = 1; + up->s.ptr = np; + + page = (struct heap_page *)pic_alloc(pic, sizeof(struct heap_page)); + page->basep = up; + page->endp = up + nu + 1; + page->next = pic->heap->pages; + + pic->heap->pages = page; +} + +static void * +alloc(void *ptr, size_t size) +{ + if (size == 0) { + if (ptr) { + free(ptr); + } + return NULL; + } + if (ptr) { + return realloc(ptr, size); + } else { + return malloc(size); + } +} + +void * +pic_alloc(pic_state *pic, size_t size) +{ + void *ptr; + + ptr = alloc(NULL, size); + if (ptr == NULL && size > 0) { + pic_panic(pic, "memory exhausted"); + } + return ptr; +} + +void * +pic_realloc(pic_state *pic, void *ptr, size_t size) +{ + ptr = alloc(ptr, size); + if (ptr == NULL && size > 0) { + pic_panic(pic, "memory exhausted"); + } + return ptr; +} + +void * +pic_calloc(pic_state *pic, size_t count, size_t size) +{ + void *ptr; + + size *= count; + ptr = alloc(NULL, size); + if (ptr == NULL && size > 0) { + pic_panic(pic, "memory exhausted"); + } + memset(ptr, 0, size); + return ptr; +} + +void +pic_free(pic_state *pic, void *ptr) +{ + UNUSED(pic); + + free(ptr); +} + +static void +gc_protect(pic_state *pic, struct pic_object *obj) +{ + if (pic->arena_idx >= pic->arena_size) { + pic->arena_size = pic->arena_size * 2 + 1; + pic->arena = pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * pic->arena_size); + } + pic->arena[pic->arena_idx++] = obj; +} + +pic_value +pic_gc_protect(pic_state *pic, pic_value v) +{ + struct pic_object *obj; + + if (pic_vtype(v) != PIC_VTYPE_HEAP) { + return v; + } + obj = pic_obj_ptr(v); + + gc_protect(pic, obj); + + return v; +} + +size_t +pic_gc_arena_preserve(pic_state *pic) +{ + return pic->arena_idx; +} + +void +pic_gc_arena_restore(pic_state *pic, size_t state) +{ + pic->arena_idx = state; +} + +static void * +gc_alloc(pic_state *pic, size_t size) +{ + union header *freep, *p, *prevp; + size_t nunits; + +#if GC_DEBUG + assert(size > 0); +#endif + + nunits = (size + sizeof(union header) - 1) / sizeof(union header) + 1; + + prevp = freep = pic->heap->freep; + for (p = prevp->s.ptr; ; prevp = p, p = p->s.ptr) { + if (p->s.size >= nunits) + break; + if (p == freep) { + return NULL; + } + } + +#if GC_DEBUG + { + unsigned char *c; + size_t s, i, j; + if (p->s.size == nunits) { + c = (unsigned char *)(p + p->s.size - nunits + 1); + s = nunits - 1; + } else { + c = (unsigned char *)(p + p->s.size - nunits); + s = nunits; + } + + for (i = 0; i < s; ++i) { + for (j = 0; j < sizeof(union header); ++j) { + assert(c[i * sizeof(union header) + j] == 0xAA); + } + } + } +#endif + + if (p->s.size == nunits) { + prevp->s.ptr = p->s.ptr; + } + else { + p->s.size -= nunits; + p += p->s.size; + p->s.size = nunits; + } + pic->heap->freep = prevp; + + p->s.mark = PIC_GC_UNMARK; + +#if GC_DEBUG + memset(p+1, 0, sizeof(union header) * (nunits - 1)); + p->s.ptr = (union header *)0xcafebabe; +#endif + + return (void *)(p + 1); +} + +static void +gc_free(pic_state *pic, union header *bp) +{ + union header *freep, *p; + +#if GC_DEBUG + assert(bp != NULL); + assert(bp->s.size > 1); +#endif + +#if GC_DEBUG + memset(bp + 1, 0xAA, (bp->s.size - 1) * sizeof(union header)); +#endif + + freep = pic->heap->freep; + for (p = freep; ! (bp > p && bp < p->s.ptr); p = p->s.ptr) { + if (p >= p->s.ptr && (bp > p || bp < p->s.ptr)) { + break; + } + } + if (bp + bp->s.size == p->s.ptr) { + bp->s.size += p->s.ptr->s.size; + bp->s.ptr = p->s.ptr->s.ptr; + +#if GC_DEBUG + memset(p->s.ptr, 0xAA, sizeof(union header)); +#endif + } + else { + bp->s.ptr = p->s.ptr; + } + if (p + p->s.size == bp && p->s.size > 1) { + p->s.size += bp->s.size; + p->s.ptr = bp->s.ptr; + +#if GC_DEBUG + memset(bp, 0xAA, sizeof(union header)); +#endif + } + else { + p->s.ptr = bp; + } + pic->heap->freep = p; +} + +static void gc_mark(pic_state *, pic_value); +static void gc_mark_object(pic_state *pic, struct pic_object *obj); + +static bool +gc_is_marked(union header *p) +{ + return p->s.mark == PIC_GC_MARK; +} + +static bool +gc_obj_is_marked(struct pic_object *obj) +{ + union header *p; + + p = ((union header *)obj) - 1; + + return gc_is_marked(p); +} + +static void +gc_unmark(union header *p) +{ + p->s.mark = PIC_GC_UNMARK; +} + +static void +gc_mark_winder(pic_state *pic, struct pic_winder *wind) +{ + if (wind->prev) { + gc_mark_object(pic, (struct pic_object *)wind->prev); + } + if (wind->in) { + gc_mark_object(pic, (struct pic_object *)wind->in); + } + if (wind->out) { + gc_mark_object(pic, (struct pic_object *)wind->out); + } +} + +static void +gc_mark_object(pic_state *pic, struct pic_object *obj) +{ + union header *p; + + p = ((union header *)obj) - 1; + + if (gc_is_marked(p)) + return; + p->s.mark = PIC_GC_MARK; + + switch (obj->tt) { + case PIC_TT_PAIR: { + gc_mark(pic, ((struct pic_pair *)obj)->car); + gc_mark(pic, ((struct pic_pair *)obj)->cdr); + break; + } + case PIC_TT_ENV: { + struct pic_env *env = (struct pic_env *)obj; + int i; + + for (i = 0; i < env->regc; ++i) { + gc_mark(pic, env->regs[i]); + } + if (env->up) { + gc_mark_object(pic, (struct pic_object *)env->up); + } + break; + } + case PIC_TT_PROC: { + struct pic_proc *proc = (struct pic_proc *)obj; + if (proc->env) { + gc_mark_object(pic, (struct pic_object *)proc->env); + } + if (pic_proc_irep_p(proc)) { + gc_mark_object(pic, (struct pic_object *)proc->u.irep); + } + break; + } + case PIC_TT_PORT: { + break; + } + case PIC_TT_ERROR: { + struct pic_error *err = (struct pic_error *)obj; + gc_mark_object(pic,(struct pic_object *)err->msg); + gc_mark(pic, err->irrs); + gc_mark_object(pic, (struct pic_object *)err->stack); + break; + } + case PIC_TT_STRING: { + break; + } + case PIC_TT_VECTOR: { + size_t i; + for (i = 0; i < ((struct pic_vector *)obj)->len; ++i) { + gc_mark(pic, ((struct pic_vector *)obj)->data[i]); + } + break; + } + case PIC_TT_BLOB: { + break; + } + case PIC_TT_MACRO: { + struct pic_macro *mac = (struct pic_macro *)obj; + + if (mac->proc) { + gc_mark_object(pic, (struct pic_object *)mac->proc); + } + if (mac->senv) { + gc_mark_object(pic, (struct pic_object *)mac->senv); + } + break; + } + case PIC_TT_SENV: { + struct pic_senv *senv = (struct pic_senv *)obj; + + if (senv->up) { + gc_mark_object(pic, (struct pic_object *)senv->up); + } + gc_mark(pic, senv->defer); + break; + } + case PIC_TT_LIB: { + struct pic_lib *lib = (struct pic_lib *)obj; + gc_mark(pic, lib->name); + gc_mark_object(pic, (struct pic_object *)lib->env); + break; + } + case PIC_TT_IREP: { + struct pic_irep *irep = (struct pic_irep *)obj; + size_t i; + + for (i = 0; i < irep->ilen; ++i) { + gc_mark_object(pic, (struct pic_object *)irep->irep[i]); + } + for (i = 0; i < irep->plen; ++i) { + gc_mark(pic, irep->pool[i]); + } + break; + } + case PIC_TT_DATA: { + struct pic_data *data = (struct pic_data *)obj; + xh_entry *it; + + for (it = xh_begin(&data->storage); it != NULL; it = xh_next(it)) { + gc_mark(pic, xh_val(it, pic_value)); + } + if (data->type->mark) { + data->type->mark(pic, data->data, gc_mark); + } + break; + } + case PIC_TT_DICT: { + struct pic_dict *dict = (struct pic_dict *)obj; + xh_entry *it; + + for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) { + gc_mark(pic, xh_key(it, pic_value)); + gc_mark(pic, xh_val(it, pic_value)); + } + break; + } + case PIC_TT_RECORD: { + struct pic_record *rec = (struct pic_record *)obj; + xh_entry *it; + + for (it = xh_begin(&rec->hash); it != NULL; it = xh_next(it)) { + gc_mark(pic, xh_val(it, pic_value)); + } + break; + } + case PIC_TT_NIL: + case PIC_TT_BOOL: + case PIC_TT_FLOAT: + case PIC_TT_INT: + case PIC_TT_SYMBOL: + case PIC_TT_CHAR: + case PIC_TT_EOF: + case PIC_TT_UNDEF: + pic_panic(pic, "logic flaw"); + } +} + +static void +gc_mark(pic_state *pic, pic_value v) +{ + struct pic_object *obj; + + if (pic_vtype(v) != PIC_VTYPE_HEAP) + return; + obj = pic_obj_ptr(v); + + gc_mark_object(pic, obj); +} + +static void +gc_mark_trie(pic_state *pic, struct pic_trie *trie) +{ + size_t i; + + for (i = 0; i < sizeof trie->table / sizeof(struct pic_trie *); ++i) { + if (trie->table[i] != NULL) { + gc_mark_trie(pic, trie->table[i]); + } + } + if (trie->proc != NULL) { + gc_mark_object(pic, (struct pic_object *)trie->proc); + } +} + +static void +gc_mark_phase(pic_state *pic) +{ + pic_value *stack; + pic_callinfo *ci; + struct pic_proc **xhandler; + size_t j; + xh_entry *it; + struct pic_object *obj; + + /* winder */ + if (pic->wind) { + gc_mark_winder(pic, pic->wind); + } + + /* stack */ + for (stack = pic->stbase; stack != pic->sp; ++stack) { + gc_mark(pic, *stack); + } + + /* callinfo */ + for (ci = pic->ci; ci != pic->cibase; --ci) { + if (ci->env) { + gc_mark_object(pic, (struct pic_object *)ci->env); + } + } + + /* exception handlers */ + for (xhandler = pic->xpbase; xhandler != pic->xp; ++xhandler) { + gc_mark_object(pic, (struct pic_object *)*xhandler); + } + + /* arena */ + for (j = 0; j < pic->arena_idx; ++j) { + gc_mark_object(pic, pic->arena[j]); + } + + /* global variables */ + for (it = xh_begin(&pic->globals); it != NULL; it = xh_next(it)) { + gc_mark(pic, xh_val(it, pic_value)); + } + + /* macro objects */ + for (it = xh_begin(&pic->macros); it != NULL; it = xh_next(it)) { + gc_mark_object(pic, xh_val(it, struct pic_object *)); + } + + /* error object */ + gc_mark(pic, pic->err); + + /* features */ + gc_mark(pic, pic->features); + + /* readers */ + gc_mark_trie(pic, pic->reader->trie); + + /* library table */ + gc_mark(pic, pic->libs); + + /* standard I/O ports */ + if (pic->xSTDIN) { + gc_mark_object(pic, (struct pic_object *)pic->xSTDIN); + } + if (pic->xSTDOUT) { + gc_mark_object(pic, (struct pic_object *)pic->xSTDOUT); + } + if (pic->xSTDERR) { + gc_mark_object(pic, (struct pic_object *)pic->xSTDERR); + } + + /* attributes */ + do { + j = 0; + + for (it = xh_begin(&pic->attrs); it != NULL; it = xh_next(it)) { + if (gc_obj_is_marked(xh_key(it, struct pic_object *))) { + obj = (struct pic_object *)xh_val(it, struct pic_dict *); + if (! gc_obj_is_marked(obj)) { + gc_mark_object(pic, obj); + ++j; + } + } + } + } while (j > 0); +} + +static void +gc_finalize_object(pic_state *pic, struct pic_object *obj) +{ +#if GC_DEBUG + printf("* finalizing object: %s", pic_type_repr(pic_type(pic_obj_value(obj)))); + // pic_debug(pic, pic_obj_value(obj)); + puts(""); +#endif + + switch (obj->tt) { + case PIC_TT_PAIR: { + break; + } + case PIC_TT_ENV: { + break; + } + case PIC_TT_PROC: { + break; + } + case PIC_TT_VECTOR: { + pic_free(pic, ((struct pic_vector *)obj)->data); + break; + } + case PIC_TT_BLOB: { + pic_free(pic, ((struct pic_blob *)obj)->data); + break; + } + case PIC_TT_STRING: { + XROPE_DECREF(((struct pic_string *)obj)->rope); + break; + } + case PIC_TT_PORT: { + break; + } + case PIC_TT_ERROR: { + break; + } + case PIC_TT_SENV: { + struct pic_senv *senv = (struct pic_senv *)obj; + xh_destroy(&senv->map); + break; + } + case PIC_TT_MACRO: { + break; + } + case PIC_TT_LIB: { + struct pic_lib *lib = (struct pic_lib *)obj; + xh_destroy(&lib->exports); + break; + } + case PIC_TT_IREP: { + struct pic_irep *irep = (struct pic_irep *)obj; + pic_free(pic, irep->code); + pic_free(pic, irep->irep); + pic_free(pic, irep->pool); + break; + } + case PIC_TT_DATA: { + struct pic_data *data = (struct pic_data *)obj; + data->type->dtor(pic, data->data); + xh_destroy(&data->storage); + break; + } + case PIC_TT_DICT: { + struct pic_dict *dict = (struct pic_dict *)obj; + xh_destroy(&dict->hash); + break; + } + case PIC_TT_RECORD: { + struct pic_record *rec = (struct pic_record *)obj; + xh_destroy(&rec->hash); + break; + } + case PIC_TT_NIL: + case PIC_TT_BOOL: + case PIC_TT_FLOAT: + case PIC_TT_INT: + case PIC_TT_SYMBOL: + case PIC_TT_CHAR: + case PIC_TT_EOF: + case PIC_TT_UNDEF: + pic_panic(pic, "logic flaw"); + } +} + +static void +gc_sweep_page(pic_state *pic, struct heap_page *page) +{ +#if GC_DEBUG + static union header *NIL = (union header *)0xdeadbeef; +#else + static union header *NIL = NULL; +#endif + union header *bp, *p, *s = NIL, *t = NIL; + +#if GC_DEBUG + int c = 0; +#endif + + for (bp = page->basep; ; bp = bp->s.ptr) { + for (p = bp + bp->s.size; p != bp->s.ptr; p += p->s.size) { + if (p == page->endp) { + goto escape; + } + if (! gc_is_marked(p)) { + if (s == NIL) { + s = p; + } + else { + t->s.ptr = p; + } + t = p; + t->s.ptr = NIL; /* For dead objects we can safely reuse ptr field */ + } + gc_unmark(p); + } + } + escape: + + /* free! */ + while (s != NIL) { + t = s->s.ptr; + gc_finalize_object(pic, (struct pic_object *)(s + 1)); + gc_free(pic, s); + s = t; + +#if GC_DEBUG + c++; +#endif + } + +#if GC_DEBUG + printf("freed objects count: %d\n", c); +#endif +} + +static void +gc_sweep_phase(pic_state *pic) +{ + struct heap_page *page = pic->heap->pages; + xh_entry *it, *next; + + do { + for (it = xh_begin(&pic->attrs); it != NULL; it = next) { + next = xh_next(it); + if (! gc_obj_is_marked(xh_key(it, struct pic_object *))) { + xh_del_ptr(&pic->attrs, xh_key(it, struct pic_object *)); + } + } + } while (it != NULL); + + while (page) { + gc_sweep_page(pic, page); + page = page->next; + } +} + +void +pic_gc_run(pic_state *pic) +{ +#if GC_DEBUG + struct heap_page *page; +#endif + +#if DEBUG + puts("gc run!"); +#endif + + gc_mark_phase(pic); + gc_sweep_phase(pic); + +#if GC_DEBUG + for (page = pic->heap->pages; page; page = page->next) { + union header *bp, *p; + unsigned char *c; + + for (bp = page->basep; ; bp = bp->s.ptr) { + for (c = (unsigned char *)(bp+1); c != (unsigned char *)(bp + bp->s.size); ++c) { + assert(*c == 0xAA); + } + for (p = bp + bp->s.size; p != bp->s.ptr; p += p->s.size) { + if (p == page->endp) { + /* if (page->next) */ + /* assert(bp->s.ptr == page->next->basep); */ + /* else */ + /* assert(bp->s.ptr == &pic->heap->base); */ + goto escape; + } + assert(! gc_is_marked(p)); + } + } + escape: + ((void)0); + } + + puts("not error on heap found! gc successfully finished"); +#endif +} + +struct pic_object * +pic_obj_alloc_unsafe(pic_state *pic, size_t size, enum pic_tt tt) +{ + struct pic_object *obj; + +#if GC_DEBUG + printf("*allocating: %s\n", pic_type_repr(tt)); +#endif + +#if GC_STRESS + pic_gc_run(pic); +#endif + + obj = (struct pic_object *)gc_alloc(pic, size); + if (obj == NULL) { + pic_gc_run(pic); + obj = (struct pic_object *)gc_alloc(pic, size); + if (obj == NULL) { + add_heap_page(pic); + obj = (struct pic_object *)gc_alloc(pic, size); + if (obj == NULL) + pic_panic(pic, "GC memory exhausted"); + } + } + obj->tt = tt; + + return obj; +} + +struct pic_object * +pic_obj_alloc(pic_state *pic, size_t size, enum pic_tt tt) +{ + struct pic_object *obj; + + obj = pic_obj_alloc_unsafe(pic, size, tt); + + gc_protect(pic, obj); + return obj; +} diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h new file mode 100644 index 00000000..442e06a0 --- /dev/null +++ b/extlib/benz/include/picrin.h @@ -0,0 +1,249 @@ +/** + * Copyright (c) 2013-2014 Yuichi Nishiwaki and other picrin contributors. + * + * Permission is hereby granted, free of charge, to any person obtaining + * a copy of this software and associated documentation files (the + * "Software"), to deal in the Software without restriction, including + * without limitation the rights to use, copy, modify, merge, publish, + * distribute, sublicense, and/or sell copies of the Software, and to + * permit persons to whom the Software is furnished to do so, subject to + * the following conditions: + * + * The above copyright notice and this permission notice shall be + * included in all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY + * CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, + * TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE + * SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + */ + +#ifndef PICRIN_H +#define PICRIN_H + +#if defined(__cplusplus) +extern "C" { +#endif + +#include +#include +#include +#include +#include +#include + +#include "picrin/xvect.h" +#include "picrin/xhash.h" +#include "picrin/xfile.h" +#include "picrin/xrope.h" + +#include "picrin/config.h" +#include "picrin/util.h" +#include "picrin/value.h" + +typedef struct pic_code pic_code; + +struct pic_winder { + struct pic_proc *in; + struct pic_proc *out; + int depth; + struct pic_winder *prev; +}; + +typedef struct { + int argc, retc; + pic_code *ip; + pic_value *fp; + struct pic_env *env; + int regc; + pic_value *regs; + struct pic_env *up; +} pic_callinfo; + +typedef struct { + int argc; + char **argv, **envp; + + struct pic_winder *wind; + + pic_value *sp; + pic_value *stbase, *stend; + + pic_callinfo *ci; + pic_callinfo *cibase, *ciend; + + struct pic_proc **xp; + struct pic_proc **xpbase, **xpend; + + pic_code *ip; + + struct pic_lib *lib; + + pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG; + pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING; + pic_sym sDEFINE_SYNTAX, sIMPORT, sEXPORT; + pic_sym sDEFINE_LIBRARY, sIN_LIBRARY; + pic_sym sCOND_EXPAND, sAND, sOR, sELSE, sLIBRARY; + pic_sym sONLY, sRENAME, sPREFIX, sEXCEPT; + pic_sym sCONS, sCAR, sCDR, sNILP; + pic_sym sADD, sSUB, sMUL, sDIV, sMINUS; + pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT; + pic_sym sREAD, sFILE; + + pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG; + pic_sym rDEFINE_SYNTAX, rIMPORT, rEXPORT; + pic_sym rDEFINE_LIBRARY, rIN_LIBRARY; + pic_sym rCOND_EXPAND; + + struct pic_lib *PICRIN_BASE; + struct pic_lib *PICRIN_USER; + + pic_value features; + + xhash syms; /* name to symbol */ + xhash sym_names; /* symbol to name */ + int sym_cnt; + int uniq_sym_cnt; + + xhash globals; + xhash macros; + pic_value libs; + xhash attrs; + + struct pic_reader *reader; + + struct pic_heap *heap; + struct pic_object **arena; + size_t arena_size, arena_idx; + + struct pic_port *xSTDIN, *xSTDOUT, *xSTDERR; + + pic_value err; + + char *native_stack_start; +} pic_state; + +typedef pic_value (*pic_func_t)(pic_state *); + +void *pic_alloc(pic_state *, size_t); +#define pic_malloc(pic,size) pic_alloc(pic,size) /* obsoleted */ +void *pic_realloc(pic_state *, void *, size_t); +void *pic_calloc(pic_state *, size_t, size_t); +struct pic_object *pic_obj_alloc(pic_state *, size_t, enum pic_tt); +struct pic_object *pic_obj_alloc_unsafe(pic_state *, size_t, enum pic_tt); +void pic_free(pic_state *, void *); + +void pic_gc_run(pic_state *); +pic_value pic_gc_protect(pic_state *, pic_value); +size_t pic_gc_arena_preserve(pic_state *); +void pic_gc_arena_restore(pic_state *, size_t); +#define pic_void(exec) \ + pic_void_(GENSYM(ai), exec) +#define pic_void_(ai,exec) do { \ + size_t ai = pic_gc_arena_preserve(pic); \ + exec; \ + pic_gc_arena_restore(pic, ai); \ + } while (0) + +pic_state *pic_open(int argc, char *argv[], char **envp); +void pic_close(pic_state *); + +void pic_add_feature(pic_state *, const char *); + +void pic_define(pic_state *, const char *, pic_value); +void pic_define_noexport(pic_state *, const char *, pic_value); +void pic_defun(pic_state *, const char *, pic_func_t); + +struct pic_proc *pic_make_var(pic_state *, pic_value, struct pic_proc *); +void pic_defvar(pic_state *, const char *, pic_value, struct pic_proc *); + +struct pic_proc *pic_get_proc(pic_state *); +int pic_get_args(pic_state *, const char *, ...); + +bool pic_eq_p(pic_value, pic_value); +bool pic_eqv_p(pic_value, pic_value); +bool pic_equal_p(pic_state *, pic_value, pic_value); + +pic_sym pic_intern(pic_state *, const char *, size_t); +pic_sym pic_intern_str(pic_state *, pic_str *); +pic_sym pic_intern_cstr(pic_state *, const char *); +const char *pic_symbol_name(pic_state *, pic_sym); +pic_sym pic_gensym(pic_state *, pic_sym); +pic_sym pic_ungensym(pic_state *, pic_sym); +bool pic_interned_p(pic_state *, pic_sym); + +pic_value pic_read(pic_state *, struct pic_port *); +pic_value pic_read_cstr(pic_state *, const char *); + +void pic_load(pic_state *, const char *); +void pic_load_cstr(pic_state *, const char *); + +pic_value pic_funcall(pic_state *pic, struct pic_lib *, const char *, pic_list); +pic_value pic_ref(pic_state *, struct pic_lib *, const char *); +void pic_set(pic_state *, struct pic_lib *, const char *, pic_value); + +pic_value pic_apply(pic_state *, struct pic_proc *, pic_value); +pic_value pic_apply0(pic_state *, struct pic_proc *); +pic_value pic_apply1(pic_state *, struct pic_proc *, pic_value); +pic_value pic_apply2(pic_state *, struct pic_proc *, pic_value, pic_value); +pic_value pic_apply3(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value); +pic_value pic_apply4(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value); +pic_value pic_apply5(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value, pic_value); +pic_value pic_apply_trampoline(pic_state *, struct pic_proc *, pic_value); +pic_value pic_eval(pic_state *, pic_value, struct pic_lib *); +struct pic_proc *pic_compile(pic_state *, pic_value, struct pic_lib *); +pic_value pic_macroexpand(pic_state *, pic_value, struct pic_lib *); + +void pic_in_library(pic_state *, pic_value); +struct pic_lib *pic_open_library(pic_state *, pic_value); +struct pic_lib *pic_find_library(pic_state *, pic_value); + +#define pic_deflibrary(pic, spec) \ + pic_deflibrary_helper_(pic, GENSYM(i), GENSYM(prev_lib), spec) +#define pic_deflibrary_helper_(pic, i, prev_lib, spec) \ + for (int i = 0; ! i; ) \ + for (struct pic_lib *prev_lib; ! i; ) \ + for ((prev_lib = pic->lib), pic_open_library(pic, pic_read_cstr(pic, spec)), pic_in_library(pic, pic_read_cstr(pic, spec)); ! i++; pic->lib = prev_lib) + +void pic_import(pic_state *, pic_value); +void pic_import_library(pic_state *, struct pic_lib *); +void pic_export(pic_state *, pic_sym); + +noreturn void pic_panic(pic_state *, const char *); +noreturn void pic_errorf(pic_state *, const char *, ...); +void pic_warnf(pic_state *, const char *, ...); +const char *pic_errmsg(pic_state *); +pic_str *pic_get_backtrace(pic_state *); +void pic_print_backtrace(pic_state *); + +/* obsoleted */ +static inline void pic_warn(pic_state *pic, const char *msg) +{ + pic_warnf(pic, msg); +} + +struct pic_dict *pic_attr(pic_state *, pic_value); +pic_value pic_attr_ref(pic_state *, pic_value, const char *); +void pic_attr_set(pic_state *, pic_value, const char *, pic_value); + +struct pic_port *pic_stdin(pic_state *); +struct pic_port *pic_stdout(pic_state *); +struct pic_port *pic_stderr(pic_state *); + +pic_value pic_write(pic_state *, pic_value); /* returns given obj */ +pic_value pic_fwrite(pic_state *, pic_value, xFILE *); +void pic_printf(pic_state *, const char *, ...); +pic_value pic_display(pic_state *, pic_value); +pic_value pic_fdisplay(pic_state *, pic_value, xFILE *); +/* obsoleted macros */ +#define pic_debug(pic,obj) pic_write(pic,obj) +#define pic_fdebug(pic,obj,file) pic_fwrite(pic,obj,file) + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/blob.h b/extlib/benz/include/picrin/blob.h new file mode 100644 index 00000000..442c8a52 --- /dev/null +++ b/extlib/benz/include/picrin/blob.h @@ -0,0 +1,27 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_BLOB_H +#define PICRIN_BLOB_H + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_blob { + PIC_OBJECT_HEADER + unsigned char *data; + size_t len; +}; + +#define pic_blob_p(v) (pic_type(v) == PIC_TT_BLOB) +#define pic_blob_ptr(v) ((struct pic_blob *)pic_ptr(v)) + +struct pic_blob *pic_make_blob(pic_state *, size_t); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/config.h b/extlib/benz/include/picrin/config.h new file mode 100644 index 00000000..76c30066 --- /dev/null +++ b/extlib/benz/include/picrin/config.h @@ -0,0 +1,97 @@ +/** + * See Copyright Notice in picrin.h + */ + +/** switch normal VM and direct threaded VM */ +/* #define PIC_DIRECT_THREADED_VM 1 */ + +/** switch internal value representation */ +/* #define PIC_NAN_BOXING 1 */ + +/** treat false value as none */ +/* #define PIC_NONE_IS_FALSE 1 */ + +/** initial memory size (to be dynamically extended if necessary) */ +/* #define PIC_ARENA_SIZE 1000 */ + +/* #define PIC_HEAP_PAGE_SIZE 10000 */ + +/* #define PIC_STACK_SIZE 1024 */ + +/* #define PIC_RESCUE_SIZE 30 */ + +/* #define PIC_SYM_POOL_SIZE 128 */ + +/* #define PIC_IREP_SIZE 8 */ + +/* #define PIC_POOL_SIZE 8 */ + +/* #define PIC_ISEQ_SIZE 1024 */ + +/** enable all debug flags */ +/* #define DEBUG 1 */ + +/** auxiliary debug flags */ +/* #define GC_STRESS 1 */ +/* #define VM_DEBUG 1 */ +/* #define GC_DEBUG 1 */ +/* #define GC_DEBUG_DETAIL 1 */ + +#if __STDC_VERSION__ < 199901L +# error please activate c99 features +#endif + +#ifndef PIC_DIRECT_THREADED_VM +# if defined(__GNUC__) || defined(__clang__) +# define PIC_DIRECT_THREADED_VM 1 +# endif +#endif + +#ifndef PIC_NAN_BOXING +# if __x86_64__ && __STDC_VERSION__ >= 201112L +# define PIC_NAN_BOXING 1 +# endif +#endif + +#ifndef PIC_NONE_IS_FALSE +# define PIC_NONE_IS_FALSE 1 +#endif + +#ifndef PIC_ARENA_SIZE +# define PIC_ARENA_SIZE 1000 +#endif + +#ifndef PIC_HEAP_PAGE_SIZE +# define PIC_HEAP_PAGE_SIZE 10000 +#endif + +#ifndef PIC_STACK_SIZE +# define PIC_STACK_SIZE 1024 +#endif + +#ifndef PIC_RESCUE_SIZE +# define PIC_RESCUE_SIZE 30 +#endif + +#ifndef PIC_SYM_POOL_SIZE +# define PIC_SYM_POOL_SIZE 128 +#endif + +#ifndef PIC_IREP_SIZE +# define PIC_IREP_SIZE 8 +#endif + +#ifndef PIC_POOL_SIZE +# define PIC_POOL_SIZE 8 +#endif + +#ifndef PIC_ISEQ_SIZE +# define PIC_ISEQ_SIZE 1024 +#endif + +#if DEBUG +# define GC_STRESS 0 +# define VM_DEBUG 1 +# define GC_DEBUG 0 +# define GC_DEBUG_DETAIL 0 +#endif diff --git a/extlib/benz/include/picrin/cont.h b/extlib/benz/include/picrin/cont.h new file mode 100644 index 00000000..645e6d9c --- /dev/null +++ b/extlib/benz/include/picrin/cont.h @@ -0,0 +1,53 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_CONT_H +#define PICRIN_CONT_H + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_escape { + jmp_buf jmp; + + bool valid; + + struct pic_winder *wind; + + ptrdiff_t sp_offset; + ptrdiff_t ci_offset; + ptrdiff_t xp_offset; + size_t arena_idx; + + pic_code *ip; + + pic_value results; +}; + +void pic_save_point(pic_state *, struct pic_escape *); +void pic_load_point(pic_state *, struct pic_escape *); + +struct pic_proc *pic_make_econt(pic_state *, struct pic_escape *); + +void pic_wind(pic_state *, struct pic_winder *, struct pic_winder *); +pic_value pic_dynamic_wind(pic_state *, struct pic_proc *, struct pic_proc *, struct pic_proc *); + +pic_value pic_values0(pic_state *); +pic_value pic_values1(pic_state *, pic_value); +pic_value pic_values2(pic_state *, pic_value, pic_value); +pic_value pic_values3(pic_state *, pic_value, pic_value, pic_value); +pic_value pic_values4(pic_state *, pic_value, pic_value, pic_value, pic_value); +pic_value pic_values5(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value); +pic_value pic_values_by_array(pic_state *, size_t, pic_value *); +pic_value pic_values_by_list(pic_state *, pic_value); +size_t pic_receive(pic_state *, size_t, pic_value *); + +pic_value pic_escape(pic_state *, struct pic_proc *); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/data.h b/extlib/benz/include/picrin/data.h new file mode 100644 index 00000000..fec4cd7d --- /dev/null +++ b/extlib/benz/include/picrin/data.h @@ -0,0 +1,38 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_DATA_H +#define PICRIN_DATA_H + +#if defined(__cplusplus) +extern "C" { +#endif + +typedef struct { + const char *type_name; + void (*dtor)(pic_state *, void *); + void (*mark)(pic_state *, void *, void (*)(pic_state *, pic_value)); +} pic_data_type; + +struct pic_data { + PIC_OBJECT_HEADER + const pic_data_type *type; + xhash storage; /* const char * to pic_value table */ + void *data; +}; + +#define pic_data_p(o) (pic_type(o) == PIC_TT_DATA) +#define pic_data_ptr(o) ((struct pic_data *)pic_ptr(o)) + +static inline bool pic_data_type_p(const pic_value obj, const pic_data_type *type) { + return pic_data_p(obj) && pic_data_ptr(obj)->type == type; +} + +struct pic_data *pic_data_alloc(pic_state *, const pic_data_type *, void *); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/dict.h b/extlib/benz/include/picrin/dict.h new file mode 100644 index 00000000..36160c24 --- /dev/null +++ b/extlib/benz/include/picrin/dict.h @@ -0,0 +1,32 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_DICT_H +#define PICRIN_DICT_H + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_dict { + PIC_OBJECT_HEADER + xhash hash; +}; + +#define pic_dict_p(v) (pic_type(v) == PIC_TT_DICT) +#define pic_dict_ptr(v) ((struct pic_dict *)pic_ptr(v)) + +struct pic_dict *pic_make_dict(pic_state *); + +pic_value pic_dict_ref(pic_state *, struct pic_dict *, pic_value); +void pic_dict_set(pic_state *, struct pic_dict *, pic_value, pic_value); +void pic_dict_del(pic_state *, struct pic_dict *, pic_value); +size_t pic_dict_size(pic_state *, struct pic_dict *); +bool pic_dict_has(pic_state *, struct pic_dict *, pic_value); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/error.h b/extlib/benz/include/picrin/error.h new file mode 100644 index 00000000..784b95f8 --- /dev/null +++ b/extlib/benz/include/picrin/error.h @@ -0,0 +1,54 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_ERROR_H +#define PICRIN_ERROR_H + +#if defined(__cplusplus) +extern "C" { +#endif + +#include "picrin/cont.h" + +struct pic_error { + PIC_OBJECT_HEADER + pic_sym type; + pic_str *msg; + pic_value irrs; + pic_str *stack; +}; + +#define pic_error_p(v) (pic_type(v) == PIC_TT_ERROR) +#define pic_error_ptr(v) ((struct pic_error *)pic_ptr(v)) + +struct pic_error *pic_make_error(pic_state *, pic_sym, const char *, pic_list); + +/* do not return from try block! */ + +#define pic_try \ + pic_try_(GENSYM(escape)) +#define pic_try_(escape) \ + struct pic_escape *escape = pic_alloc(pic, sizeof(struct pic_escape)); \ + pic_save_point(pic, escape); \ + if (setjmp(escape->jmp) == 0) { \ + pic_push_try(pic, escape); \ + do +#define pic_catch \ + while (0); \ + pic_pop_try(pic); \ + } else + +void pic_push_try(pic_state *, struct pic_escape *); +void pic_pop_try(pic_state *); + +pic_value pic_raise_continuable(pic_state *, pic_value); +noreturn void pic_raise(pic_state *, pic_value); +noreturn void pic_throw(pic_state *, pic_sym, const char *, pic_list); +noreturn void pic_error(pic_state *, const char *, pic_list); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/gc.h b/extlib/benz/include/picrin/gc.h new file mode 100644 index 00000000..9f165d80 --- /dev/null +++ b/extlib/benz/include/picrin/gc.h @@ -0,0 +1,24 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_GC_H +#define PICRIN_GC_H + +#if defined(__cplusplus) +extern "C" { +#endif + +#define PIC_GC_UNMARK 0 +#define PIC_GC_MARK 1 + +struct pic_heap; + +struct pic_heap *pic_heap_open(); +void pic_heap_close(struct pic_heap *); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/irep.h b/extlib/benz/include/picrin/irep.h new file mode 100644 index 00000000..fe924bbc --- /dev/null +++ b/extlib/benz/include/picrin/irep.h @@ -0,0 +1,206 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_IREP_H +#define PICRIN_IREP_H + +#if defined(__cplusplus) +extern "C" { +#endif + +enum pic_opcode { + OP_NOP, + OP_POP, + OP_PUSHNIL, + OP_PUSHTRUE, + OP_PUSHFALSE, + OP_PUSHINT, + OP_PUSHCHAR, + OP_PUSHCONST, + OP_GREF, + OP_GSET, + OP_LREF, + OP_LSET, + OP_CREF, + OP_CSET, + OP_JMP, + OP_JMPIF, + OP_NOT, + OP_CALL, + OP_TAILCALL, + OP_RET, + OP_LAMBDA, + OP_CONS, + OP_CAR, + OP_CDR, + OP_NILP, + OP_ADD, + OP_SUB, + OP_MUL, + OP_DIV, + OP_MINUS, + OP_EQ, + OP_LT, + OP_LE, + OP_STOP +}; + +struct pic_code { + enum pic_opcode insn; + union { + int i; + char c; + struct { + int depth; + int idx; + } r; + } u; +}; + +struct pic_irep { + PIC_OBJECT_HEADER + pic_sym name; + pic_code *code; + int argc, localc, capturec; + bool varg; + struct pic_irep **irep; + pic_value *pool; + size_t clen, ilen, plen; +}; + +pic_value pic_analyze(pic_state *, pic_value); +struct pic_irep *pic_codegen(pic_state *, pic_value); + +static inline void +pic_dump_code(pic_code c) +{ + printf("[%2d] ", c.insn); + switch (c.insn) { + case OP_NOP: + puts("OP_NOP"); + break; + case OP_POP: + puts("OP_POP"); + break; + case OP_PUSHNIL: + puts("OP_PUSHNIL"); + break; + case OP_PUSHTRUE: + puts("OP_PUSHTRUE"); + break; + case OP_PUSHFALSE: + puts("OP_PUSHFALSE"); + break; + case OP_PUSHINT: + printf("OP_PUSHINT\t%d\n", c.u.i); + break; + case OP_PUSHCHAR: + printf("OP_PUSHCHAR\t%c\n", c.u.c); + break; + case OP_PUSHCONST: + printf("OP_PUSHCONST\t%d\n", c.u.i); + break; + case OP_GREF: + printf("OP_GREF\t%i\n", c.u.i); + break; + case OP_GSET: + printf("OP_GSET\t%i\n", c.u.i); + break; + case OP_LREF: + printf("OP_LREF\t%d\n", c.u.i); + break; + case OP_LSET: + printf("OP_LSET\t%d\n", c.u.i); + break; + case OP_CREF: + printf("OP_CREF\t%d\t%d\n", c.u.r.depth, c.u.r.idx); + break; + case OP_CSET: + printf("OP_CSET\t%d\t%d\n", c.u.r.depth, c.u.r.idx); + break; + case OP_JMP: + printf("OP_JMP\t%x\n", c.u.i); + break; + case OP_JMPIF: + printf("OP_JMPIF\t%x\n", c.u.i); + break; + case OP_NOT: + puts("OP_NOT"); + break; + case OP_CALL: + printf("OP_CALL\t%d\n", c.u.i); + break; + case OP_TAILCALL: + printf("OP_TAILCALL\t%d\n", c.u.i); + break; + case OP_RET: + printf("OP_RET\t%d\n", c.u.i); + break; + case OP_LAMBDA: + printf("OP_LAMBDA\t%d\n", c.u.i); + break; + case OP_CONS: + puts("OP_CONS"); + break; + case OP_CAR: + puts("OP_CAR"); + break; + case OP_NILP: + puts("OP_NILP"); + break; + case OP_CDR: + puts("OP_CDR"); + break; + case OP_ADD: + puts("OP_ADD"); + break; + case OP_SUB: + puts("OP_SUB"); + break; + case OP_MUL: + puts("OP_MUL"); + break; + case OP_DIV: + puts("OP_DIV"); + break; + case OP_MINUS: + puts("OP_MINUS"); + break; + case OP_EQ: + puts("OP_EQ"); + break; + case OP_LT: + puts("OP_LT"); + break; + case OP_LE: + puts("OP_LE"); + break; + case OP_STOP: + puts("OP_STOP"); + break; + } +} + +static inline void +pic_dump_irep(struct pic_irep *irep) +{ + unsigned i; + + printf("## irep %p\n", (void *)irep); + printf("[clen = %zd, argc = %d, localc = %d, capturec = %d]\n", irep->clen, irep->argc, irep->localc, irep->capturec); + for (i = 0; i < irep->clen; ++i) { + printf("%02x ", i); + pic_dump_code(irep->code[i]); + } + + for (i = 0; i < irep->ilen; ++i) { + pic_dump_irep(irep->irep[i]); + } +} + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/lib.h b/extlib/benz/include/picrin/lib.h new file mode 100644 index 00000000..98ab3ae8 --- /dev/null +++ b/extlib/benz/include/picrin/lib.h @@ -0,0 +1,25 @@ +/** + * 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_senv *env; + xhash exports; +}; + +#define pic_lib_ptr(o) ((struct pic_lib *)pic_ptr(o)) + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/macro.h b/extlib/benz/include/picrin/macro.h new file mode 100644 index 00000000..79148e51 --- /dev/null +++ b/extlib/benz/include/picrin/macro.h @@ -0,0 +1,48 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_MACRO_H +#define PICRIN_MACRO_H + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_senv { + PIC_OBJECT_HEADER + xhash map; + pic_value defer; + struct pic_senv *up; +}; + +struct pic_macro { + PIC_OBJECT_HEADER + struct pic_proc *proc; + struct pic_senv *senv; +}; + +#define pic_macro_p(v) (pic_type(v) == PIC_TT_MACRO) +#define pic_macro_ptr(v) ((struct pic_macro *)pic_ptr(v)) + +#define pic_senv_p(v) (pic_type(v) == PIC_TT_SENV) +#define pic_senv_ptr(v) ((struct pic_senv *)pic_ptr(v)) + +struct pic_senv *pic_null_syntactic_environment(pic_state *); + +bool pic_identifier_p(pic_state *pic, pic_value obj); +bool pic_identifier_eq_p(pic_state *, struct pic_senv *, pic_sym, struct pic_senv *, pic_sym); + +struct pic_senv *pic_make_senv(pic_state *, struct pic_senv *); + +pic_sym pic_add_rename(pic_state *, struct pic_senv *, pic_sym); +bool pic_find_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym * /* = NULL */); +void pic_put_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym); + +void pic_define_syntactic_keyword(pic_state *, struct pic_senv *, pic_sym, pic_sym); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/pair.h b/extlib/benz/include/picrin/pair.h new file mode 100644 index 00000000..d489b765 --- /dev/null +++ b/extlib/benz/include/picrin/pair.h @@ -0,0 +1,100 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_PAIR_H +#define PICRIN_PAIR_H + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_pair { + PIC_OBJECT_HEADER + pic_value car; + pic_value cdr; +}; + +#define pic_pair_p(v) (pic_type(v) == PIC_TT_PAIR) +#define pic_pair_ptr(o) ((struct pic_pair *)pic_ptr(o)) + +static inline pic_value +pic_car(pic_state *pic, pic_value obj) +{ + struct pic_pair *pair; + + if (! pic_pair_p(obj)) { + pic_errorf(pic, "pair required, but got ~s", obj); + } + pair = pic_pair_ptr(obj); + + return pair->car; +} + +static inline pic_value +pic_cdr(pic_state *pic, pic_value obj) +{ + struct pic_pair *pair; + + if (! pic_pair_p(obj)) { + pic_errorf(pic, "pair required, but got ~s", obj); + } + pair = pic_pair_ptr(obj); + + return pair->cdr; +} + +pic_value pic_cons(pic_state *, pic_value, pic_value); +void pic_set_car(pic_state *, pic_value, pic_value); +void pic_set_cdr(pic_state *, pic_value, pic_value); + +bool pic_list_p(pic_value); +pic_value pic_list1(pic_state *, pic_value); +pic_value pic_list2(pic_state *, pic_value, pic_value); +pic_value pic_list3(pic_state *, pic_value, pic_value, pic_value); +pic_value pic_list4(pic_state *, pic_value, pic_value, pic_value, pic_value); +pic_value pic_list5(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value); +pic_value pic_list6(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value); +pic_value pic_list7(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value); +pic_value pic_list_by_array(pic_state *, size_t, pic_value *); +pic_value pic_make_list(pic_state *, size_t, pic_value); + +#define pic_for_each(var, list) \ + pic_for_each_helper_(var, GENSYM(tmp), list) +#define pic_for_each_helper_(var, tmp, list) \ + for (pic_value tmp = (list); \ + pic_nil_p(tmp) ? false : ((var = pic_car(pic, tmp)), true); \ + tmp = pic_cdr(pic, tmp)) + +#define pic_push(pic, item, place) (place = pic_cons(pic, item, place)) +#define pic_pop(pic, place) (place = pic_cdr(pic, place)) + +size_t pic_length(pic_state *, pic_value); +pic_value pic_reverse(pic_state *, pic_value); +pic_value pic_append(pic_state *, pic_value, pic_value); + +pic_value pic_memq(pic_state *, pic_value key, pic_value list); +pic_value pic_memv(pic_state *, pic_value key, pic_value list); +pic_value pic_member(pic_state *, pic_value key, pic_value list, struct pic_proc * /* = NULL */); + +pic_value pic_assq(pic_state *, pic_value key, pic_value assoc); +pic_value pic_assv(pic_state *, pic_value key, pic_value assoc); +pic_value pic_assoc(pic_state *, pic_value key, pic_value assoc, struct pic_proc * /* = NULL */); + +pic_value pic_acons(pic_state *, pic_value key, pic_value val, pic_value assoc); + +pic_value pic_caar(pic_state *, pic_value); +pic_value pic_cadr(pic_state *, pic_value); +pic_value pic_cdar(pic_state *, pic_value); +pic_value pic_cddr(pic_state *, pic_value); + +pic_value pic_list_tail(pic_state *, pic_value, size_t); +pic_value pic_list_ref(pic_state *, pic_value, size_t); +void pic_list_set(pic_state *, pic_value, size_t, pic_value); +pic_value pic_list_copy(pic_state *, pic_value); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/port.h b/extlib/benz/include/picrin/port.h new file mode 100644 index 00000000..4f763902 --- /dev/null +++ b/extlib/benz/include/picrin/port.h @@ -0,0 +1,46 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_PORT_H +#define PICRIN_PORT_H + +#if defined(__cplusplus) +extern "C" { +#endif + +enum pic_port_flag { + PIC_PORT_IN = 1, + PIC_PORT_OUT = 2, + PIC_PORT_TEXT = 4, + PIC_PORT_BINARY = 8, +}; + +enum pic_port_status { + PIC_PORT_OPEN, + PIC_PORT_CLOSE, +}; + +struct pic_port { + PIC_OBJECT_HEADER + xFILE *file; + int flags; + int status; +}; + +#define pic_port_p(v) (pic_type(v) == PIC_TT_PORT) +#define pic_port_ptr(v) ((struct pic_port *)pic_ptr(v)) + +pic_value pic_eof_object(); + +struct pic_port *pic_open_input_string(pic_state *, const char *); +struct pic_port *pic_open_output_string(pic_state *); +struct pic_string *pic_get_output_string(pic_state *, struct pic_port *); + +void pic_close_port(pic_state *pic, struct pic_port *); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/proc.h b/extlib/benz/include/picrin/proc.h new file mode 100644 index 00000000..e64cd6fc --- /dev/null +++ b/extlib/benz/include/picrin/proc.h @@ -0,0 +1,57 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_PROC_H +#define PICRIN_PROC_H + +#if defined(__cplusplus) +extern "C" { +#endif + +/* native C function */ +struct pic_func { + pic_func_t f; + pic_sym name; +}; + +struct pic_env { + PIC_OBJECT_HEADER + pic_value *regs; + int regc; + struct pic_env *up; + pic_value storage[]; +}; + +struct pic_proc { + PIC_OBJECT_HEADER + char kind; + union { + struct pic_func func; + struct pic_irep *irep; + } u; + struct pic_env *env; +}; + +#define PIC_PROC_KIND_FUNC 1 +#define PIC_PROC_KIND_IREP 2 + +#define pic_proc_func_p(proc) ((proc)->kind == PIC_PROC_KIND_FUNC) +#define pic_proc_irep_p(proc) ((proc)->kind == PIC_PROC_KIND_IREP) + +#define pic_proc_p(o) (pic_type(o) == PIC_TT_PROC) +#define pic_proc_ptr(o) ((struct pic_proc *)pic_ptr(o)) + +#define pic_env_p(o) (pic_type(o) == PIC_TT_ENV) +#define pic_env_ptr(o) ((struct pic_env *)pic_ptr(o)) + +struct pic_proc *pic_make_proc(pic_state *, pic_func_t, const char *); +struct pic_proc *pic_make_proc_irep(pic_state *, struct pic_irep *, struct pic_env *); + +pic_sym pic_proc_name(struct pic_proc *); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/read.h b/extlib/benz/include/picrin/read.h new file mode 100644 index 00000000..18d46ff7 --- /dev/null +++ b/extlib/benz/include/picrin/read.h @@ -0,0 +1,39 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_READ_H +#define PICRIN_READ_H + +#if defined(__cplusplus) +extern "C" { +#endif + +enum pic_typecase { + PIC_CASE_DEFAULT, + PIC_CASE_FOLD, +}; + +struct pic_trie { + struct pic_trie *table[256]; + struct pic_proc *proc; +}; + +struct pic_reader { + short typecase; + xhash labels; + struct pic_trie *trie; +}; + +void pic_init_reader(pic_state *); + +void pic_define_reader(pic_state *, const char *, pic_func_t); + +struct pic_trie *pic_make_trie(pic_state *); +void pic_trie_delete(pic_state *, struct pic_trie *); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/record.h b/extlib/benz/include/picrin/record.h new file mode 100644 index 00000000..d2944c06 --- /dev/null +++ b/extlib/benz/include/picrin/record.h @@ -0,0 +1,30 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_RECORD_H +#define PICRIN_RECORD_H + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_record { + PIC_OBJECT_HEADER + xhash hash; +}; + +#define pic_record_p(v) (pic_type(v) == PIC_TT_RECORD) +#define pic_record_ptr(v) ((struct pic_record *)pic_ptr(v)) + +struct pic_record *pic_make_record(pic_state *, pic_value); + +pic_value pic_record_type(pic_state *, struct pic_record *); +pic_value pic_record_ref(pic_state *, struct pic_record *, pic_sym); +void pic_record_set(pic_state *, struct pic_record *, pic_sym, pic_value); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/string.h b/extlib/benz/include/picrin/string.h new file mode 100644 index 00000000..2701e162 --- /dev/null +++ b/extlib/benz/include/picrin/string.h @@ -0,0 +1,45 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_STRING_H +#define PICRIN_STRING_H + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_string { + PIC_OBJECT_HEADER + xrope *rope; +}; + +#define pic_str_p(v) (pic_type(v) == PIC_TT_STRING) +#define pic_str_ptr(o) ((struct pic_string *)pic_ptr(o)) + +pic_str *pic_make_str(pic_state *, const char * /* nullable */, size_t); +pic_str *pic_make_str_cstr(pic_state *, const char *); +pic_str *pic_make_str_fill(pic_state *, size_t, char); + +size_t pic_strlen(pic_str *); +char pic_str_ref(pic_state *, pic_str *, size_t); + +pic_str *pic_strcat(pic_state *, pic_str *, pic_str *); +pic_str *pic_substr(pic_state *, pic_str *, size_t, size_t); +int pic_strcmp(pic_str *, pic_str *); + +const char *pic_str_cstr(pic_str *); + +pic_str *pic_format(pic_state *, const char *, ...); +pic_str *pic_vformat(pic_state *, const char *, va_list); +void pic_vfformat(pic_state *, xFILE *, const char *, va_list); + +pic_value pic_xformat(pic_state *, const char *, ...); +pic_value pic_xvformat(pic_state *, const char *, va_list); +pic_value pic_xvfformat(pic_state *, xFILE *, const char *, va_list); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/util.h b/extlib/benz/include/picrin/util.h new file mode 100644 index 00000000..d56cd9f6 --- /dev/null +++ b/extlib/benz/include/picrin/util.h @@ -0,0 +1,51 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_UTIL_H +#define PICRIN_UTIL_H + +#if defined(__cplusplus) +extern "C" { +#endif + +#if __STDC_VERSION__ >= 201112L +# include +#elif __GNUC__ || __clang__ +# define noreturn __attribute__((noreturn)) +#else +# define noreturn +#endif + +#define FALLTHROUGH ((void)0) +#define UNUSED(v) ((void)(v)) + +#define GENSYM2_(x,y) G##x##_##y##__ +#define GENSYM1_(x,y) GENSYM2_(x,y) +#if defined(__COUNTER__) +# define GENSYM(x) GENSYM1_(__COUNTER__,x) +#else +# define GENSYM(x) GENSYM1_(__LINE__,x) +#endif + +#if GCC_VERSION >= 40500 || __clang__ +# define UNREACHABLE() (__builtin_unreachable()) +#else +# include +# define UNREACHABLE() (assert(false)) +#endif + +#define SWAP(type,a,b) \ + SWAP_HELPER_(type,GENSYM(tmp),a,b) +#define SWAP_HELPER_(type,tmp,a,b) \ + do { \ + type tmp = (a); \ + (a) = (b); \ + (b) = tmp; \ + } while (0) + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/value.h b/extlib/benz/include/picrin/value.h new file mode 100644 index 00000000..709fcf77 --- /dev/null +++ b/extlib/benz/include/picrin/value.h @@ -0,0 +1,534 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_VALUE_H +#define PICRIN_VALUE_H + +#if defined(__cplusplus) +extern "C" { +#endif + +/** + * pic_sym is just an alias of int. + */ + +typedef int pic_sym; + +/** + * `undef` values never seen from user-end: that is, + * it's used only for repsenting internal special state + */ + +enum pic_vtype { + PIC_VTYPE_NIL = 1, + PIC_VTYPE_TRUE, + PIC_VTYPE_FALSE, + PIC_VTYPE_UNDEF, + PIC_VTYPE_FLOAT, + PIC_VTYPE_INT, + PIC_VTYPE_SYMBOL, + PIC_VTYPE_CHAR, + PIC_VTYPE_EOF, + PIC_VTYPE_HEAP +}; + +#if PIC_NAN_BOXING + +/** + * value representation by nan-boxing: + * float : FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF + * ptr : 111111111111TTTT PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP + * int : 1111111111110110 0000000000000000 IIIIIIIIIIIIIIII IIIIIIIIIIIIIIII + * sym : 1111111111110111 0000000000000000 SSSSSSSSSSSSSSSS SSSSSSSSSSSSSSSS + * char : 1111111111111000 0000000000000000 CCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCC + */ + +typedef uint64_t pic_value; + +#define pic_ptr(v) ((void *)(0xfffffffffffful & (v))) +#define pic_init_value(v,vtype) (v = (0xfff0000000000000ul | ((uint64_t)(vtype) << 48))) + +static inline enum pic_vtype +pic_vtype(pic_value v) +{ + return 0xfff0 >= (v >> 48) ? PIC_VTYPE_FLOAT : ((v >> 48) & 0xf); +} + +static inline double +pic_float(pic_value v) +{ + union { double f; uint64_t i; } u; + u.i = v; + return u.f; +} + +static inline int +pic_int(pic_value v) +{ + union { int i; unsigned u; } u; + u.u = v & 0xfffffffful; + return u.i; +} + +static inline int +pic_sym(pic_value v) +{ + union { int i; unsigned u; } u; + u.u = v & 0xfffffffful; + return u.i; +} + +#define pic_char(v) ((v) & 0xfffffffful) + +#else + +typedef struct { + enum pic_vtype type; + union { + void *data; + double f; + int i; + pic_sym sym; + char c; + } u; +} pic_value; + +#define pic_ptr(v) ((v).u.data) +#define pic_vtype(v) ((v).type) +#define pic_init_value(v,vtype) ((v).type = (vtype), (v).u.data = NULL) + +#define pic_float(v) ((v).u.f) +#define pic_int(v) ((v).u.i) +#define pic_sym(v) ((v).u.sym) +#define pic_char(v) ((v).u.c) + +#endif + +enum pic_tt { + /* immediate */ + PIC_TT_NIL, + PIC_TT_BOOL, + PIC_TT_FLOAT, + PIC_TT_INT, + PIC_TT_SYMBOL, + PIC_TT_CHAR, + PIC_TT_EOF, + PIC_TT_UNDEF, + /* heap */ + PIC_TT_PAIR, + PIC_TT_STRING, + PIC_TT_VECTOR, + PIC_TT_BLOB, + PIC_TT_PROC, + PIC_TT_PORT, + PIC_TT_ERROR, + PIC_TT_ENV, + PIC_TT_SENV, + PIC_TT_MACRO, + PIC_TT_LIB, + PIC_TT_IREP, + PIC_TT_DATA, + PIC_TT_DICT, + PIC_TT_RECORD, +}; + +#define PIC_OBJECT_HEADER \ + enum pic_tt tt; + +struct pic_object { + PIC_OBJECT_HEADER +}; + +struct pic_pair; +struct pic_string; +struct pic_vector; +struct pic_blob; + +struct pic_proc; +struct pic_port; +struct pic_error; + +/* set aliases to basic types */ +typedef pic_value pic_list; +typedef struct pic_pair pic_pair; +typedef struct pic_string pic_str; +typedef struct pic_vector pic_vec; +typedef struct pic_blob pic_blob; + +#define pic_obj_p(v) (pic_vtype(v) == PIC_VTYPE_HEAP) +#define pic_obj_ptr(v) ((struct pic_object *)pic_ptr(v)) + +#define pic_nil_p(v) (pic_vtype(v) == PIC_VTYPE_NIL) +#define pic_true_p(v) (pic_vtype(v) == PIC_VTYPE_TRUE) +#define pic_false_p(v) (pic_vtype(v) == PIC_VTYPE_FALSE) +#define pic_undef_p(v) (pic_vtype(v) == PIC_VTYPE_UNDEF) +#define pic_float_p(v) (pic_vtype(v) == PIC_VTYPE_FLOAT) +#define pic_int_p(v) (pic_vtype(v) == PIC_VTYPE_INT) +#define pic_sym_p(v) (pic_vtype(v) == PIC_VTYPE_SYMBOL) +#define pic_char_p(v) (pic_vtype(v) == PIC_VTYPE_CHAR) +#define pic_eof_p(v) (pic_vtype(v) == PIC_VTYPE_EOF) + +#define pic_test(v) (! pic_false_p(v)) + +static inline enum pic_tt pic_type(pic_value); +static inline const char *pic_type_repr(enum pic_tt); + +#define pic_assert_type(pic, v, type) \ + if (! pic_##type##_p(v)) { \ + pic_errorf(pic, "expected " #type ", but got ~s", v); \ + } + +static inline bool pic_valid_int(double); + +static inline pic_value pic_nil_value(); +static inline pic_value pic_true_value(); +static inline pic_value pic_false_value(); +static inline pic_value pic_bool_value(bool); +static inline pic_value pic_undef_value(); +static inline pic_value pic_obj_value(void *); +static inline pic_value pic_float_value(double); +static inline pic_value pic_int_value(int); +static inline pic_value pic_size_value(size_t); +static inline pic_value pic_sym_value(pic_sym); +static inline pic_value pic_char_value(char c); +static inline pic_value pic_none_value(); + +#define pic_symbol_value(sym) pic_sym_value(sym) + +static inline bool pic_eq_p(pic_value, pic_value); +static inline bool pic_eqv_p(pic_value, pic_value); + +static inline enum pic_tt +pic_type(pic_value v) +{ + switch (pic_vtype(v)) { + case PIC_VTYPE_NIL: + return PIC_TT_NIL; + case PIC_VTYPE_TRUE: + return PIC_TT_BOOL; + case PIC_VTYPE_FALSE: + return PIC_TT_BOOL; + case PIC_VTYPE_UNDEF: + return PIC_TT_UNDEF; + case PIC_VTYPE_FLOAT: + return PIC_TT_FLOAT; + case PIC_VTYPE_INT: + return PIC_TT_INT; + case PIC_VTYPE_SYMBOL: + return PIC_TT_SYMBOL; + case PIC_VTYPE_CHAR: + return PIC_TT_CHAR; + case PIC_VTYPE_EOF: + return PIC_TT_EOF; + case PIC_VTYPE_HEAP: + return ((struct pic_object *)pic_ptr(v))->tt; + } + + UNREACHABLE(); +} + +static inline const char * +pic_type_repr(enum pic_tt tt) +{ + switch (tt) { + case PIC_TT_NIL: + return "nil"; + case PIC_TT_BOOL: + return "boolean"; + case PIC_TT_FLOAT: + return "float"; + case PIC_TT_INT: + return "int"; + case PIC_TT_SYMBOL: + return "symbol"; + case PIC_TT_CHAR: + return "char"; + case PIC_TT_EOF: + return "eof"; + case PIC_TT_UNDEF: + return "undef"; + case PIC_TT_PAIR: + return "pair"; + case PIC_TT_STRING: + return "string"; + case PIC_TT_VECTOR: + return "vector"; + case PIC_TT_BLOB: + return "blob"; + case PIC_TT_PORT: + return "port"; + case PIC_TT_ERROR: + return "error"; + case PIC_TT_ENV: + return "env"; + case PIC_TT_PROC: + return "proc"; + case PIC_TT_SENV: + return "senv"; + case PIC_TT_MACRO: + return "macro"; + case PIC_TT_LIB: + return "lib"; + case PIC_TT_IREP: + return "irep"; + case PIC_TT_DATA: + return "data"; + case PIC_TT_DICT: + return "dict"; + case PIC_TT_RECORD: + return "record"; + } + UNREACHABLE(); +} + +static inline bool +pic_valid_int(double v) +{ + return INT_MIN <= v && v <= INT_MAX; +} + +static inline pic_value +pic_nil_value() +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_NIL); + return v; +} + +static inline pic_value +pic_true_value() +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_TRUE); + return v; +} + +static inline pic_value +pic_false_value() +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_FALSE); + return v; +} + +static inline pic_value +pic_bool_value(bool b) +{ + pic_value v; + + pic_init_value(v, b ? PIC_VTYPE_TRUE : PIC_VTYPE_FALSE); + return v; +} + +static inline pic_value +pic_size_value(size_t s) +{ + if (sizeof(unsigned) < sizeof(size_t)) { + if (s > (size_t)INT_MAX) { + return pic_float_value(s); + } + } + return pic_int_value((int)s); +} + +#if PIC_NAN_BOXING + +static inline pic_value +pic_obj_value(void *ptr) +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_HEAP); + v |= 0xfffffffffffful & (uint64_t)ptr; + return v; +} + +static inline pic_value +pic_float_value(double f) +{ + union { double f; uint64_t i; } u; + + if (f != f) { + return 0x7ff8000000000000ul; + } else { + u.f = f; + return u.i; + } +} + +static inline pic_value +pic_int_value(int i) +{ + union { int i; unsigned u; } u; + pic_value v; + + u.i = i; + + pic_init_value(v, PIC_VTYPE_INT); + v |= u.u; + return v; +} + +static inline pic_value +pic_symbol_value(pic_sym sym) +{ + union { int i; unsigned u; } u; + pic_value v; + + u.i = sym; + + pic_init_value(v, PIC_VTYPE_SYMBOL); + v |= u.u; + return v; +} + +static inline pic_value +pic_char_value(char c) +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_CHAR); + v |= c; + return v; +} + +#else + +static inline pic_value +pic_obj_value(void *ptr) +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_HEAP); + v.u.data = ptr; + return v; +} + +static inline pic_value +pic_float_value(double f) +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_FLOAT); + v.u.f = f; + return v; +} + +static inline pic_value +pic_int_value(int i) +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_INT); + v.u.i = i; + return v; +} + +static inline pic_value +pic_symbol_value(pic_sym sym) +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_SYMBOL); + v.u.sym = sym; + return v; +} + +static inline pic_value +pic_char_value(char c) +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_CHAR); + v.u.c = c; + return v; +} + +#endif + +static inline pic_value +pic_undef_value() +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_UNDEF); + return v; +} + +static inline pic_value +pic_none_value() +{ +#if PIC_NONE_IS_FALSE + return pic_false_value(); +#else +# error enable PIC_NONE_IS_FALSE +#endif +} + +#if PIC_NAN_BOXING + +static inline bool +pic_eq_p(pic_value x, pic_value y) +{ + return x == y; +} + +static inline bool +pic_eqv_p(pic_value x, pic_value y) +{ + return x == y; +} + +#else + +static inline bool +pic_eq_p(pic_value x, pic_value y) +{ + if (pic_type(x) != pic_type(y)) + return false; + + switch (pic_type(x)) { + case PIC_TT_NIL: + return true; + case PIC_TT_BOOL: + return pic_vtype(x) == pic_vtype(y); + case PIC_TT_SYMBOL: + return pic_sym(x) == pic_sym(y); + default: + return pic_ptr(x) == pic_ptr(y); + } +} + +static inline bool +pic_eqv_p(pic_value x, pic_value y) +{ + if (pic_type(x) != pic_type(y)) + return false; + + switch (pic_type(x)) { + case PIC_TT_NIL: + return true; + case PIC_TT_BOOL: + return pic_vtype(x) == pic_vtype(y); + case PIC_TT_SYMBOL: + return pic_sym(x) == pic_sym(y); + case PIC_TT_FLOAT: + return pic_float(x) == pic_float(y); + case PIC_TT_INT: + return pic_int(x) == pic_int(y); + default: + return pic_ptr(x) == pic_ptr(y); + } +} + +#endif + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/vector.h b/extlib/benz/include/picrin/vector.h new file mode 100644 index 00000000..514ecb4b --- /dev/null +++ b/extlib/benz/include/picrin/vector.h @@ -0,0 +1,28 @@ +/** + * See Copyright Notice in picrin.h + */ + +#ifndef PICRIN_VECTOR_H +#define PICRIN_VECTOR_H + +#if defined(__cplusplus) +extern "C" { +#endif + +struct pic_vector { + PIC_OBJECT_HEADER + pic_value *data; + size_t len; +}; + +#define pic_vec_p(v) (pic_type(v) == PIC_TT_VECTOR) +#define pic_vec_ptr(o) ((struct pic_vector *)pic_ptr(o)) + +struct pic_vector *pic_make_vec(pic_state *, size_t); +struct pic_vector *pic_make_vec_from_list(pic_state *, pic_value); + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/xfile.h b/extlib/benz/include/picrin/xfile.h new file mode 100644 index 00000000..4db6f836 --- /dev/null +++ b/extlib/benz/include/picrin/xfile.h @@ -0,0 +1,584 @@ +#ifndef XFILE_H +#define XFILE_H + +#if defined(__cplusplus) +extern "C" { +#endif + +#include +#include +#include +#include +#include + +typedef struct { + int ungot; + int flags; + /* operators */ + struct { + void *cookie; + int (*read)(void *, char *, int); + int (*write)(void *, const char *, int); + long (*seek)(void *, long, int); + int (*flush)(void *); + int (*close)(void *); + } vtable; +} xFILE; + +/* generic file constructor */ +static inline xFILE *xfunopen(void *cookie, int (*read)(void *, char *, int), int (*write)(void *, const char *, int), long (*seek)(void *, long, int), int (*flush)(void *), int (*close)(void *)); + +/* resource aquisition */ +static inline xFILE *xfpopen(FILE *); +static inline xFILE *xmopen(); +static inline xFILE *xfopen(const char *, const char *); +static inline int xfclose(xFILE *); + +/* buffer management */ +static inline int xfflush(xFILE *); + +/* direct IO with buffering */ +static inline size_t xfread(void *, size_t, size_t, xFILE *); +static inline size_t xfwrite(const void *, size_t, size_t, xFILE *); + +/* indicator positioning */ +static inline long xfseek(xFILE *, long offset, int whence); +static inline long xftell(xFILE *); +static inline void xrewind(xFILE *); + +/* stream status */ +static inline void xclearerr(xFILE *); +static inline int xfeof(xFILE *); +static inline int xferror(xFILE *); + +/* character IO */ +static inline int xfgetc(xFILE *); +static inline char *xfgets(char *, int, xFILE *); +static inline int xfputc(int, xFILE *); +static inline int xfputs(const char *, xFILE *); +static inline int xgetc(xFILE *); +static inline int xgetchar(void); +static inline int xputc(int, xFILE *); +static inline int xputchar(int); +static inline int xputs(const char *); +static inline int xungetc(int, xFILE *); + +/* formatted I/O */ +static inline int xprintf(const char *, ...); +static inline int xfprintf(xFILE *, const char *, ...); +static inline int xvfprintf(xFILE *, const char *, va_list); + +/* standard I/O */ +#define xstdin (xstdin_()) +#define xstdout (xstdout_()) +#define xstderr (xstderr_()) + + +/* private */ + +#define XF_EOF 1 +#define XF_ERR 2 + +static inline xFILE * +xfunopen(void *cookie, int (*read)(void *, char *, int), int (*write)(void *, const char *, int), long (*seek)(void *, long, int), int (*flush)(void *), int (*close)(void *)) +{ + xFILE *file; + + file = (xFILE *)malloc(sizeof(xFILE)); + if (! file) { + return NULL; + } + file->ungot = -1; + file->flags = 0; + /* set vtable */ + file->vtable.cookie = cookie; + file->vtable.read = read; + file->vtable.write = write; + file->vtable.seek = seek; + file->vtable.flush = flush; + file->vtable.close = close; + + return file; +} + +/* + * Derieved xFILE Classes + */ + +static inline int +xf_file_read(void *cookie, char *ptr, int size) +{ + FILE *file = cookie; + int r; + + r = (int)fread(ptr, 1, (size_t)size, file); + if (r < size && ferror(file)) { + return -1; + } + if (r == 0 && feof(file)) { + clearerr(file); + } + return r; +} + +static inline int +xf_file_write(void *cookie, const char *ptr, int size) +{ + FILE *file = cookie; + int r; + + r = (int)fwrite(ptr, 1, (size_t)size, file); + if (r < size) { + return -1; + } + return r; +} + +static inline long +xf_file_seek(void *cookie, long pos, int whence) +{ + return fseek(cookie, pos, whence); +} + +static inline int +xf_file_flush(void *cookie) +{ + return fflush(cookie); +} + +static inline int +xf_file_close(void *cookie) +{ + return fclose(cookie); +} + +static inline xFILE * +xfpopen(FILE *fp) +{ + xFILE *file; + + file = xfunopen(fp, xf_file_read, xf_file_write, xf_file_seek, xf_file_flush, xf_file_close); + if (! file) { + return NULL; + } + + return file; +} + +#define XF_FILE_VTABLE xf_file_read, xf_file_write, xf_file_seek, xf_file_flush, xf_file_close + +static inline xFILE * +xstdin_() +{ + static xFILE x = { -1, 0, { NULL, XF_FILE_VTABLE } }; + + if (! x.vtable.cookie) { + x.vtable.cookie = stdin; + } + return &x; +} + +static inline xFILE * +xstdout_() +{ + static xFILE x = { -1, 0, { NULL, XF_FILE_VTABLE } }; + + if (! x.vtable.cookie) { + x.vtable.cookie = stdout; + } + return &x; +} + +static inline xFILE * +xstderr_() +{ + static xFILE x = { -1, 0, { NULL, XF_FILE_VTABLE } }; + + if (! x.vtable.cookie) { + x.vtable.cookie = stderr; + } + return &x; +} + +struct xf_membuf { + char *buf; + long pos, end, capa; +}; + +static inline int +xf_mem_read(void *cookie, char *ptr, int size) +{ + struct xf_membuf *mem; + + mem = (struct xf_membuf *)cookie; + + if (size > (int)(mem->end - mem->pos)) + size = (int)(mem->end - mem->pos); + memcpy(ptr, mem->buf + mem->pos, size); + mem->pos += size; + return size; +} + +static inline int +xf_mem_write(void *cookie, const char *ptr, int size) +{ + struct xf_membuf *mem; + + mem = (struct xf_membuf *)cookie; + + if (mem->pos + size >= mem->capa) { + mem->capa = (mem->pos + size) * 2; + mem->buf = realloc(mem->buf, (size_t)mem->capa); + } + memcpy(mem->buf + mem->pos, ptr, size); + mem->pos += size; + if (mem->end < mem->pos) + mem->end = mem->pos; + return size; +} + +static inline long +xf_mem_seek(void *cookie, long pos, int whence) +{ + struct xf_membuf *mem; + + mem = (struct xf_membuf *)cookie; + + switch (whence) { + case SEEK_SET: + mem->pos = pos; + break; + case SEEK_CUR: + mem->pos += pos; + break; + case SEEK_END: + mem->pos = mem->end + pos; + break; + } + + return mem->pos; +} + +static inline int +xf_mem_flush(void *cookie) +{ + (void)cookie; + + return 0; +} + +static inline int +xf_mem_close(void *cookie) +{ + struct xf_membuf *mem; + + mem = (struct xf_membuf *)cookie; + free(mem->buf); + free(mem); + return 0; +} + +static inline xFILE * +xmopen() +{ + struct xf_membuf *mem; + + mem = (struct xf_membuf *)malloc(sizeof(struct xf_membuf)); + mem->buf = (char *)malloc(BUFSIZ); + mem->pos = 0; + mem->end = 0; + mem->capa = BUFSIZ; + + return xfunopen(mem, xf_mem_read, xf_mem_write, xf_mem_seek, xf_mem_flush, xf_mem_close); +} + +#undef XF_FILE_VTABLE + +static inline xFILE * +xfopen(const char *filename, const char *mode) +{ + FILE *fp; + xFILE *file; + + fp = fopen(filename, mode); + if (! fp) { + return NULL; + } + + file = xfpopen(fp); + if (! file) { + return NULL; + } + + return file; +} + +static inline int +xfclose(xFILE *file) +{ + int r; + + r = file->vtable.close(file->vtable.cookie); + if (r == EOF) { + return -1; + } + + free(file); + return 0; +} + +static inline int +xfflush(xFILE *file) +{ + return file->vtable.flush(file->vtable.cookie); +} + +static inline size_t +xfread(void *ptr, size_t block, size_t nitems, xFILE *file) +{ + char *dst = (char *)ptr; + char buf[block]; + size_t i, offset; + int n; + + for (i = 0; i < nitems; ++i) { + offset = 0; + if (file->ungot != -1 && block > 0) { + buf[0] = (char)file->ungot; + offset += 1; + file->ungot = -1; + } + while (offset < block) { + n = file->vtable.read(file->vtable.cookie, buf + offset, (int)(block - offset)); + if (n < 0) { + file->flags |= XF_ERR; + goto exit; + } + if (n == 0) { + file->flags |= XF_EOF; + goto exit; + } + offset += (unsigned)n; + } + memcpy(dst, buf, block); + dst += block; + } + + exit: + return i; +} + +static inline size_t +xfwrite(const void *ptr, size_t block, size_t nitems, xFILE *file) +{ + char *dst = (char *)ptr; + size_t i, offset; + int n; + + for (i = 0; i < nitems; ++i) { + offset = 0; + while (offset < block) { + n = file->vtable.write(file->vtable.cookie, dst + offset, (int)(block - offset)); + if (n < 0) { + file->flags |= XF_ERR; + goto exit; + } + offset += (unsigned)n; + } + dst += block; + } + + exit: + return i; +} + +static inline long +xfseek(xFILE *file, long offset, int whence) +{ + file->ungot = -1; + return file->vtable.seek(file->vtable.cookie, offset, whence); +} + +static inline long +xftell(xFILE *file) +{ + return xfseek(file, 0, SEEK_CUR); +} + +static inline void +xrewind(xFILE *file) +{ + xfseek(file, 0, SEEK_SET); +} + +static inline void +xclearerr(xFILE *file) +{ + file->flags = 0; +} + +static inline int +xfeof(xFILE *file) +{ + return file->flags & XF_EOF; +} + +static inline int +xferror(xFILE *file) +{ + return file->flags & XF_ERR; +} + +static inline int +xfgetc(xFILE *file) +{ + char buf[1]; + + xfread(buf, 1, 1, file); + + if (xfeof(file) || xferror(file)) { + return EOF; + } + + return buf[0]; +} + +static inline int +xgetc(xFILE *file) +{ + return xfgetc(file); +} + +static inline char * +xfgets(char *str, int size, xFILE *file) +{ + int c = EOF, i; + + for (i = 0; i < size - 1 && c != '\n'; ++i) { + if ((c = xfgetc(file)) == EOF) { + break; + } + str[i] = (char)c; + } + if (i == 0 && c == EOF) { + return NULL; + } + if (xferror(file)) { + return NULL; + } + str[i] = '\0'; + + return str; +} + +static inline int +xungetc(int c, xFILE *file) +{ + file->ungot = c; + if (c != EOF) { + file->flags &= ~XF_EOF; + } + return c; +} + +static inline int +xgetchar(void) +{ + return xfgetc(xstdin); +} + +static inline int +xfputc(int c, xFILE *file) +{ + char buf[1]; + + buf[0] = (char)c; + xfwrite(buf, 1, 1, file); + + if (xferror(file)) { + return EOF; + } + return buf[0]; +} + +static inline int +xputc(int c, xFILE *file) +{ + return xfputc(c, file); +} + +static inline int +xputchar(int c) +{ + return xfputc(c, xstdout); +} + +static inline int +xfputs(const char *str, xFILE *file) +{ + size_t len; + + len = strlen(str); + xfwrite(str, len, 1, file); + + if (xferror(file)) { + return EOF; + } + return 0; +} + +static inline int +xputs(const char *s) +{ + return xfputs(s, xstdout); +} + +static inline int +xprintf(const char *fmt, ...) +{ + va_list ap; + int n; + + va_start(ap, fmt); + n = xvfprintf(xstdout, fmt, ap); + va_end(ap); + return n; +} + +static inline int +xfprintf(xFILE *stream, const char *fmt, ...) +{ + va_list ap; + int n; + + va_start(ap, fmt); + n = xvfprintf(stream, fmt, ap); + va_end(ap); + return n; +} + +static inline int +xvfprintf(xFILE *stream, const char *fmt, va_list ap) +{ + va_list ap2; + + va_copy(ap2, ap); + { + char buf[vsnprintf(NULL, 0, fmt, ap2)]; + + vsnprintf(buf, sizeof buf + 1, fmt, ap); + + if (xfwrite(buf, sizeof buf, 1, stream) < 1) { + return -1; + } + + va_end(ap2); + return (int)(sizeof buf); + } +} + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/xhash.h b/extlib/benz/include/picrin/xhash.h new file mode 100644 index 00000000..e25302ed --- /dev/null +++ b/extlib/benz/include/picrin/xhash.h @@ -0,0 +1,427 @@ +#ifndef XHASH_H +#define XHASH_H + +/* + * Copyright (c) 2013-2014 by Yuichi Nishiwaki + */ + +#if defined(__cplusplus) +extern "C" { +#endif + +#include +#include +#include +#include +#include + +/* simple object to object hash table */ + +#define XHASH_INIT_SIZE 11 +#define XHASH_RESIZE_RATIO 0.75 + +#define XHASH_ALIGNMENT 3 /* quad word alignment */ +#define XHASH_MASK (~(size_t)((1 << XHASH_ALIGNMENT) - 1)) +#define XHASH_ALIGN(i) ((((i) - 1) & XHASH_MASK) + (1 << XHASH_ALIGNMENT)) + +typedef struct xh_entry { + struct xh_entry *next; + int hash; + struct xh_entry *fw, *bw; + const void *key; + void *val; +} xh_entry; + +#define xh_key(e,type) (*(type *)((e)->key)) +#define xh_val(e,type) (*(type *)((e)->val)) + +typedef int (*xh_hashf)(const void *, void *); +typedef int (*xh_equalf)(const void *, const void *, void *); + +typedef struct xhash { + xh_entry **buckets; + size_t size, count, kwidth, vwidth; + size_t koffset, voffset; + xh_hashf hashf; + xh_equalf equalf; + xh_entry *head, *tail; + void *data; +} xhash; + +/** Protected Methods: + * static inline void xh_init_(xhash *x, size_t, size_t, xh_hashf, xh_equalf, void *); + * static inline xh_entry *xh_get_(xhash *x, const void *key); + * static inline xh_entry *xh_put_(xhash *x, const void *key, void *val); + * static inline void xh_del_(xhash *x, const void *key); + */ + +/* string map */ +static inline void xh_init_str(xhash *x, size_t width); +static inline xh_entry *xh_get_str(xhash *x, const char *key); +static inline xh_entry *xh_put_str(xhash *x, const char *key, void *); +static inline void xh_del_str(xhash *x, const char *key); + +/* object map */ +static inline void xh_init_ptr(xhash *x, size_t width); +static inline xh_entry *xh_get_ptr(xhash *x, const void *key); +static inline xh_entry *xh_put_ptr(xhash *x, const void *key, void *); +static inline void xh_del_ptr(xhash *x, const void *key); + +/* int map */ +static inline void xh_init_int(xhash *x, size_t width); +static inline xh_entry *xh_get_int(xhash *x, int key); +static inline xh_entry *xh_put_int(xhash *x, int key, void *); +static inline void xh_del_int(xhash *x, int key); + +static inline size_t xh_size(xhash *x); +static inline void xh_clear(xhash *x); +static inline void xh_destroy(xhash *x); + +static inline xh_entry *xh_begin(xhash *x); +static inline xh_entry *xh_next(xh_entry *e); + + +static inline void +xh_bucket_realloc(xhash *x, size_t newsize) +{ + x->size = newsize; + x->buckets = realloc(x->buckets, (x->size + 1) * sizeof(xh_entry *)); + memset(x->buckets, 0, (x->size + 1) * sizeof(xh_entry *)); +} + +static inline void +xh_init_(xhash *x, size_t kwidth, size_t vwidth, xh_hashf hashf, xh_equalf equalf, void *data) +{ + x->size = 0; + x->buckets = NULL; + x->count = 0; + x->kwidth = kwidth; + x->vwidth = vwidth; + x->koffset = XHASH_ALIGN(sizeof(xh_entry)); + x->voffset = XHASH_ALIGN(sizeof(xh_entry)) + XHASH_ALIGN(kwidth); + x->hashf = hashf; + x->equalf = equalf; + x->head = NULL; + x->tail = NULL; + x->data = data; + + xh_bucket_realloc(x, XHASH_INIT_SIZE); +} + +static inline xh_entry * +xh_get_(xhash *x, const void *key) +{ + int hash; + size_t idx; + xh_entry *e; + + hash = x->hashf(key, x->data); + idx = ((unsigned)hash) % x->size; + for (e = x->buckets[idx]; e; e = e->next) { + if (e->hash == hash && x->equalf(key, e->key, x->data)) + break; + } + return e; +} + +static inline void +xh_resize_(xhash *x, size_t newsize) +{ + xhash y; + xh_entry *it; + size_t idx; + + xh_init_(&y, x->kwidth, x->vwidth, x->hashf, x->equalf, x->data); + xh_bucket_realloc(&y, newsize); + + for (it = xh_begin(x); it != NULL; it = xh_next(it)) { + idx = ((unsigned)it->hash) % y.size; + /* reuse entry object */ + it->next = y.buckets[idx]; + y.buckets[idx] = it; + y.count++; + } + + y.head = x->head; + y.tail = x->tail; + + free(x->buckets); + + /* copy all members from y to x */ + memcpy(x, &y, sizeof(xhash)); +} + +static inline xh_entry * +xh_put_(xhash *x, const void *key, void *val) +{ + int hash; + size_t idx; + xh_entry *e; + + if ((e = xh_get_(x, key))) { + memcpy(e->val, val, x->vwidth); + return e; + } + + if (x->count + 1 > x->size * XHASH_RESIZE_RATIO) { + xh_resize_(x, x->size * 2 + 1); + } + + hash = x->hashf(key, x->data); + idx = ((unsigned)hash) % x->size; + e = malloc(x->voffset + x->vwidth); + e->next = x->buckets[idx]; + e->hash = hash; + e->key = ((char *)e) + x->koffset; + e->val = ((char *)e) + x->voffset; + memcpy((void *)e->key, key, x->kwidth); + memcpy(e->val, val, x->vwidth); + + if (x->head == NULL) { + x->head = x->tail = e; + e->fw = e->bw = NULL; + } else { + x->tail->bw = e; + e->fw = x->tail; + e->bw = NULL; + x->tail = e; + } + + x->count++; + + return x->buckets[idx] = e; +} + +static inline void +xh_del_(xhash *x, const void *key) +{ + int hash; + size_t idx; + xh_entry *p, *q, *r; + + hash = x->hashf(key, x->data); + idx = ((unsigned)hash) % x->size; + if (x->buckets[idx]->hash == hash && x->equalf(key, x->buckets[idx]->key, x->data)) { + q = x->buckets[idx]; + if (q->fw == NULL) { + x->head = q->bw; + } else { + q->fw->bw = q->bw; + } + if (q->bw == NULL) { + x->tail = q->fw; + } else { + q->bw->fw = q->fw; + } + r = q->next; + free(q); + x->buckets[idx] = r; + } + else { + for (p = x->buckets[idx]; ; p = p->next) { + if (p->next->hash == hash && x->equalf(key, p->next->key, x->data)) + break; + } + q = p->next; + if (q->fw == NULL) { + x->head = q->bw; + } else { + q->fw->bw = q->bw; + } + if (q->bw == NULL) { + x->tail = q->fw; + } else { + q->bw->fw = q->fw; + } + r = q->next; + free(q); + p->next = r; + } + + x->count--; +} + +static inline size_t +xh_size(xhash *x) +{ + return x->count; +} + +static inline void +xh_clear(xhash *x) +{ + size_t i; + xh_entry *e, *d; + + for (i = 0; i < x->size; ++i) { + e = x->buckets[i]; + while (e) { + d = e->next; + free(e); + e = d; + } + x->buckets[i] = NULL; + } + + x->head = x->tail = NULL; + x->count = 0; +} + +static inline void +xh_destroy(xhash *x) +{ + xh_clear(x); + free(x->buckets); +} + +/* string map */ + +static inline int +xh_str_hash(const void *key, void *data) +{ + const char *str = *(const char **)key; + int hash = 0; + + (void)data; + + while (*str) { + hash = hash * 31 + *str++; + } + return hash; +} + +static inline int +xh_str_equal(const void *key1, const void *key2, void *data) +{ + (void)data; + + return strcmp(*(const char **)key1, *(const char **)key2) == 0; +} + +static inline void +xh_init_str(xhash *x, size_t width) +{ + xh_init_(x, sizeof(const char *), width, xh_str_hash, xh_str_equal, NULL); +} + +static inline xh_entry * +xh_get_str(xhash *x, const char *key) +{ + return xh_get_(x, &key); +} + +static inline xh_entry * +xh_put_str(xhash *x, const char *key, void *val) +{ + return xh_put_(x, &key, val); +} + +static inline void +xh_del_str(xhash *x, const char *key) +{ + xh_del_(x, &key); +} + +/* object map */ + +static inline int +xh_ptr_hash(const void *key, void *data) +{ + (void)data; + + return (int)(size_t)*(const void **)key; +} + +static inline int +xh_ptr_equal(const void *key1, const void *key2, void *data) +{ + (void) data; + + return *(const void **)key1 == *(const void **)key2; +} + +static inline void +xh_init_ptr(xhash *x, size_t width) +{ + xh_init_(x, sizeof(const void *), width, xh_ptr_hash, xh_ptr_equal, NULL); +} + +static inline xh_entry * +xh_get_ptr(xhash *x, const void *key) +{ + return xh_get_(x, &key); +} + +static inline xh_entry * +xh_put_ptr(xhash *x, const void *key, void *val) +{ + return xh_put_(x, &key, val); +} + +static inline void +xh_del_ptr(xhash *x, const void *key) +{ + xh_del_(x, &key); +} + +/* int map */ + +static inline int +xh_int_hash(const void *key, void *data) +{ + (void)data; + + return *(int *)key; +} + +static inline int +xh_int_equal(const void *key1, const void *key2, void *data) +{ + (void)data; + + return *(int *)key1 == *(int *)key2; +} + +static inline void +xh_init_int(xhash *x, size_t width) +{ + xh_init_(x, sizeof(int), width, xh_int_hash, xh_int_equal, NULL); +} + +static inline xh_entry * +xh_get_int(xhash *x, int key) +{ + return xh_get_(x, &key); +} + +static inline xh_entry * +xh_put_int(xhash *x, int key, void *val) +{ + return xh_put_(x, &key, val); +} + +static inline void +xh_del_int(xhash *x, int key) +{ + xh_del_(x, &key); +} + +/** iteration */ + +static inline xh_entry * +xh_begin(xhash *x) +{ + return x->head; +} + +static inline xh_entry * +xh_next(xh_entry *e) +{ + return e->bw; +} + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/xrope.h b/extlib/benz/include/picrin/xrope.h new file mode 100644 index 00000000..89842de0 --- /dev/null +++ b/extlib/benz/include/picrin/xrope.h @@ -0,0 +1,329 @@ +#ifndef XROPE_H__ +#define XROPE_H__ + +#if defined(__cplusplus) +extern "C" { +#endif + +#include +#include +#include +#include + +/* public APIs */ + +typedef struct xrope xrope; + +/** + * | name | frees buffer? | end with NULL? | complexity | misc + * | ---- | ---- | ---- | ---- | --- + * | xr_new_cstr | no | yes | O(1) | xr_new(_lit) + * | xr_new_imbed | no | no | O(1) | + * | xr_new_move | yes | yes | O(1) | + * | xr_new_copy | yes | no | O(n) | + */ + +#define xr_new(cstr) xr_new_cstr(cstr, strlen(cstr)) +#define xr_new_lit(cstr) xr_new_cstr(cstr, sizeof(cstr) - 1) +static inline xrope *xr_new_cstr(const char *, size_t); +static inline xrope *xr_new_imbed(const char *, size_t); +static inline xrope *xr_new_move(const char *, size_t); +static inline xrope *xr_new_copy(const char *, size_t); + +static inline void XROPE_INCREF(xrope *); +static inline void XROPE_DECREF(xrope *); + +static inline size_t xr_len(xrope *); +static inline char xr_at(xrope *, size_t); +static inline xrope *xr_cat(xrope *, xrope *); +static inline xrope *xr_sub(xrope *, size_t, size_t); +static inline const char *xr_cstr(xrope *); /* returns NULL-terminated string */ + + +/* impl */ + +typedef struct { + char *str; + int refcnt; + size_t len; + char autofree, zeroterm; +} xr_chunk; + +#define XR_CHUNK_INCREF(c) do { \ + (c)->refcnt++; \ + } while (0) + +#define XR_CHUNK_DECREF(c) do { \ + xr_chunk *c__ = (c); \ + if (! --c__->refcnt) { \ + if (c__->autofree) \ + free(c__->str); \ + free(c__); \ + } \ + } while (0) + +struct xrope { + int refcnt; + size_t weight; + xr_chunk *chunk; + size_t offset; + struct xrope *left, *right; +}; + +static inline void +XROPE_INCREF(xrope *x) { + x->refcnt++; +} + +static inline void +XROPE_DECREF(xrope *x) { + if (! --x->refcnt) { + if (x->chunk) { + XR_CHUNK_DECREF(x->chunk); + free(x); + return; + } + XROPE_DECREF(x->left); + XROPE_DECREF(x->right); + free(x); + } +} + +static inline xrope * +xr_new_cstr(const char *cstr, size_t len) +{ + xr_chunk *c; + xrope *x; + + c = (xr_chunk *)malloc(sizeof(xr_chunk)); + c->refcnt = 1; + c->str = (char *)cstr; + c->len = len; + c->autofree = 0; + c->zeroterm = 1; + + x = (xrope *)malloc(sizeof(xrope)); + x->refcnt = 1; + x->left = NULL; + x->right = NULL; + x->weight = c->len; + x->offset = 0; + x->chunk = c; + + return x; +} + +static inline xrope * +xr_new_imbed(const char *str, size_t len) +{ + xr_chunk *c; + xrope *x; + + c = (xr_chunk *)malloc(sizeof(xr_chunk)); + c->refcnt = 1; + c->str = (char *)str; + c->len = len; + c->autofree = 0; + c->zeroterm = 0; + + x = (xrope *)malloc(sizeof(xrope)); + x->refcnt = 1; + x->left = NULL; + x->right = NULL; + x->weight = c->len; + x->offset = 0; + x->chunk = c; + + return x; +} + +static inline xrope * +xr_new_move(const char *cstr, size_t len) +{ + xr_chunk *c; + xrope *x; + + c = (xr_chunk *)malloc(sizeof(xr_chunk)); + c->refcnt = 1; + c->str = (char *)cstr; + c->len = len; + c->autofree = 1; + c->zeroterm = 1; + + x = (xrope *)malloc(sizeof(xrope)); + x->refcnt = 1; + x->left = NULL; + x->right = NULL; + x->weight = c->len; + x->offset = 0; + x->chunk = c; + + return x; +} + +static inline xrope * +xr_new_copy(const char *str, size_t len) +{ + char *buf; + xr_chunk *c; + xrope *x; + + buf = (char *)malloc(len + 1); + buf[len] = '\0'; + memcpy(buf, str, len); + + c = (xr_chunk *)malloc(sizeof(xr_chunk)); + c->refcnt = 1; + c->str = buf; + c->len = len; + c->autofree = 1; + c->zeroterm = 1; + + x = (xrope *)malloc(sizeof(xrope)); + x->refcnt = 1; + x->left = NULL; + x->right = NULL; + x->weight = c->len; + x->offset = 0; + x->chunk = c; + + return x; +} + +static inline size_t +xr_len(xrope *x) +{ + return x->weight; +} + +static inline char +xr_at(xrope *x, size_t i) +{ + if (x->weight <= i) { + return -1; + } + if (x->chunk) { + return x->chunk->str[x->offset + i]; + } + return (i < x->left->weight) + ? xr_at(x->left, i) + : xr_at(x->right, i - x->left->weight); +} + +static inline xrope * +xr_cat(xrope *x, xrope *y) +{ + xrope *z; + + z = (xrope *)malloc(sizeof(xrope)); + z->refcnt = 1; + z->left = x; + z->right = y; + z->weight = x->weight + y->weight; + z->offset = 0; + z->chunk = NULL; + + XROPE_INCREF(x); + XROPE_INCREF(y); + + return z; +} + +static inline struct xrope * +xr_sub(xrope *x, size_t i, size_t j) +{ + assert(i <= j); + assert(j <= x->weight); + + if (i == 0 && x->weight == j) { + XROPE_INCREF(x); + return x; + } + + if (x->chunk) { + xrope *y; + + y = (xrope *)malloc(sizeof(xrope)); + y->refcnt = 1; + y->left = NULL; + y->right = NULL; + y->weight = j - i; + y->offset = x->offset + i; + y->chunk = x->chunk; + + XR_CHUNK_INCREF(x->chunk); + + return y; + } + + if (j <= x->left->weight) { + return xr_sub(x->left, i, j); + } + else if (x->left->weight <= i) { + return xr_sub(x->right, i - x->left->weight, j - x->left->weight); + } + else { + xrope *r, *l; + + l = xr_sub(x->left, i, x->left->weight); + r = xr_sub(x->right, 0, j - x->left->weight); + x = xr_cat(l, r); + + XROPE_DECREF(l); + XROPE_DECREF(r); + + return x; + } +} + +static inline void +xr_fold(xrope *x, xr_chunk *c, size_t offset) +{ + if (x->chunk) { + memcpy(c->str + offset, x->chunk->str + x->offset, x->weight); + XR_CHUNK_DECREF(x->chunk); + + x->chunk = c; + x->offset = offset; + XR_CHUNK_INCREF(c); + return; + } + xr_fold(x->left, c, offset); + xr_fold(x->right, c, offset + x->left->weight); + + XROPE_DECREF(x->left); + XROPE_DECREF(x->right); + x->left = x->right = NULL; + x->chunk = c; + x->offset = offset; + XR_CHUNK_INCREF(c); +} + +static inline const char * +xr_cstr(xrope *x) +{ + xr_chunk *c; + + if (x->chunk && x->offset == 0 && x->weight == x->chunk->len && x->chunk->zeroterm) { + return x->chunk->str; /* reuse cached chunk */ + } + + c = (xr_chunk *)malloc(sizeof(xr_chunk)); + c->refcnt = 1; + c->len = x->weight; + c->autofree = 1; + c->zeroterm = 1; + c->str = (char *)malloc(c->len + 1); + c->str[c->len] = '\0'; + + xr_fold(x, c, 0); + + XR_CHUNK_DECREF(c); + return c->str; +} + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/include/picrin/xvect.h b/extlib/benz/include/picrin/xvect.h new file mode 100644 index 00000000..3701205e --- /dev/null +++ b/extlib/benz/include/picrin/xvect.h @@ -0,0 +1,207 @@ +#ifndef XVECT_H__ +#define XVECT_H__ + +/* + * Copyright (c) 2014 by Yuichi Nishiwaki + */ + +#if defined(__cplusplus) +extern "C" { +#endif + +#include +#include +#include +#include + +typedef struct xvect { + char *data; + size_t size, mask, head, tail, width; +} xvect; + +static inline void xv_init(xvect *, size_t); +static inline void xv_destroy(xvect *); + +static inline size_t xv_size(xvect *); + +static inline void xv_reserve(xvect *, size_t); +static inline void xv_shrink(xvect *, size_t); + +static inline void *xv_get(xvect *, size_t); +static inline void xv_set(xvect *, size_t, void *); + +static inline void xv_push(xvect *, void *); +static inline void *xv_pop(xvect *); + +static inline void *xv_shift(xvect *); +static inline void xv_unshift(xvect *, void *); + +static inline void xv_splice(xvect *, size_t, size_t); +static inline void xv_insert(xvect *, size_t, void *); + +static inline void +xv_init(xvect *x, size_t width) +{ + x->data = NULL; + x->width = width; + x->size = 0; + x->mask = (size_t)-1; + x->head = 0; + x->tail = 0; +} + +static inline void +xv_destroy(xvect *x) +{ + free(x->data); +} + +static inline size_t +xv_size(xvect *x) +{ + return x->tail < x->head + ? x->tail + x->size - x->head + : x->tail - x->head; +} + +static inline size_t +xv_round2(size_t x) +{ + x -= 1; + x |= (x >> 1); + x |= (x >> 2); + x |= (x >> 4); + x |= (x >> 8); + x |= (x >> 16); + x |= (x >> 32); + x++; + return x; +} + +static inline void +xv_rotate(xvect *x) +{ + if (x->tail < x->head) { + char buf[x->size * x->width]; + + /* perform rotation */ + memcpy(buf, x->data, sizeof buf); + memcpy(x->data, buf + x->head * x->width, (x->size - x->head) * x->width); + memcpy(x->data + (x->size - x->head) * x->width, buf, x->tail * x->width); + x->tail = x->size - x->head + x->tail; + x->head = 0; + } +} + +static inline void +xv_adjust(xvect *x, size_t size) +{ + size = xv_round2(size); + if (size != x->size) { + xv_rotate(x); + x->data = realloc(x->data, size * x->width); + x->size = size; + x->mask = size - 1; + } +} + +static inline void +xv_reserve(xvect *x, size_t mincapa) +{ + if (x->size < mincapa + 1) { + xv_adjust(x, mincapa + 1); /* capa == size - 1 */ + } +} + +static inline void +xv_shrink(xvect *x, size_t maxcapa) +{ + if (x->size > maxcapa + 1) { + xv_adjust(x, maxcapa + 1); /* capa == size - 1 */ + } +} + +static inline void * +xv_get(xvect *x, size_t i) +{ + assert(i < xv_size(x)); + + return x->data + ((x->head + i) & x->mask) * x->width; +} + +static inline void +xv_set(xvect *x, size_t i, void *src) +{ + memcpy(xv_get(x, i), src, x->width); +} + +static inline void +xv_push(xvect *x, void *src) +{ + xv_reserve(x, xv_size(x) + 1); + x->tail = (x->tail + 1) & x->mask; + xv_set(x, xv_size(x) - 1, src); +} + +static inline void * +xv_pop(xvect *x) +{ + void *dat; + + assert(xv_size(x) >= 1); + + dat = xv_get(x, xv_size(x) - 1); + x->tail = (x->tail - 1) & x->mask; + return dat; +} + +static inline void * +xv_shift(xvect *x) +{ + void *dat; + + assert(xv_size(x) >= 1); + + dat = xv_get(x, 0); + x->head = (x->head + 1) & x->mask; + return dat; +} + +static inline void +xv_unshift(xvect *x, void *src) +{ + xv_reserve(x, xv_size(x) + 1); + x->head = (x->head - 1) & x->mask; + xv_set(x, 0, src); +} + +static inline void +xv_splice(xvect *x, size_t i, size_t j) +{ + assert(i <= j && j < xv_size(x)); + + xv_rotate(x); + memmove(xv_get(x, i), xv_get(x, j), (xv_size(x) - j) * x->width); + x->tail = (x->tail - j + i) & x->mask; +} + +static inline void +xv_insert(xvect *x, size_t i, void *src) +{ + assert(i <= xv_size(x)); + + xv_reserve(x, xv_size(x) + 1); + xv_rotate(x); + x->tail = (x->tail + 1) & x->mask; + + if (xv_size(x) - 1 != i) { + memmove(xv_get(x, i + 1), xv_get(x, i), (xv_size(x) - 1 - i) * x->width); + } + xv_set(x, i, src); +} + +#if defined(__cplusplus) +} +#endif + +#endif diff --git a/extlib/benz/init.c b/extlib/benz/init.c new file mode 100644 index 00000000..06e97ca2 --- /dev/null +++ b/extlib/benz/init.c @@ -0,0 +1,148 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/pair.h" +#include "picrin/lib.h" +#include "picrin/macro.h" +#include "picrin/error.h" + +void +pic_add_feature(pic_state *pic, const char *feature) +{ + pic_push(pic, pic_sym_value(pic_intern_cstr(pic, feature)), pic->features); +} + +void pic_init_bool(pic_state *); +void pic_init_pair(pic_state *); +void pic_init_port(pic_state *); +void pic_init_number(pic_state *); +void pic_init_time(pic_state *); +void pic_init_system(pic_state *); +void pic_init_file(pic_state *); +void pic_init_proc(pic_state *); +void pic_init_symbol(pic_state *); +void pic_init_vector(pic_state *); +void pic_init_blob(pic_state *); +void pic_init_cont(pic_state *); +void pic_init_char(pic_state *); +void pic_init_error(pic_state *); +void pic_init_str(pic_state *); +void pic_init_macro(pic_state *); +void pic_init_var(pic_state *); +void pic_init_load(pic_state *); +void pic_init_write(pic_state *); +void pic_init_read(pic_state *); +void pic_init_dict(pic_state *); +void pic_init_record(pic_state *); +void pic_init_eval(pic_state *); +void pic_init_lib(pic_state *); +void pic_init_attr(pic_state *); + +extern const char pic_boot[]; + +static void +pic_init_features(pic_state *pic) +{ + pic_add_feature(pic, "picrin"); + pic_add_feature(pic, "ieee-float"); + +#if _POSIX_SOURCE + pic_add_feature(pic, "posix"); +#endif + +#if _WIN32 + pic_add_feature(pic, "windows"); +#endif + +#if __unix__ + pic_add_feature(pic, "unix"); +#endif +#if __gnu_linux__ + pic_add_feature(pic, "gnu-linux"); +#endif +#if __FreeBSD__ + pic_add_feature(pic, "freebsd"); +#endif + +#if __i386__ + pic_add_feature(pic, "i386"); +#elif __x86_64__ + pic_add_feature(pic, "x86-64"); +#elif __ppc__ + pic_add_feature(pic, "ppc"); +#elif __sparc__ + pic_add_feature(pic, "sparc"); +#endif + +#if __ILP32__ + pic_add_feature(pic, "ilp32"); +#elif __LP64__ + pic_add_feature(pic, "lp64"); +#endif + +#if defined(__BYTE_ORDER__) +# if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + pic_add_feature(pic, "little-endian"); +# elif __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ + pic_add_feature(pic, "big-endian"); +# endif +#else +# if __LITTLE_ENDIAN__ + pic_add_feature(pic, "little-endian"); +# elif __BIG_ENDIAN__ + pic_add_feature(pic, "big-endian"); +# endif +#endif +} + +#define DONE pic_gc_arena_restore(pic, ai); + +void +pic_init_core(pic_state *pic) +{ + size_t ai = pic_gc_arena_preserve(pic); + + pic_init_features(pic); + + pic_deflibrary (pic, "(picrin base)") { + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX); + + pic_init_bool(pic); DONE; + pic_init_pair(pic); DONE; + pic_init_port(pic); DONE; + pic_init_number(pic); DONE; + pic_init_time(pic); DONE; + pic_init_system(pic); DONE; + pic_init_file(pic); DONE; + pic_init_proc(pic); DONE; + pic_init_symbol(pic); DONE; + pic_init_vector(pic); DONE; + pic_init_blob(pic); DONE; + pic_init_cont(pic); DONE; + pic_init_char(pic); DONE; + pic_init_error(pic); DONE; + pic_init_str(pic); DONE; + pic_init_macro(pic); DONE; + pic_init_var(pic); DONE; + pic_init_load(pic); DONE; + pic_init_write(pic); DONE; + pic_init_read(pic); DONE; + pic_init_dict(pic); DONE; + pic_init_record(pic); DONE; + pic_init_eval(pic); DONE; + pic_init_lib(pic); DONE; + pic_init_attr(pic); DONE; + + pic_load_cstr(pic, pic_boot); + } + + pic_import_library(pic, pic->PICRIN_BASE); +} diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c new file mode 100644 index 00000000..37cba2bd --- /dev/null +++ b/extlib/benz/lib.c @@ -0,0 +1,349 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/lib.h" +#include "picrin/pair.h" +#include "picrin/macro.h" +#include "picrin/error.h" +#include "picrin/string.h" +#include "picrin/proc.h" + +struct pic_lib * +pic_open_library(pic_state *pic, pic_value name) +{ + struct pic_lib *lib; + struct pic_senv *senv; + + if ((lib = pic_find_library(pic, name)) != NULL) { + +#if DEBUG + printf("* reopen library: "); + pic_debug(pic, name); + puts(""); +#endif + + return lib; + } + + senv = pic_null_syntactic_environment(pic); + + lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB); + lib->env = senv; + lib->name = name; + xh_init_int(&lib->exports, sizeof(pic_sym)); + + /* register! */ + pic->libs = pic_acons(pic, name, pic_obj_value(lib), pic->libs); + + return lib; +} + +void +pic_in_library(pic_state *pic, pic_value spec) +{ + struct pic_lib *lib; + + lib = pic_find_library(pic, spec); + if (! lib) { + pic_errorf(pic, "library not found: ~a", spec); + } + pic->lib = lib; +} + +struct pic_lib * +pic_find_library(pic_state *pic, pic_value spec) +{ + pic_value v; + + v = pic_assoc(pic, spec, pic->libs, NULL); + if (pic_false_p(v)) { + return NULL; + } + return pic_lib_ptr(pic_cdr(pic, v)); +} + +static void +import_table(pic_state *pic, pic_value spec, xhash *imports) +{ + struct pic_lib *lib; + xhash table; + pic_value val; + pic_sym sym, id, tag; + xh_entry *it; + + xh_init_int(&table, sizeof(pic_sym)); + + if (pic_pair_p(spec) && pic_sym_p(pic_car(pic, spec))) { + + tag = pic_sym(pic_car(pic, spec)); + + if (tag == pic->sONLY) { + import_table(pic, pic_cadr(pic, spec), &table); + pic_for_each (val, pic_cddr(pic, spec)) { + xh_put_int(imports, pic_sym(val), &xh_val(xh_get_int(&table, pic_sym(val)), pic_sym)); + } + goto exit; + } + if (tag == pic->sRENAME) { + import_table(pic, pic_cadr(pic, spec), imports); + pic_for_each (val, pic_cddr(pic, spec)) { + id = xh_val(xh_get_int(imports, pic_sym(pic_car(pic, val))), pic_sym); + xh_del_int(imports, pic_sym(pic_car(pic, val))); + xh_put_int(imports, pic_sym(pic_cadr(pic, val)), &id); + } + goto exit; + } + if (tag == pic->sPREFIX) { + import_table(pic, pic_cadr(pic, spec), &table); + for (it = xh_begin(&table); it != NULL; it = xh_next(it)) { + val = pic_list_ref(pic, spec, 2); + sym = pic_intern_str(pic, pic_format(pic, "~s~s", val, pic_sym_value(xh_key(it, pic_sym)))); + xh_put_int(imports, sym, &xh_val(it, pic_sym)); + } + goto exit; + } + if (tag == pic->sEXCEPT) { + import_table(pic, pic_cadr(pic, spec), imports); + pic_for_each (val, pic_cddr(pic, spec)) { + xh_del_int(imports, pic_sym(val)); + } + goto exit; + } + } + lib = pic_find_library(pic, spec); + if (! lib) { + pic_errorf(pic, "library not found: ~a", spec); + } + for (it = xh_begin(&lib->exports); it != NULL; it = xh_next(it)) { + xh_put_int(imports, xh_key(it, pic_sym), &xh_val(it, pic_sym)); + } + + exit: + xh_destroy(&table); +} + +static void +import(pic_state *pic, pic_value spec) +{ + xhash imports; + xh_entry *it; + + xh_init_int(&imports, sizeof(pic_sym)); /* pic_sym to pic_sym */ + + import_table(pic, spec, &imports); + + for (it = xh_begin(&imports); it != NULL; it = xh_next(it)) { + +#if DEBUG + printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it, pic_sym)), pic_symbol_name(pic, xh_val(it, pic_sym))); +#endif + + pic_put_rename(pic, pic->lib->env, xh_key(it, pic_sym), xh_val(it, pic_sym)); + } + + xh_destroy(&imports); +} + +static void +export(pic_state *pic, pic_value spec) +{ + const pic_sym sRENAME = pic_intern_cstr(pic, "rename"); + pic_value a, b; + pic_sym rename; + + 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_sym_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 (! pic_find_rename(pic, pic->lib->env, pic_sym(a), &rename)) { + pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, pic_sym(a))); + } + +#if DEBUG + printf("* exporting %s as %s\n", pic_symbol_name(pic, pic_sym(b)), pic_symbol_name(pic, rename)); +#endif + + xh_put_int(&pic->lib->exports, pic_sym(b), &rename); + + return; + + fail: + pic_errorf(pic, "illegal export spec: ~s", spec); +} + +void +pic_import(pic_state *pic, pic_value spec) +{ + 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_sym_value(sym)); +} + +static bool +condexpand(pic_state *pic, pic_value clause) +{ + pic_sym tag; + pic_value c, feature; + + if (pic_eq_p(clause, pic_sym_value(pic->sELSE))) { + return true; + } + if (pic_sym_p(clause)) { + pic_for_each (feature, pic->features) { + 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(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)) { + if (! condexpand(pic, c)) + return false; + } + return true; + } + if (tag == pic->sOR) { + pic_for_each (c, pic_cdr(pic, clause)) { + 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_sym_value(pic->rBEGIN), pic_cdr(pic, clauses[i])); + } + } + + return pic_none_value(); +} + +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_none_value(); +} + +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_none_value(); +} + +static pic_value +pic_lib_define_library(pic_state *pic) +{ + struct pic_lib *prev = pic->lib; + size_t argc, i; + pic_value spec, *argv; + + pic_get_args(pic, "o*", &spec, &argc, &argv); + + pic_open_library(pic, spec); + + pic_try { + pic_in_library(pic, spec); + + for (i = 0; i < argc; ++i) { + pic_void(pic_eval(pic, argv[i], pic->lib)); + } + + pic_in_library(pic, prev->name); + } + pic_catch { + pic_in_library(pic, prev->name); /* restores pic->lib even if an error occurs */ + pic_raise(pic, pic->err); + } + + return pic_none_value(); +} + +static pic_value +pic_lib_in_library(pic_state *pic) +{ + pic_value spec; + + pic_get_args(pic, "o", &spec); + + pic_in_library(pic, spec); + + return pic_none_value(); +} + +void +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->rCOND_EXPAND, pic_lib_condexpand); + pic_defmacro(pic, pic->sIMPORT, pic->rIMPORT, pic_lib_import); + pic_defmacro(pic, pic->sEXPORT, pic->rEXPORT, pic_lib_export); + pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY, pic_lib_define_library); + pic_defmacro(pic, pic->sIN_LIBRARY, pic->rIN_LIBRARY, pic_lib_in_library); +} diff --git a/extlib/benz/load.c b/extlib/benz/load.c new file mode 100644 index 00000000..83deb212 --- /dev/null +++ b/extlib/benz/load.c @@ -0,0 +1,77 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/pair.h" +#include "picrin/port.h" +#include "picrin/error.h" + +static void +pic_load_port(pic_state *pic, struct pic_port *port) +{ + pic_value form; + + pic_try { + size_t ai = pic_gc_arena_preserve(pic); + + while (! pic_eof_p(form = pic_read(pic, port))) { + pic_eval(pic, form, pic->lib); + + pic_gc_arena_restore(pic, ai); + } + } + pic_catch { + pic_errorf(pic, "load error: %s", pic_errmsg(pic)); + } +} + +void +pic_load_cstr(pic_state *pic, const char *src) +{ + struct pic_port *port = pic_open_input_string(pic, src); + + pic_load_port(pic, port); + + pic_close_port(pic, port); +} + +void +pic_load(pic_state *pic, const char *filename) +{ + struct pic_port *port; + xFILE *file; + + file = xfopen(filename, "r"); + if (file == NULL) { + pic_errorf(pic, "could not open file: %s", filename); + } + + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); + port->file = file; + port->flags = PIC_PORT_IN | PIC_PORT_TEXT; + port->status = PIC_PORT_OPEN; + + pic_load_port(pic, port); + + pic_close_port(pic, port); +} + +static pic_value +pic_load_load(pic_state *pic) +{ + pic_value envid; + char *fn; + + pic_get_args(pic, "z|o", &fn, &envid); + + pic_load(pic, fn); + + return pic_none_value(); +} + +void +pic_init_load(pic_state *pic) +{ + pic_defun(pic, "load", pic_load_load); +} diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c new file mode 100644 index 00000000..c7cd243f --- /dev/null +++ b/extlib/benz/macro.c @@ -0,0 +1,506 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/pair.h" +#include "picrin/string.h" +#include "picrin/proc.h" +#include "picrin/macro.h" +#include "picrin/lib.h" +#include "picrin/error.h" +#include "picrin/dict.h" +#include "picrin/cont.h" + +pic_sym +pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym) +{ + pic_sym rename; + + rename = pic_gensym(pic, sym); + pic_put_rename(pic, senv, sym, rename); + return rename; +} + +void +pic_put_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rename) +{ + UNUSED(pic); + + xh_put_int(&senv->map, sym, &rename); +} + +bool +pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *rename) +{ + xh_entry *e; + + UNUSED(pic); + + if ((e = xh_get_int(&senv->map, sym)) == NULL) { + return false; + } + if (rename != NULL) { + *rename = xh_val(e, pic_sym); + } + return true; +} + +static void +define_macro(pic_state *pic, pic_sym rename, struct pic_proc *proc, struct pic_senv *senv) +{ + struct pic_macro *mac; + + mac = (struct pic_macro *)pic_obj_alloc(pic, sizeof(struct pic_macro), PIC_TT_MACRO); + mac->senv = senv; + mac->proc = proc; + + xh_put_int(&pic->macros, rename, &mac); +} + +static struct pic_macro * +find_macro(pic_state *pic, pic_sym rename) +{ + xh_entry *e; + + if ((e = xh_get_int(&pic->macros, rename)) == NULL) { + return NULL; + } + return xh_val(e, struct pic_macro *); +} + +static pic_sym +make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv) +{ + pic_sym rename; + + while (true) { + if (pic_find_rename(pic, senv, sym, &rename)) { + return rename; + } + if (! senv->up) + break; + senv = senv->up; + } + if (! pic_interned_p(pic, sym)) { + return sym; + } + else { + return pic_gensym(pic, sym); + } +} + +static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *); +static pic_value macroexpand_lambda(pic_state *, pic_value, struct pic_senv *); + +static pic_value +macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv) +{ + return pic_sym_value(make_identifier(pic, sym, senv)); +} + +static pic_value +macroexpand_quote(pic_state *pic, pic_value expr) +{ + return pic_cons(pic, pic_sym_value(pic->rQUOTE), pic_cdr(pic, expr)); +} + +static pic_value +macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value x, head, tail; + + if (pic_pair_p(obj)) { + head = macroexpand(pic, pic_car(pic, obj), senv); + tail = macroexpand_list(pic, pic_cdr(pic, obj), senv); + x = pic_cons(pic, head, tail); + } else { + x = macroexpand(pic, obj, senv); + } + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, x); + return x; +} + +static pic_value +macroexpand_defer(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + pic_value skel = pic_list1(pic, pic_none_value()); /* (#) */ + + pic_push(pic, pic_cons(pic, expr, skel), senv->defer); + + return skel; +} + +static void +macroexpand_deferred(pic_state *pic, struct pic_senv *senv) +{ + pic_value defer, val, src, dst; + + pic_for_each (defer, pic_reverse(pic, senv->defer)) { + src = pic_car(pic, defer); + dst = pic_cdr(pic, defer); + + val = macroexpand_lambda(pic, src, senv); + + /* copy */ + pic_pair_ptr(dst)->car = pic_car(pic, val); + pic_pair_ptr(dst)->cdr = pic_cdr(pic, val); + } + + senv->defer = pic_nil_value(); +} + +static pic_value +macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + pic_value formal, body; + struct pic_senv *in; + pic_value a; + + if (pic_length(pic, expr) < 2) { + pic_errorf(pic, "syntax error"); + } + + in = pic_make_senv(pic, senv); + + for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) { + pic_value v = pic_car(pic, a); + + if (! pic_sym_p(v)) { + pic_errorf(pic, "syntax error"); + } + pic_add_rename(pic, in, pic_sym(v)); + } + if (pic_sym_p(a)) { + pic_add_rename(pic, in, pic_sym(a)); + } + else if (! pic_nil_p(a)) { + pic_errorf(pic, "syntax error"); + } + + formal = macroexpand_list(pic, pic_cadr(pic, expr), in); + body = macroexpand_list(pic, pic_cddr(pic, expr), in); + + macroexpand_deferred(pic, in); + + return pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, formal, body)); +} + +static pic_value +macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + pic_sym sym, rename; + pic_value var, val; + + while (pic_length(pic, expr) >= 2 && pic_pair_p(pic_cadr(pic, expr))) { + var = pic_car(pic, pic_cadr(pic, expr)); + val = pic_cdr(pic, pic_cadr(pic, expr)); + + expr = pic_list3(pic, pic_sym_value(pic->rDEFINE), var, pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr)))); + } + + if (pic_length(pic, expr) != 3) { + pic_errorf(pic, "syntax error"); + } + + var = pic_cadr(pic, expr); + if (! pic_sym_p(var)) { + pic_errorf(pic, "binding to non-symbol object"); + } + sym = pic_sym(var); + if (! pic_find_rename(pic, senv, sym, &rename)) { + rename = pic_add_rename(pic, senv, sym); + } + val = macroexpand(pic, pic_list_ref(pic, expr, 2), senv); + + return pic_list3(pic, pic_sym_value(pic->rDEFINE), pic_sym_value(rename), val); +} + +static pic_value +macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + pic_value var, val; + pic_sym sym, rename; + + if (pic_length(pic, expr) != 3) { + pic_errorf(pic, "syntax error"); + } + + var = pic_cadr(pic, expr); + if (! pic_sym_p(var)) { + pic_errorf(pic, "binding to non-symbol object"); + } + sym = pic_sym(var); + if (! pic_find_rename(pic, senv, sym, &rename)) { + rename = pic_add_rename(pic, senv, sym); + } else { + pic_warnf(pic, "redefining syntax variable: ~s", pic_sym_value(sym)); + } + + val = pic_cadr(pic, pic_cdr(pic, expr)); + + pic_try { + val = pic_eval(pic, val, pic->lib); + } pic_catch { + pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic)); + } + + if (! pic_proc_p(val)) { + pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); + } + + define_macro(pic, rename, pic_proc_ptr(val), senv); + + return pic_none_value(); +} + +static pic_value +macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv) +{ + pic_value v, args; + +#if DEBUG + puts("before expand-1:"); + pic_debug(pic, expr); + puts(""); +#endif + + if (mac->senv == NULL) { /* legacy macro */ + args = pic_cdr(pic, expr); + } else { + args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv)); + } + + pic_try { + v = pic_apply(pic, mac->proc, args); + } pic_catch { + pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic)); + } + +#if DEBUG + puts("after expand-1:"); + pic_debug(pic, v); + puts(""); +#endif + + return v; +} + +static pic_value +macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + switch (pic_type(expr)) { + case PIC_TT_SYMBOL: { + return macroexpand_symbol(pic, pic_sym(expr), senv); + } + case PIC_TT_PAIR: { + pic_value car; + struct pic_macro *mac; + + if (! pic_list_p(expr)) { + pic_errorf(pic, "cannot macroexpand improper list: ~s", expr); + } + + car = macroexpand(pic, pic_car(pic, expr), senv); + if (pic_sym_p(car)) { + pic_sym tag = pic_sym(car); + + if (tag == pic->rDEFINE_SYNTAX) { + return macroexpand_defsyntax(pic, expr, senv); + } + else if (tag == pic->rLAMBDA) { + return macroexpand_defer(pic, expr, senv); + } + else if (tag == pic->rDEFINE) { + return macroexpand_define(pic, expr, senv); + } + else if (tag == pic->rQUOTE) { + return macroexpand_quote(pic, expr); + } + + if ((mac = find_macro(pic, tag)) != NULL) { + return macroexpand_node(pic, macroexpand_macro(pic, mac, expr, senv), senv); + } + } + + return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv)); + } + default: + return expr; + } +} + +static pic_value +macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value v; + +#if DEBUG + printf("[macroexpand] expanding... "); + pic_debug(pic, expr); + puts(""); +#endif + + v = macroexpand_node(pic, expr, senv); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, v); + return v; +} + +pic_value +pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib) +{ + struct pic_lib *prev; + pic_value v; + +#if DEBUG + puts("before expand:"); + pic_debug(pic, expr); + puts(""); +#endif + + /* change library for macro-expansion time processing */ + prev = pic->lib; + pic->lib = lib; + + lib->env->defer = pic_nil_value(); /* the last expansion could fail and leave defer field old */ + + v = macroexpand(pic, expr, lib->env); + + macroexpand_deferred(pic, lib->env); + + pic->lib = prev; + +#if DEBUG + puts("after expand:"); + pic_debug(pic, v); + puts(""); +#endif + + return v; +} + +struct pic_senv * +pic_make_senv(pic_state *pic, struct pic_senv *up) +{ + struct pic_senv *senv; + + senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); + senv->up = up; + senv->defer = pic_nil_value(); + xh_init_int(&senv->map, sizeof(pic_sym)); + + return senv; +} + +struct pic_senv * +pic_null_syntactic_environment(pic_state *pic) +{ + struct pic_senv *senv; + + senv = pic_make_senv(pic, NULL); + + pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY); + pic_define_syntactic_keyword(pic, senv, pic->sIMPORT, pic->rIMPORT); + pic_define_syntactic_keyword(pic, senv, pic->sEXPORT, pic->rEXPORT); + pic_define_syntactic_keyword(pic, senv, pic->sIN_LIBRARY, pic->rIN_LIBRARY); + pic_define_syntactic_keyword(pic, senv, pic->sCOND_EXPAND, pic->rCOND_EXPAND); + + return senv; +} + +void +pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rsym) +{ + pic_put_rename(pic, senv, sym, rsym); + + if (pic->lib && pic->lib->env == senv) { + pic_export(pic, sym); + } +} + +void +pic_defmacro(pic_state *pic, pic_sym name, pic_sym id, pic_func_t func) +{ + pic_put_rename(pic, pic->lib->env, name, id); + + /* symbol registration */ + define_macro(pic, id, pic_make_proc(pic, func, pic_symbol_name(pic, name)), NULL); + + /* auto export! */ + pic_export(pic, name); +} + +bool +pic_identifier_p(pic_state *pic, pic_value obj) +{ + return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym(obj)); +} + +bool +pic_identifier_eq_p(pic_state *pic, struct pic_senv *env1, pic_sym sym1, struct pic_senv *env2, pic_sym sym2) +{ + pic_sym a, b; + + a = make_identifier(pic, sym1, env1); + if (a != make_identifier(pic, sym1, env1)) { + a = sym1; + } + + b = make_identifier(pic, sym2, env2); + if (b != make_identifier(pic, sym2, env2)) { + b = sym2; + } + + return pic_eq_p(pic_sym_value(a), pic_sym_value(b)); +} + +static pic_value +pic_macro_identifier_p(pic_state *pic) +{ + pic_value obj; + + pic_get_args(pic, "o", &obj); + + return pic_bool_value(pic_identifier_p(pic, obj)); +} + +static pic_value +pic_macro_make_identifier(pic_state *pic) +{ + pic_value obj; + pic_sym sym; + + pic_get_args(pic, "mo", &sym, &obj); + + pic_assert_type(pic, obj, senv); + + return pic_sym_value(make_identifier(pic, sym, pic_senv_ptr(obj))); +} + +static pic_value +pic_macro_identifier_eq_p(pic_state *pic) +{ + pic_sym sym1, sym2; + pic_value env1, env2; + + pic_get_args(pic, "omom", &env1, &sym1, &env2, &sym2); + + pic_assert_type(pic, env1, senv); + pic_assert_type(pic, env2, senv); + + return pic_bool_value(pic_identifier_eq_p(pic, pic_senv_ptr(env1), sym1, pic_senv_ptr(env2), sym2)); +} + +void +pic_init_macro(pic_state *pic) +{ + pic_defun(pic, "identifier?", pic_macro_identifier_p); + pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p); + pic_defun(pic, "make-identifier", pic_macro_make_identifier); +} diff --git a/extlib/benz/number.c b/extlib/benz/number.c new file mode 100644 index 00000000..be819bbd --- /dev/null +++ b/extlib/benz/number.c @@ -0,0 +1,647 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include +#include +#include + +#include "picrin.h" +#include "picrin/string.h" +#include "picrin/cont.h" + +/** + * Returns the length of string representing val. + * radix is between 2 and 36 (inclusive). + * No error checks are performed in this function. + */ +static int +number_string_length(int val, int radix) +{ + long long v = val; /* in case val == INT_MIN */ + int count = 0; + if (val == 0) { + return 1; + } + if (val < 0) { + v = - v; + count = 1; + } + while (v > 0) { + ++count; + v /= radix; + } + return count; +} + +/** + * Returns the string representing val. + * radix is between 2 and 36 (inclusive). + * This function overwrites buffer and stores the result. + * No error checks are performed in this function. It is caller's responsibility to avoid buffer-overrun. + */ +static void +number_string(int val, int radix, int length, char *buffer) { + const char digits[37] = "0123456789abcdefghijklmnopqrstuvwxyz"; + long long v = val; + int i; + if (val == 0) { + buffer[0] = '0'; + buffer[1] = '\0'; + return; + } + if (val < 0) { + buffer[0] = '-'; + v = -v; + } + + for(i = length - 1; v > 0; --i) { + buffer[i] = digits[v % radix]; + v /= radix; + } + buffer[length] = '\0'; + return; +} + +static pic_value +pic_number_real_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_float_p(v) || pic_int_p(v)); +} + +static pic_value +pic_number_integer_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_int_p(v)) { + return pic_true_value(); + } + if (pic_float_p(v)) { + double f = pic_float(v); + + if (isinf(f)) { + return pic_false_value(); + } + + if (f == round(f)) { + return pic_true_value(); + } + } + return pic_false_value(); +} + +static pic_value +pic_number_exact_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_int_p(v)); +} + +static pic_value +pic_number_inexact_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_float_p(v)); +} + +static pic_value +pic_number_finite_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_int_p(v)) + return pic_true_value(); + if (pic_float_p(v) && ! (isinf(pic_float(v)) || isnan(pic_float(v)))) + return pic_true_value(); + else + return pic_false_value(); +} + +static pic_value +pic_number_infinite_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_float_p(v) && isinf(pic_float(v))) + return pic_true_value(); + else + return pic_false_value(); +} + +static pic_value +pic_number_nan_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_float_p(v) && isnan(pic_float(v))) + return pic_true_value(); + else + return pic_false_value(); +} + +#define DEFINE_ARITH_CMP(op, name) \ + static pic_value \ + pic_number_##name(pic_state *pic) \ + { \ + size_t argc, i; \ + pic_value *argv; \ + double f,g; \ + \ + pic_get_args(pic, "ff*", &f, &g, &argc, &argv); \ + \ + if (! (f op g)) \ + return pic_false_value(); \ + \ + for (i = 0; i < argc; ++i) { \ + f = g; \ + if (pic_float_p(argv[i])) \ + g = pic_float(argv[i]); \ + else if (pic_int_p(argv[i])) \ + g = pic_int(argv[i]); \ + else \ + pic_errorf(pic, #op ": number required"); \ + \ + if (! (f op g)) \ + return pic_false_value(); \ + } \ + \ + return pic_true_value(); \ + } + +DEFINE_ARITH_CMP(==, eq) +DEFINE_ARITH_CMP(<, lt) +DEFINE_ARITH_CMP(>, gt) +DEFINE_ARITH_CMP(<=, le) +DEFINE_ARITH_CMP(>=, ge) + +#define DEFINE_ARITH_OP(op, name, unit) \ + static pic_value \ + pic_number_##name(pic_state *pic) \ + { \ + size_t argc, i; \ + pic_value *argv; \ + double f; \ + bool e = true; \ + \ + pic_get_args(pic, "*", &argc, &argv); \ + \ + f = unit; \ + for (i = 0; i < argc; ++i) { \ + if (pic_int_p(argv[i])) { \ + f op##= pic_int(argv[i]); \ + } \ + else if (pic_float_p(argv[i])) { \ + e = false; \ + f op##= pic_float(argv[i]); \ + } \ + else { \ + pic_errorf(pic, #op ": number required"); \ + } \ + } \ + \ + return e ? pic_int_value((int)f) : pic_float_value(f); \ + } + +DEFINE_ARITH_OP(+, add, 0) +DEFINE_ARITH_OP(*, mul, 1) + +#define DEFINE_ARITH_INV_OP(op, name, unit, exact) \ + static pic_value \ + pic_number_##name(pic_state *pic) \ + { \ + size_t argc, i; \ + pic_value *argv; \ + double f; \ + bool e; \ + \ + pic_get_args(pic, "F*", &f, &e, &argc, &argv); \ + \ + e = e && exact; \ + \ + if (argc == 0) { \ + f = unit op f; \ + } \ + for (i = 0; i < argc; ++i) { \ + if (pic_int_p(argv[i])) { \ + f op##= pic_int(argv[i]); \ + } \ + else if (pic_float_p(argv[i])) { \ + e = false; \ + f op##= pic_float(argv[i]); \ + } \ + else { \ + pic_errorf(pic, #op ": number required"); \ + } \ + } \ + \ + return e ? pic_int_value((int)f) : pic_float_value(f); \ + } + +DEFINE_ARITH_INV_OP(-, sub, 0, true) +DEFINE_ARITH_INV_OP(/, div, 1, false) + +static pic_value +pic_number_abs(pic_state *pic) +{ + double f; + bool e; + + pic_get_args(pic, "F", &f, &e); + + if (e) { + return pic_int_value(abs((int)f)); + } + else { + return pic_float_value(fabs(f)); + } +} + +static pic_value +pic_number_floor2(pic_state *pic) +{ + int i, j; + bool e1, e2; + + pic_get_args(pic, "II", &i, &e1, &j, &e2); + + if (e1 && e2) { + int k; + + k = (i < 0 && j < 0) || (0 <= i && 0 <= j) + ? i / j + : (i / j) - 1; + + return pic_values2(pic, pic_int_value(k), pic_int_value(i - k * j)); + } + else { + double q, r; + + q = floor((double)i/j); + r = i - j * q; + return pic_values2(pic, pic_float_value(q), pic_float_value(r)); + } +} + +static pic_value +pic_number_trunc2(pic_state *pic) +{ + int i, j; + bool e1, e2; + + pic_get_args(pic, "II", &i, &e1, &j, &e2); + + if (e1 && e2) { + return pic_values2(pic, pic_int_value(i/j), pic_int_value(i - (i/j) * j)); + } + else { + double q, r; + + q = trunc((double)i/j); + r = i - j * q; + + return pic_values2(pic, pic_float_value(q), pic_float_value(r)); + } +} + +static pic_value +pic_number_floor(pic_state *pic) +{ + double f; + bool e; + + pic_get_args(pic, "F", &f, &e); + + if (e) { + return pic_int_value((int)f); + } + else { + return pic_float_value(floor(f)); + } +} + +static pic_value +pic_number_ceil(pic_state *pic) +{ + double f; + bool e; + + pic_get_args(pic, "F", &f, &e); + + if (e) { + return pic_int_value((int)f); + } + else { + return pic_float_value(ceil(f)); + } +} + +static pic_value +pic_number_trunc(pic_state *pic) +{ + double f; + bool e; + + pic_get_args(pic, "F", &f, &e); + + if (e) { + return pic_int_value((int)f); + } + else { + return pic_float_value(trunc(f)); + } +} + +static pic_value +pic_number_round(pic_state *pic) +{ + double f; + bool e; + + pic_get_args(pic, "F", &f, &e); + + if (e) { + return pic_int_value((int)f); + } + else { + return pic_float_value(round(f)); + } +} + +static pic_value +pic_number_exp(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + return pic_float_value(exp(f)); +} + +static pic_value +pic_number_log(pic_state *pic) +{ + double f,g; + int argc; + + argc = pic_get_args(pic, "f|f", &f, &g); + if (argc == 1) { + return pic_float_value(log(f)); + } + else { + return pic_float_value(log(f) / log(g)); + } +} + +static pic_value +pic_number_sin(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + f = sin(f); + return pic_float_value(f); +} + +static pic_value +pic_number_cos(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + f = cos(f); + return pic_float_value(f); +} + +static pic_value +pic_number_tan(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + f = tan(f); + return pic_float_value(f); +} + +static pic_value +pic_number_acos(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + f = acos(f); + return pic_float_value(f); +} + +static pic_value +pic_number_asin(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + f = asin(f); + return pic_float_value(f); +} + +static pic_value +pic_number_atan(pic_state *pic) +{ + double f,g; + int argc; + + argc = pic_get_args(pic, "f|f", &f, &g); + if (argc == 1) { + f = atan(f); + return pic_float_value(f); + } + else { + return pic_float_value(atan2(f,g)); + } +} + +static pic_value +pic_number_sqrt(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + + return pic_float_value(sqrt(f)); +} + +static pic_value +pic_number_expt(pic_state *pic) +{ + double f, g, h; + bool e1, e2; + + pic_get_args(pic, "FF", &f, &e1, &g, &e2); + + h = pow(f, g); + if (e1 && e2) { + if (h <= INT_MAX) { + return pic_int_value((int)h); + } + } + return pic_float_value(h); +} + +static pic_value +pic_number_inexact(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + + return pic_float_value(f); +} + +static pic_value +pic_number_exact(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + + return pic_int_value((int)(round(f))); +} + +static pic_value +pic_number_number_to_string(pic_state *pic) +{ + double f; + bool e; + int radix = 10; + + pic_get_args(pic, "F|i", &f, &e, &radix); + + if (radix < 2 || radix > 36) { + pic_errorf(pic, "number->string: invalid radix %d (between 2 and 36, inclusive)", radix); + } + + if (e) { + int ival = (int) f; + int ilen = number_string_length(ival, radix); + char buf[ilen + 1]; + + number_string(ival, radix, ilen, buf); + + return pic_obj_value(pic_make_str(pic, buf, sizeof buf - 1)); + } + else { + char buf[snprintf(NULL, 0, "%f", f) + 1]; + + snprintf(buf, sizeof buf, "%f", f); + + return pic_obj_value(pic_make_str(pic, buf, sizeof buf - 1)); + } +} + +static pic_value +pic_number_string_to_number(pic_state *pic) +{ + const char *str; + int radix = 10; + long num; + char *eptr; + double flo; + + pic_get_args(pic, "z|i", &str, &radix); + + num = strtol(str, &eptr, radix); + if (*eptr == '\0') { + return pic_valid_int(num) + ? pic_int_value((int)num) + : pic_float_value(num); + } + + flo = strtod(str, &eptr); + if (*eptr == '\0') { + return pic_float_value(flo); + } + + pic_errorf(pic, "invalid string given: %s", str); +} + +void +pic_init_number(pic_state *pic) +{ + size_t ai = pic_gc_arena_preserve(pic); + + pic_defun(pic, "number?", pic_number_real_p); + pic_defun(pic, "complex?", pic_number_real_p); + pic_defun(pic, "real?", pic_number_real_p); + pic_defun(pic, "rational?", pic_number_real_p); + pic_defun(pic, "integer?", pic_number_integer_p); + pic_gc_arena_restore(pic, ai); + + pic_defun(pic, "exact?", pic_number_exact_p); + pic_defun(pic, "inexact?", pic_number_inexact_p); + pic_gc_arena_restore(pic, ai); + + pic_defun(pic, "=", pic_number_eq); + pic_defun(pic, "<", pic_number_lt); + pic_defun(pic, ">", pic_number_gt); + pic_defun(pic, "<=", pic_number_le); + pic_defun(pic, ">=", pic_number_ge); + pic_gc_arena_restore(pic, ai); + + pic_defun(pic, "+", pic_number_add); + pic_defun(pic, "-", pic_number_sub); + pic_defun(pic, "*", pic_number_mul); + pic_defun(pic, "/", pic_number_div); + pic_gc_arena_restore(pic, ai); + + pic_defun(pic, "floor/", pic_number_floor2); + pic_defun(pic, "truncate/", pic_number_trunc2); + pic_gc_arena_restore(pic, ai); + + pic_defun(pic, "floor", pic_number_floor); + pic_defun(pic, "ceiling", pic_number_ceil); + pic_defun(pic, "truncate", pic_number_trunc); + pic_defun(pic, "round", pic_number_round); + pic_gc_arena_restore(pic, ai); + + pic_defun(pic, "inexact", pic_number_inexact); + pic_defun(pic, "exact", pic_number_exact); + pic_gc_arena_restore(pic, ai); + + pic_defun(pic, "finite?", pic_number_finite_p); + pic_defun(pic, "infinite?", pic_number_infinite_p); + pic_defun(pic, "nan?", pic_number_nan_p); + pic_gc_arena_restore(pic, ai); + + pic_defun(pic, "abs", pic_number_abs); + pic_defun(pic, "sqrt", pic_number_sqrt); + pic_defun(pic, "expt", pic_number_expt); + pic_defun(pic, "exp", pic_number_exp); + pic_defun(pic, "log", pic_number_log); + pic_defun(pic, "sin", pic_number_sin); + pic_defun(pic, "cos", pic_number_cos); + pic_defun(pic, "tan", pic_number_tan); + pic_defun(pic, "acos", pic_number_acos); + pic_defun(pic, "asin", pic_number_asin); + pic_defun(pic, "atan", pic_number_atan); + pic_gc_arena_restore(pic, ai); + + pic_defun(pic, "number->string", pic_number_number_to_string); + pic_defun(pic, "string->number", pic_number_string_to_number); + pic_gc_arena_restore(pic, ai); +} diff --git a/extlib/benz/pair.c b/extlib/benz/pair.c new file mode 100644 index 00000000..b662534a --- /dev/null +++ b/extlib/benz/pair.c @@ -0,0 +1,792 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#include "picrin.h" +#include "picrin/pair.h" + +pic_value +pic_cons(pic_state *pic, pic_value car, pic_value cdr) +{ + struct pic_pair *pair; + + pair = (struct pic_pair *)pic_obj_alloc(pic, sizeof(struct pic_pair), PIC_TT_PAIR); + pair->car = car; + pair->cdr = cdr; + + return pic_obj_value(pair); +} + +void +pic_set_car(pic_state *pic, pic_value obj, pic_value val) +{ + struct pic_pair *pair; + + if (! pic_pair_p(obj)) { + pic_errorf(pic, "pair required"); + } + pair = pic_pair_ptr(obj); + + pair->car = val; +} + +void +pic_set_cdr(pic_state *pic, pic_value obj, pic_value val) +{ + struct pic_pair *pair; + + if (! pic_pair_p(obj)) { + pic_errorf(pic, "pair required"); + } + pair = pic_pair_ptr(obj); + + pair->cdr = val; +} + +bool +pic_list_p(pic_value obj) +{ + pic_value local, rapid; + int i; + + /* Floyd's cycle-finding algorithm. */ + + local = rapid = obj; + while (true) { + + /* advance rapid fast-forward; runs 2x faster than local */ + for (i = 0; i < 2; ++i) { + if (pic_pair_p(rapid)) { + rapid = pic_pair_ptr(rapid)->cdr; + } + else { + return pic_nil_p(rapid); + } + } + + /* advance local */ + local = pic_pair_ptr(local)->cdr; + + if (pic_eq_p(local, rapid)) { + return false; + } + } +} + +pic_value +pic_list1(pic_state *pic, pic_value obj1) +{ + return pic_cons(pic, obj1, pic_nil_value()); +} + +pic_value +pic_list2(pic_state *pic, pic_value obj1, pic_value obj2) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value val; + + val = pic_cons(pic, obj1, pic_list1(pic, obj2)); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, val); + return val; +} + +pic_value +pic_list3(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value val; + + val = pic_cons(pic, obj1, pic_list2(pic, obj2, obj3)); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, val); + return val; +} + +pic_value +pic_list4(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value val; + + val = pic_cons(pic, obj1, pic_list3(pic, obj2, obj3, obj4)); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, val); + return val; +} + +pic_value +pic_list5(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value val; + + val = pic_cons(pic, obj1, pic_list4(pic, obj2, obj3, obj4, obj5)); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, val); + return val; +} + +pic_value +pic_list6(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value val; + + val = pic_cons(pic, obj1, pic_list5(pic, obj2, obj3, obj4, obj5, obj6)); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, val); + return val; +} + +pic_value +pic_list7(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6, pic_value obj7) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value val; + + val = pic_cons(pic, obj1, pic_list6(pic, obj2, obj3, obj4, obj5, obj6, obj7)); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, val); + return val; +} + +pic_value +pic_list_by_array(pic_state *pic, size_t c, pic_value *vs) +{ + pic_value v; + + v = pic_nil_value(); + while (c--) { + v = pic_cons(pic, vs[c], v); + } + return v; +} + +pic_value +pic_make_list(pic_state *pic, size_t k, pic_value fill) +{ + pic_value list; + size_t i; + + list = pic_nil_value(); + for (i = 0; i < k; ++i) { + list = pic_cons(pic, fill, list); + } + + return list; +} + +size_t +pic_length(pic_state *pic, pic_value obj) +{ + size_t c = 0; + + if (! pic_list_p(obj)) { + pic_errorf(pic, "length: expected list, but got ~s", obj); + } + + while (! pic_nil_p(obj)) { + obj = pic_cdr(pic, obj); + ++c; + } + + return c; +} + +pic_value +pic_reverse(pic_state *pic, pic_value list) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value v, acc; + + acc = pic_nil_value(); + pic_for_each(v, list) { + acc = pic_cons(pic, v, acc); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, acc); + } + return acc; +} + +pic_value +pic_append(pic_state *pic, pic_value xs, pic_value ys) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value x; + + xs = pic_reverse(pic, xs); + pic_for_each (x, xs) { + ys = pic_cons(pic, x, ys); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, xs); + pic_gc_protect(pic, ys); + } + return ys; +} + +pic_value +pic_memq(pic_state *pic, pic_value key, pic_value list) +{ + enter: + + if (pic_nil_p(list)) + return pic_false_value(); + + if (pic_eq_p(key, pic_car(pic, list))) + return list; + + list = pic_cdr(pic, list); + goto enter; +} + +pic_value +pic_memv(pic_state *pic, pic_value key, pic_value list) +{ + enter: + + if (pic_nil_p(list)) + return pic_false_value(); + + if (pic_eqv_p(key, pic_car(pic, list))) + return list; + + list = pic_cdr(pic, list); + goto enter; +} + +pic_value +pic_member(pic_state *pic, pic_value key, pic_value list, struct pic_proc *compar) +{ + enter: + + if (pic_nil_p(list)) + return pic_false_value(); + + if (compar == NULL) { + if (pic_equal_p(pic, key, pic_car(pic, list))) + return list; + } else { + if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, list)))) + return list; + } + + list = pic_cdr(pic, list); + goto enter; +} + +pic_value +pic_assq(pic_state *pic, pic_value key, pic_value assoc) +{ + pic_value cell; + + enter: + + if (pic_nil_p(assoc)) + return pic_false_value(); + + cell = pic_car(pic, assoc); + if (pic_eq_p(key, pic_car(pic, cell))) + return cell; + + assoc = pic_cdr(pic, assoc); + goto enter; +} + +pic_value +pic_assv(pic_state *pic, pic_value key, pic_value assoc) +{ + pic_value cell; + + enter: + + if (pic_nil_p(assoc)) + return pic_false_value(); + + cell = pic_car(pic, assoc); + if (pic_eqv_p(key, pic_car(pic, cell))) + return cell; + + assoc = pic_cdr(pic, assoc); + goto enter; +} + +pic_value +pic_assoc(pic_state *pic, pic_value key, pic_value assoc, struct pic_proc *compar) +{ + pic_value cell; + + enter: + + if (pic_nil_p(assoc)) + return pic_false_value(); + + cell = pic_car(pic, assoc); + if (compar == NULL) { + if (pic_equal_p(pic, key, pic_car(pic, cell))) + return cell; + } else { + if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, cell)))) + return cell; + } + + assoc = pic_cdr(pic, assoc); + goto enter; +} + +pic_value +pic_acons(pic_state *pic, pic_value key, pic_value val, pic_value assoc) +{ + return pic_cons(pic, pic_cons(pic, key, val), assoc); +} + +pic_value +pic_caar(pic_state *pic, pic_value v) +{ + return pic_car(pic, pic_car(pic, v)); +} + +pic_value +pic_cadr(pic_state *pic, pic_value v) +{ + return pic_car(pic, pic_cdr(pic, v)); +} + +pic_value +pic_cdar(pic_state *pic, pic_value v) +{ + return pic_cdr(pic, pic_car(pic, v)); +} + +pic_value +pic_cddr(pic_state *pic, pic_value v) +{ + return pic_cdr(pic, pic_cdr(pic, v)); +} + +pic_value +pic_list_tail(pic_state *pic, pic_value list, size_t i) +{ + while (i-- > 0) { + list = pic_cdr(pic, list); + } + return list; +} + +pic_value +pic_list_ref(pic_state *pic, pic_value list, size_t i) +{ + return pic_car(pic, pic_list_tail(pic, list, i)); +} + +void +pic_list_set(pic_state *pic, pic_value list, size_t i, pic_value obj) +{ + pic_pair_ptr(pic_list_tail(pic, list, i))->car = obj; +} + +pic_value +pic_list_copy(pic_state *pic, pic_value obj) +{ + if (pic_pair_p(obj)) { + return pic_cons(pic, pic_car(pic, obj), pic_list_copy(pic, pic_cdr(pic, obj))); + } + else { + return obj; + } +} + +static pic_value +pic_pair_pair_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_pair_p(v)); +} + +static pic_value +pic_pair_cons(pic_state *pic) +{ + pic_value v,w; + + pic_get_args(pic, "oo", &v, &w); + + return pic_cons(pic, v, w); +} + +static pic_value +pic_pair_car(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_car(pic, v); +} + +static pic_value +pic_pair_cdr(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_cdr(pic, v); +} + +static pic_value +pic_pair_caar(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_caar(pic, v); +} + +static pic_value +pic_pair_cadr(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_cadr(pic, v); +} + +static pic_value +pic_pair_cdar(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_cdar(pic, v); +} + +static pic_value +pic_pair_cddr(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_cddr(pic, v); +} + +static pic_value +pic_pair_set_car(pic_state *pic) +{ + pic_value v,w; + + pic_get_args(pic, "oo", &v, &w); + + pic_set_car(pic, v, w); + + return pic_none_value(); +} + +static pic_value +pic_pair_set_cdr(pic_state *pic) +{ + pic_value v,w; + + pic_get_args(pic, "oo", &v, &w); + + pic_set_cdr(pic, v, w); + + return pic_none_value(); +} + +static pic_value +pic_pair_null_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_nil_p(v)); +} + +static pic_value +pic_pair_list_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_list_p(v)); +} + +static pic_value +pic_pair_make_list(pic_state *pic) +{ + size_t i; + pic_value fill = pic_none_value(); + + pic_get_args(pic, "k|o", &i, &fill); + + return pic_make_list(pic, i, fill); +} + +static pic_value +pic_pair_list(pic_state *pic) +{ + size_t argc; + pic_value *argv; + + pic_get_args(pic, "*", &argc, &argv); + + return pic_list_by_array(pic, argc, argv); +} + +static pic_value +pic_pair_length(pic_state *pic) +{ + pic_value list; + + pic_get_args(pic, "o", &list); + + return pic_size_value(pic_length(pic, list)); +} + +static pic_value +pic_pair_append(pic_state *pic) +{ + size_t argc; + pic_value *args, list; + + pic_get_args(pic, "*", &argc, &args); + + if (argc == 0) { + return pic_nil_value(); + } + + list = args[--argc]; + + while (argc-- > 0) { + list = pic_append(pic, args[argc], list); + } + return list; +} + +static pic_value +pic_pair_reverse(pic_state *pic) +{ + pic_value list; + + pic_get_args(pic, "o", &list); + + return pic_reverse(pic, list); +} + +static pic_value +pic_pair_list_tail(pic_state *pic) +{ + pic_value list; + size_t i; + + pic_get_args(pic, "ok", &list, &i); + + return pic_list_tail(pic, list, i); +} + +static pic_value +pic_pair_list_ref(pic_state *pic) +{ + pic_value list; + size_t i; + + pic_get_args(pic, "ok", &list, &i); + + return pic_list_ref(pic, list, i); +} + +static pic_value +pic_pair_list_set(pic_state *pic) +{ + pic_value list, obj; + size_t i; + + pic_get_args(pic, "oko", &list, &i, &obj); + + pic_list_set(pic, list, i, obj); + + return pic_none_value(); +} + +static pic_value +pic_pair_list_copy(pic_state *pic) +{ + pic_value obj; + + pic_get_args(pic, "o", &obj); + + return pic_list_copy(pic, obj); +} + +static pic_value +pic_pair_map(pic_state *pic) +{ + struct pic_proc *proc; + size_t argc, i; + pic_value *args; + pic_value arg, ret; + + pic_get_args(pic, "l*", &proc, &argc, &args); + + ret = pic_nil_value(); + do { + arg = pic_nil_value(); + for (i = 0; i < argc; ++i) { + if (! pic_pair_p(args[i])) { + break; + } + pic_push(pic, pic_car(pic, args[i]), arg); + args[i] = pic_cdr(pic, args[i]); + } + if (i != argc) { + break; + } + pic_push(pic, pic_apply(pic, proc, pic_reverse(pic, arg)), ret); + } while (1); + + return pic_reverse(pic, ret); +} + +static pic_value +pic_pair_for_each(pic_state *pic) +{ + struct pic_proc *proc; + size_t argc, i; + pic_value *args; + pic_value arg; + + pic_get_args(pic, "l*", &proc, &argc, &args); + + do { + arg = pic_nil_value(); + for (i = 0; i < argc; ++i) { + if (! pic_pair_p(args[i])) { + break; + } + pic_push(pic, pic_car(pic, args[i]), arg); + args[i] = pic_cdr(pic, args[i]); + } + if (i != argc) { + break; + } + pic_apply(pic, proc, pic_reverse(pic, arg)); + } while (1); + + return pic_none_value(); +} + +static pic_value +pic_pair_memq(pic_state *pic) +{ + pic_value key, list; + + pic_get_args(pic, "oo", &key, &list); + + return pic_memq(pic, key, list); +} + +static pic_value +pic_pair_memv(pic_state *pic) +{ + pic_value key, list; + + pic_get_args(pic, "oo", &key, &list); + + return pic_memv(pic, key, list); +} + +static pic_value +pic_pair_member(pic_state *pic) +{ + struct pic_proc *proc = NULL; + pic_value key, list; + + pic_get_args(pic, "oo|l", &key, &list, &proc); + + return pic_member(pic, key, list, proc); +} + +static pic_value +pic_pair_assq(pic_state *pic) +{ + pic_value key, list; + + pic_get_args(pic, "oo", &key, &list); + + return pic_assq(pic, key, list); +} + +static pic_value +pic_pair_assv(pic_state *pic) +{ + pic_value key, list; + + pic_get_args(pic, "oo", &key, &list); + + return pic_assv(pic, key, list); +} + +static pic_value +pic_pair_assoc(pic_state *pic) +{ + struct pic_proc *proc = NULL; + pic_value key, list; + + pic_get_args(pic, "oo|l", &key, &list, &proc); + + return pic_assoc(pic, key, list, proc); +} + +void +pic_init_pair(pic_state *pic) +{ + pic_defun(pic, "pair?", pic_pair_pair_p); + pic_defun(pic, "cons", pic_pair_cons); + pic_defun(pic, "car", pic_pair_car); + pic_defun(pic, "cdr", pic_pair_cdr); + pic_defun(pic, "set-car!", pic_pair_set_car); + pic_defun(pic, "set-cdr!", pic_pair_set_cdr); + pic_defun(pic, "null?", pic_pair_null_p); + + pic_defun(pic, "caar", pic_pair_caar); + pic_defun(pic, "cadr", pic_pair_cadr); + pic_defun(pic, "cdar", pic_pair_cdar); + pic_defun(pic, "cddr", pic_pair_cddr); + pic_defun(pic, "list?", pic_pair_list_p); + pic_defun(pic, "make-list", pic_pair_make_list); + pic_defun(pic, "list", pic_pair_list); + pic_defun(pic, "length", pic_pair_length); + pic_defun(pic, "append", pic_pair_append); + pic_defun(pic, "reverse", pic_pair_reverse); + pic_defun(pic, "list-tail", pic_pair_list_tail); + pic_defun(pic, "list-ref", pic_pair_list_ref); + pic_defun(pic, "list-set!", pic_pair_list_set); + pic_defun(pic, "list-copy", pic_pair_list_copy); + pic_defun(pic, "map", pic_pair_map); + pic_defun(pic, "for-each", pic_pair_for_each); + pic_defun(pic, "memq", pic_pair_memq); + pic_defun(pic, "memv", pic_pair_memv); + pic_defun(pic, "member", pic_pair_member); + pic_defun(pic, "assq", pic_pair_assq); + pic_defun(pic, "assv", pic_pair_assv); + pic_defun(pic, "assoc", pic_pair_assoc); +} diff --git a/extlib/benz/port.c b/extlib/benz/port.c new file mode 100644 index 00000000..ec61d984 --- /dev/null +++ b/extlib/benz/port.c @@ -0,0 +1,735 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include +#include +#include + +#include "picrin.h" +#include "picrin/proc.h" +#include "picrin/port.h" +#include "picrin/string.h" +#include "picrin/blob.h" + +pic_value +pic_eof_object() +{ + pic_value v; + + pic_init_value(v, PIC_VTYPE_EOF); + + return v; +} + +struct pic_port * +pic_stdin(pic_state *pic) +{ + pic_value obj; + + obj = pic_funcall(pic, pic->PICRIN_BASE, "current-input-port", pic_nil_value()); + + return pic_port_ptr(obj); +} + +struct pic_port * +pic_stdout(pic_state *pic) +{ + pic_value obj; + + obj = pic_funcall(pic, pic->PICRIN_BASE, "current-output-port", pic_nil_value()); + + return pic_port_ptr(obj); +} + +struct pic_port * +pic_make_standard_port(pic_state *pic, xFILE *file, short dir) +{ + struct pic_port *port; + + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); + port->file = file; + port->flags = dir | PIC_PORT_TEXT; + port->status = PIC_PORT_OPEN; + return port; +} + +struct pic_port * +pic_open_input_string(pic_state *pic, const char *str) +{ + struct pic_port *port; + + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); + port->file = xmopen(); + port->flags = PIC_PORT_IN | PIC_PORT_TEXT; + port->status = PIC_PORT_OPEN; + + xfputs(str, port->file); + xfflush(port->file); + xrewind(port->file); + + return port; +} + +struct pic_port * +pic_open_output_string(pic_state *pic) +{ + struct pic_port *port; + + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); + port->file = xmopen(); + port->flags = PIC_PORT_OUT | PIC_PORT_TEXT; + port->status = PIC_PORT_OPEN; + + return port; +} + +struct pic_string * +pic_get_output_string(pic_state *pic, struct pic_port *port) +{ + size_t size; + char *buf; + + /* get endpos */ + xfflush(port->file); + size = (size_t)xftell(port->file); + xrewind(port->file); + + /* copy to buf */ + buf = (char *)pic_alloc(pic, size + 1); + buf[size] = 0; + xfread(buf, size, 1, port->file); + + return pic_make_str(pic, buf, size); +} + +void +pic_close_port(pic_state *pic, struct pic_port *port) +{ + if (xfclose(port->file) == EOF) { + pic_errorf(pic, "close-port: failure"); + } + port->status = PIC_PORT_CLOSE; +} + +static pic_value +pic_port_call_with_port(pic_state *pic) +{ + struct pic_port *port; + struct pic_proc *proc; + pic_value value; + + pic_get_args(pic, "pl", &port, &proc); + + value = pic_apply1(pic, proc, pic_obj_value(port)); + + pic_close_port(pic, port); + + return value; +} + +static pic_value +pic_port_input_port_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_IN) != 0) { + return pic_true_value(); + } + else { + return pic_false_value(); + } +} + +static pic_value +pic_port_output_port_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_OUT) != 0) { + return pic_true_value(); + } + else { + return pic_false_value(); + } +} + +static pic_value +pic_port_textual_port_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_TEXT) != 0) { + return pic_true_value(); + } + else { + return pic_false_value(); + } +} + +static pic_value +pic_port_binary_port_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_BINARY) != 0) { + return pic_true_value(); + } + else { + return pic_false_value(); + } +} + +static pic_value +pic_port_port_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_port_p(v)); +} + +static pic_value +pic_port_eof_object_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_vtype(v) == PIC_VTYPE_EOF) { + return pic_true_value(); + } + else { + return pic_false_value(); + } +} + +static pic_value +pic_port_eof_object(pic_state *pic) +{ + pic_get_args(pic, ""); + + return pic_eof_object(); +} + +static pic_value +pic_port_port_open_p(pic_state *pic) +{ + struct pic_port *port; + + pic_get_args(pic, "p", &port); + + return pic_bool_value(port->status == PIC_PORT_OPEN); +} + +static pic_value +pic_port_close_port(pic_state *pic) +{ + struct pic_port *port; + + pic_get_args(pic, "p", &port); + + pic_close_port(pic, port); + + return pic_none_value(); +} + +#define assert_port_profile(port, flgs, stat, caller) do { \ + if ((port->flags & (flgs)) != (flgs)) { \ + switch (flgs) { \ + case PIC_PORT_IN: \ + pic_errorf(pic, caller ": expected output port"); \ + case PIC_PORT_OUT: \ + pic_errorf(pic, caller ": expected input port"); \ + case PIC_PORT_IN | PIC_PORT_TEXT: \ + pic_errorf(pic, caller ": expected input/textual port"); \ + case PIC_PORT_IN | PIC_PORT_BINARY: \ + pic_errorf(pic, caller ": expected input/binary port"); \ + case PIC_PORT_OUT | PIC_PORT_TEXT: \ + pic_errorf(pic, caller ": expected output/textual port"); \ + case PIC_PORT_OUT | PIC_PORT_BINARY: \ + pic_errorf(pic, caller ": expected output/binary port"); \ + } \ + } \ + if (port->status != stat) { \ + switch (stat) { \ + case PIC_PORT_OPEN: \ + pic_errorf(pic, caller ": expected open port"); \ + case PIC_PORT_CLOSE: \ + pic_errorf(pic, caller ": expected close port"); \ + } \ + } \ + } while (0) + +static pic_value +pic_port_open_input_string(pic_state *pic) +{ + struct pic_port *port; + char *str; + + pic_get_args(pic, "z", &str); + + port = pic_open_input_string(pic, str); + + return pic_obj_value(port); +} + +static pic_value +pic_port_open_output_string(pic_state *pic) +{ + struct pic_port *port; + + pic_get_args(pic, ""); + + port = pic_open_output_string(pic); + + return pic_obj_value(port); +} + +static pic_value +pic_port_get_output_string(pic_state *pic) +{ + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "get-output-string"); + + return pic_obj_value(pic_get_output_string(pic, port)); +} + +static pic_value +pic_port_open_input_blob(pic_state *pic) +{ + struct pic_port *port; + struct pic_blob *blob; + + pic_get_args(pic, "b", &blob); + + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); + port->file = xmopen(); + port->flags = PIC_PORT_IN | PIC_PORT_BINARY; + port->status = PIC_PORT_OPEN; + + xfwrite(blob->data, 1, blob->len, port->file); + xfflush(port->file); + xrewind(port->file); + + return pic_obj_value(port); +} + +static pic_value +pic_port_open_output_bytevector(pic_state *pic) +{ + struct pic_port *port; + + pic_get_args(pic, ""); + + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); + port->file = xmopen(); + port->flags = PIC_PORT_OUT | PIC_PORT_BINARY; + port->status = PIC_PORT_OPEN; + + return pic_obj_value(port); +} + +static pic_value +pic_port_get_output_bytevector(pic_state *pic) +{ + struct pic_port *port = pic_stdout(pic); + pic_blob *blob; + size_t size; + + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "get-output-bytevector"); + + /* get endpos */ + xfflush(port->file); + size = (size_t)xftell(port->file); + xrewind(port->file); + + /* copy to buf */ + blob = pic_make_blob(pic, size); + xfread(blob->data, 1, size, port->file); + + return pic_obj_value(blob); +} + +static pic_value +pic_port_read_char(pic_state *pic) +{ + int c; + struct pic_port *port = pic_stdin(pic); + + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-char"); + + if ((c = xfgetc(port->file)) == EOF) { + return pic_eof_object(); + } + else { + return pic_char_value((char)c); + } +} + +static pic_value +pic_port_peek_char(pic_state *pic) +{ + int c; + struct pic_port *port = pic_stdin(pic); + + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "peek-char"); + + if ((c = xfgetc(port->file)) == EOF) { + return pic_eof_object(); + } + else { + xungetc(c, port->file); + return pic_char_value((char)c); + } +} + +static pic_value +pic_port_read_line(pic_state *pic) +{ + int c; + struct pic_port *port = pic_stdin(pic), *buf; + struct pic_string *str; + + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-line"); + + buf = pic_open_output_string(pic); + while ((c = xfgetc(port->file)) != EOF && c != '\n') { + xfputc(c, buf->file); + } + + str = pic_get_output_string(pic, buf); + if (pic_strlen(str) == 0 && c == EOF) { + return pic_eof_object(); + } + else { + return pic_obj_value(str); + } +} + +static pic_value +pic_port_char_ready_p(pic_state *pic) +{ + struct pic_port *port = pic_stdin(pic); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "char-ready?"); + + pic_get_args(pic, "|p", &port); + + return pic_true_value(); /* FIXME: always returns #t */ +} + +static pic_value +pic_port_read_string(pic_state *pic){ + struct pic_port *port = pic_stdin(pic), *buf; + pic_str *str; + int k, i; + int c; + + pic_get_args(pic, "i|p", &k, &port); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-stritg"); + + c = EOF; + buf = pic_open_output_string(pic); + for(i = 0; i < k; ++i) { + if((c = xfgetc(port->file)) == EOF){ + break; + } + xfputc(c, buf->file); + } + + str = pic_get_output_string(pic, buf); + if (pic_strlen(str) == 0 && c == EOF) { + return pic_eof_object(); + } + else { + return pic_obj_value(str); + } + +} + +static pic_value +pic_port_read_byte(pic_state *pic){ + struct pic_port *port = pic_stdin(pic); + int c; + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-u8"); + if ((c = xfgetc(port->file)) == EOF) { + return pic_eof_object(); + } + + return pic_int_value(c); +} + +static pic_value +pic_port_peek_byte(pic_state *pic) +{ + int c; + struct pic_port *port = pic_stdin(pic); + + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "peek-u8"); + + c = xfgetc(port->file); + if (c == EOF) { + return pic_eof_object(); + } + else { + xungetc(c, port->file); + return pic_int_value(c); + } +} + +static pic_value +pic_port_byte_ready_p(pic_state *pic) +{ + struct pic_port *port = pic_stdin(pic); + + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "u8-ready?"); + + return pic_true_value(); /* FIXME: always returns #t */ +} + + +static pic_value +pic_port_read_blob(pic_state *pic) +{ + struct pic_port *port = pic_stdin(pic); + pic_blob *blob; + size_t k, i; + + pic_get_args(pic, "k|p", &k, &port); + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector"); + + blob = pic_make_blob(pic, k); + + i = xfread(blob->data, sizeof(char), k, port->file); + if (i == 0) { + return pic_eof_object(); + } + else { + pic_realloc(pic, blob->data, i); + blob->len = i; + return pic_obj_value(blob); + } +} + +static pic_value +pic_port_read_blob_ip(pic_state *pic) +{ + struct pic_port *port; + struct pic_blob *bv; + int n; + char *buf; + size_t start, end, i, len; + + n = pic_get_args(pic, "b|pkk", &bv, &port, &start, &end); + switch (n) { + case 1: + port = pic_stdin(pic); + case 2: + start = 0; + case 3: + end = bv->len; + } + + assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector!"); + + if (end < start) { + pic_errorf(pic, "read-bytevector!: end index must be greater than or equal to start index"); + } + + len = end - start; + + buf = pic_calloc(pic, len, sizeof(char)); + i = xfread(buf, sizeof(char), len, port->file); + memcpy(bv->data + start, buf, i); + pic_free(pic, buf); + + if (i == 0) { + return pic_eof_object(); + } + else { + return pic_size_value(i); + } +} + +static pic_value +pic_port_newline(pic_state *pic) +{ + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "newline"); + + xfputs("\n", port->file); + return pic_none_value(); +} + +static pic_value +pic_port_write_char(pic_state *pic) +{ + char c; + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "c|p", &c, &port); + + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "write-char"); + + xfputc(c, port->file); + return pic_none_value(); +} + +static pic_value +pic_port_write_string(pic_state *pic) +{ + char *str; + struct pic_port *port; + int start, end, n, i; + + n = pic_get_args(pic, "z|pii", &str, &port, &start, &end); + switch (n) { + case 1: + port = pic_stdout(pic); + case 2: + start = 0; + case 3: + end = INT_MAX; + } + + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "write-string"); + + for (i = start; i < end && str[i] != '\0'; ++i) { + xfputc(str[i], port->file); + } + return pic_none_value(); +} + +static pic_value +pic_port_write_byte(pic_state *pic) +{ + int i; + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "i|p", &i, &port); + + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "write-u8"); + + xfputc(i, port->file); + return pic_none_value(); +} + +static pic_value +pic_port_write_blob(pic_state *pic) +{ + struct pic_blob *blob; + struct pic_port *port; + int n; + size_t start, end, i; + + n = pic_get_args(pic, "b|pkk", &blob, &port, &start, &end); + switch (n) { + case 1: + port = pic_stdout(pic); + case 2: + start = 0; + case 3: + end = blob->len; + } + + assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "write-bytevector"); + + for (i = start; i < end; ++i) { + xfputc(blob->data[i], port->file); + } + return pic_none_value(); +} + +static pic_value +pic_port_flush(pic_state *pic) +{ + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "|p", &port); + + assert_port_profile(port, PIC_PORT_OUT, PIC_PORT_OPEN, "flush-output-port"); + + xfflush(port->file); + return pic_none_value(); +} + +void +pic_init_port(pic_state *pic) +{ + pic_defvar(pic, "current-input-port", pic_obj_value(pic->xSTDIN), NULL); + pic_defvar(pic, "current-output-port", pic_obj_value(pic->xSTDOUT), NULL); + pic_defvar(pic, "current-error-port", pic_obj_value(pic->xSTDERR), NULL); + + pic_defun(pic, "call-with-port", pic_port_call_with_port); + + pic_defun(pic, "input-port?", pic_port_input_port_p); + pic_defun(pic, "output-port?", pic_port_output_port_p); + pic_defun(pic, "textual-port?", pic_port_textual_port_p); + pic_defun(pic, "binary-port?", pic_port_binary_port_p); + pic_defun(pic, "port?", pic_port_port_p); + + pic_defun(pic, "port-open?", pic_port_port_open_p); + pic_defun(pic, "close-port", pic_port_close_port); + + /* string I/O */ + pic_defun(pic, "open-input-string", pic_port_open_input_string); + pic_defun(pic, "open-output-string", pic_port_open_output_string); + pic_defun(pic, "get-output-string", pic_port_get_output_string); + pic_defun(pic, "open-input-bytevector", pic_port_open_input_blob); + pic_defun(pic, "open-output-bytevector", pic_port_open_output_bytevector); + pic_defun(pic, "get-output-bytevector", pic_port_get_output_bytevector); + + /* input */ + pic_defun(pic, "read-char", pic_port_read_char); + pic_defun(pic, "peek-char", pic_port_peek_char); + pic_defun(pic, "read-line", pic_port_read_line); + pic_defun(pic, "eof-object?", pic_port_eof_object_p); + pic_defun(pic, "eof-object", pic_port_eof_object); + pic_defun(pic, "char-ready?", pic_port_char_ready_p); + pic_defun(pic, "read-string", pic_port_read_string); + pic_defun(pic, "read-u8", pic_port_read_byte); + pic_defun(pic, "peek-u8", pic_port_peek_byte); + pic_defun(pic, "u8-ready?", pic_port_byte_ready_p); + pic_defun(pic, "read-bytevector", pic_port_read_blob); + pic_defun(pic, "read-bytevector!", pic_port_read_blob_ip); + + /* output */ + pic_defun(pic, "newline", pic_port_newline); + pic_defun(pic, "write-char", pic_port_write_char); + pic_defun(pic, "write-string", pic_port_write_string); + pic_defun(pic, "write-u8", pic_port_write_byte); + pic_defun(pic, "write-bytevector", pic_port_write_blob); + pic_defun(pic, "flush-output-port", pic_port_flush); +} diff --git a/extlib/benz/proc.c b/extlib/benz/proc.c new file mode 100644 index 00000000..210f157d --- /dev/null +++ b/extlib/benz/proc.c @@ -0,0 +1,86 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/pair.h" +#include "picrin/proc.h" +#include "picrin/irep.h" + +struct pic_proc * +pic_make_proc(pic_state *pic, pic_func_t func, const char *name) +{ + struct pic_proc *proc; + + assert(name != NULL); + + proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC); + proc->kind = PIC_PROC_KIND_FUNC; + proc->u.func.f = func; + proc->u.func.name = pic_intern_cstr(pic, name); + proc->env = NULL; + return proc; +} + +struct pic_proc * +pic_make_proc_irep(pic_state *pic, struct pic_irep *irep, struct pic_env *env) +{ + struct pic_proc *proc; + + proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC); + proc->kind = PIC_PROC_KIND_IREP; + proc->u.irep = irep; + proc->env = env; + return proc; +} + +pic_sym +pic_proc_name(struct pic_proc *proc) +{ + switch (proc->kind) { + case PIC_PROC_KIND_FUNC: + return proc->u.func.name; + case PIC_PROC_KIND_IREP: + return proc->u.irep->name; + } + UNREACHABLE(); +} + +static pic_value +pic_proc_proc_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_proc_p(v)); +} + +static pic_value +pic_proc_apply(pic_state *pic) +{ + struct pic_proc *proc; + pic_value *args; + size_t argc; + pic_value arg_list; + + pic_get_args(pic, "l*", &proc, &argc, &args); + + if (argc == 0) { + pic_errorf(pic, "apply: wrong number of arguments"); + } + + arg_list = args[--argc]; + while (argc--) { + arg_list = pic_cons(pic, args[argc], arg_list); + } + + return pic_apply_trampoline(pic, proc, arg_list); +} + +void +pic_init_proc(pic_state *pic) +{ + pic_defun(pic, "procedure?", pic_proc_proc_p); + pic_defun(pic, "apply", pic_proc_apply); +} diff --git a/extlib/benz/read.c b/extlib/benz/read.c new file mode 100644 index 00000000..be160c0d --- /dev/null +++ b/extlib/benz/read.c @@ -0,0 +1,934 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include +#include +#include +#include "picrin.h" +#include "picrin/read.h" +#include "picrin/error.h" +#include "picrin/pair.h" +#include "picrin/string.h" +#include "picrin/vector.h" +#include "picrin/blob.h" +#include "picrin/port.h" +#include "picrin/proc.h" + +static pic_value read(pic_state *pic, struct pic_port *port, int c); +static pic_value read_nullable(pic_state *pic, struct pic_port *port, int c); + +static noreturn void +read_error(pic_state *pic, const char *msg) +{ + pic_throw(pic, pic->sREAD, msg, pic_nil_value()); +} + +static int +skip(struct pic_port *port, int c) +{ + while (isspace(c)) { + c = xfgetc(port->file); + } + return c; +} + +static int +next(struct pic_port *port) +{ + return xfgetc(port->file); +} + +static int +peek(struct pic_port *port) +{ + int c; + + xungetc((c = xfgetc(port->file)), port->file); + + return c; +} + +static bool +expect(struct pic_port *port, const char *str) +{ + int c; + + while ((c = (int)*str++) != 0) { + if (c != peek(port)) + return false; + next(port); + } + + return true; +} + +static bool +isdelim(int c) +{ + return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */ +} + +static bool +strcaseeq(const char *s1, const char *s2) +{ + char a, b; + + while ((a = *s1++) * (b = *s2++)) { + if (tolower(a) != tolower(b)) + return false; + } + return a == b; +} + +static pic_value +read_comment(pic_state *pic, struct pic_port *port, const char *str) +{ + int c; + + UNUSED(pic); + UNUSED(str); + + do { + c = next(port); + } while (! (c == EOF || c == '\n')); + + return pic_undef_value(); +} + +static pic_value +read_block_comment(pic_state *pic, struct pic_port *port, const char *str) +{ + int x, y; + int i = 1; + + UNUSED(pic); + UNUSED(str); + + y = next(port); + + while (y != EOF && i > 0) { + x = y; + y = next(port); + if (x == '|' && y == '#') { + i--; + } + if (x == '#' && y == '|') { + i++; + } + } + + return pic_undef_value(); +} + +static pic_value +read_datum_comment(pic_state *pic, struct pic_port *port, const char *str) +{ + UNUSED(str); + + read(pic, port, next(port)); + + return pic_undef_value(); +} + +static pic_value +read_directive(pic_state *pic, struct pic_port *port, const char *str) +{ + switch (peek(port)) { + case 'n': + if (expect(port, "no-fold-case")) { + pic->reader->typecase = PIC_CASE_DEFAULT; + return pic_undef_value(); + } + break; + case 'f': + if (expect(port, "fold-case")) { + pic->reader->typecase = PIC_CASE_FOLD; + return pic_undef_value(); + } + break; + } + + return read_comment(pic, port, str); +} + +static pic_value +read_eval(pic_state *pic, struct pic_port *port, const char *str) +{ + pic_value form; + + UNUSED(str); + + form = read(pic, port, next(port)); + + return pic_eval(pic, form, pic->lib); +} + +static pic_value +read_quote(pic_state *pic, struct pic_port *port, const char *str) +{ + UNUSED(str); + + return pic_list2(pic, pic_sym_value(pic->sQUOTE), read(pic, port, next(port))); +} + +static pic_value +read_quasiquote(pic_state *pic, struct pic_port *port, const char *str) +{ + UNUSED(str); + + return pic_list2(pic, pic_sym_value(pic->sQUASIQUOTE), read(pic, port, next(port))); +} + +static pic_value +read_unquote(pic_state *pic, struct pic_port *port, const char *str) +{ + UNUSED(str); + + return pic_list2(pic, pic_sym_value(pic->sUNQUOTE), read(pic, port, next(port))); +} + +static pic_value +read_unquote_splicing(pic_state *pic, struct pic_port *port, const char *str) +{ + UNUSED(str); + + return pic_list2(pic, pic_sym_value(pic->sUNQUOTE_SPLICING), read(pic, port, next(port))); +} + +static pic_value +read_symbol(pic_state *pic, struct pic_port *port, const char *str) +{ + size_t len, i; + char *buf; + pic_sym sym; + int c; + + len = strlen(str); + buf = pic_calloc(pic, 1, len + 1); + + for (i = 0; i < len; ++i) { + if (pic->reader->typecase == PIC_CASE_FOLD) { + buf[i] = (char)tolower(str[i]); + } else { + buf[i] = str[i]; + } + } + + while (! isdelim(peek(port))) { + c = next(port); + if (pic->reader->typecase == PIC_CASE_FOLD) { + c = tolower(c); + } + len += 1; + buf = pic_realloc(pic, buf, len + 1); + buf[len - 1] = (char)c; + } + + sym = pic_intern(pic, buf, len); + pic_free(pic, buf); + + return pic_sym_value(sym); +} + +static size_t +read_uinteger(pic_state *pic, struct pic_port *port, int c, char buf[]) +{ + size_t i = 0; + + if (! isdigit(c)) { + read_error(pic, "expected one or more digits"); + } + + buf[i++] = (char)c; + while (isdigit(c = peek(port))) { + buf[i++] = (char)next(port); + } + + buf[i] = '\0'; + + return i; +} + +static size_t +read_suffix(pic_state *pic, struct pic_port *port, char buf[]) +{ + size_t i = 0; + int c; + + c = peek(port); + + if (c != 'e' && c != 'E') { + return i; + } + + buf[i++] = (char)next(port); + + switch ((c = next(port))) { + case '-': + case '+': + buf[i++] = (char)c; + c = next(port); + default: + return i + read_uinteger(pic, port, c, buf + i); + } +} + +static pic_value +read_unsigned(pic_state *pic, struct pic_port *port, int c) +{ + char buf[256]; + size_t i; + + i = read_uinteger(pic, port, c, buf); + + switch (peek(port)) { + case '.': + buf[i++] = (char)next(port); + i += read_uinteger(pic, port, next(port), buf + i); + read_suffix(pic, port, buf + i); + return pic_float_value(atof(buf)); + + default: + read_suffix(pic, port, buf + i); + return pic_int_value((int)(atof(buf))); + } +} + +static pic_value +read_number(pic_state *pic, struct pic_port *port, const char *str) +{ + return read_unsigned(pic, port, str[0]); +} + +static pic_value +negate(pic_value n) +{ + if (pic_int_p(n)) { + return pic_int_value(-pic_int(n)); + } else { + return pic_float_value(-pic_float(n)); + } +} + +static pic_value +read_minus(pic_state *pic, struct pic_port *port, const char *str) +{ + pic_value sym; + + if (isdigit(peek(port))) { + return negate(read_unsigned(pic, port, next(port))); + } + else { + sym = read_symbol(pic, port, str); + if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "-inf.0")) { + return pic_float_value(-INFINITY); + } + if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "-nan.0")) { + return pic_float_value(-NAN); + } + return sym; + } +} + +static pic_value +read_plus(pic_state *pic, struct pic_port *port, const char *str) +{ + pic_value sym; + + if (isdigit(peek(port))) { + return read_unsigned(pic, port, next(port)); + } + else { + sym = read_symbol(pic, port, str); + if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "+inf.0")) { + return pic_float_value(INFINITY); + } + if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "+nan.0")) { + return pic_float_value(NAN); + } + return sym; + } +} + +static pic_value +read_true(pic_state *pic, struct pic_port *port, const char *str) +{ + UNUSED(pic); + UNUSED(port); + UNUSED(str); + + return pic_true_value(); +} + +static pic_value +read_false(pic_state *pic, struct pic_port *port, const char *str) +{ + UNUSED(pic); + UNUSED(port); + UNUSED(str); + + return pic_false_value(); +} + +static pic_value +read_char(pic_state *pic, struct pic_port *port, const char *str) +{ + int c; + + UNUSED(str); + + c = next(port); + + if (! isdelim(peek(port))) { + switch (c) { + default: read_error(pic, "unexpected character after char literal"); + case 'a': c = '\a'; if (! expect(port, "lerm")) goto fail; break; + case 'b': c = '\b'; if (! expect(port, "ackspace")) goto fail; break; + case 'd': c = 0x7F; if (! expect(port, "elete")) goto fail; break; + case 'e': c = 0x1B; if (! expect(port, "scape")) goto fail; break; + case 'n': + if ((c = peek(port)) == 'e') { + c = '\n'; + if (! expect(port, "ewline")) + goto fail; + } else { + c = '\0'; + if (! expect(port, "ull")) + goto fail; + } + break; + case 'r': c = '\r'; if (! expect(port, "eturn")) goto fail; break; + case 's': c = ' '; if (! expect(port, "pace")) goto fail; break; + case 't': c = '\t'; if (! expect(port, "ab")) goto fail; break; + } + } + + return pic_char_value((char)c); + + fail: + read_error(pic, "unexpected character while reading character literal"); +} + +static pic_value +read_string(pic_state *pic, struct pic_port *port, const char *name) +{ + int c; + char *buf; + size_t size, cnt; + pic_str *str; + + UNUSED(name); + + size = 256; + buf = pic_alloc(pic, size); + cnt = 0; + + /* TODO: intraline whitespaces */ + + while ((c = next(port)) != '"') { + if (c == '\\') { + switch (c = next(port)) { + case 'a': c = '\a'; break; + case 'b': c = '\b'; break; + case 't': c = '\t'; break; + case 'n': c = '\n'; break; + case 'r': c = '\r'; break; + } + } + buf[cnt++] = (char)c; + if (cnt >= size) { + buf = pic_realloc(pic, buf, size *= 2); + } + } + buf[cnt] = '\0'; + + str = pic_make_str(pic, buf, cnt); + pic_free(pic, buf); + return pic_obj_value(str); +} + +static pic_value +read_pipe(pic_state *pic, struct pic_port *port, const char *str) +{ + char *buf; + size_t size, cnt; + pic_sym sym; + /* Currently supports only ascii chars */ + char HEX_BUF[3]; + size_t i = 0; + int c; + + UNUSED(str); + + size = 256; + buf = pic_alloc(pic, size); + cnt = 0; + while ((c = next(port)) != '|') { + if (c == '\\') { + switch ((c = next(port))) { + case 'a': c = '\a'; break; + case 'b': c = '\b'; break; + case 't': c = '\t'; break; + case 'n': c = '\n'; break; + case 'r': c = '\r'; break; + case 'x': + i = 0; + while ((HEX_BUF[i++] = (char)next(port)) != ';') { + if (i >= sizeof HEX_BUF) + read_error(pic, "expected ';'"); + } + c = (char)strtol(HEX_BUF, NULL, 16); + break; + } + } + buf[cnt++] = (char)c; + if (cnt >= size) { + buf = pic_realloc(pic, buf, size *= 2); + } + } + buf[cnt] = '\0'; + + sym = pic_intern_cstr(pic, buf); + pic_free(pic, buf); + + return pic_sym_value(sym); +} + +static pic_value +read_blob(pic_state *pic, struct pic_port *port, const char *str) +{ + int nbits, n, c; + size_t len, i; + char buf[256]; + unsigned char *dat; + pic_blob *blob; + + UNUSED(str); + + nbits = 0; + + while (isdigit(c = next(port))) { + nbits = 10 * nbits + c - '0'; + } + + if (nbits != 8) { + read_error(pic, "unsupported bytevector bit width"); + } + + if (c != '(') { + read_error(pic, "expected '(' character"); + } + + len = 0; + dat = NULL; + c = next(port); + while ((c = skip(port, c)) != ')') { + read_uinteger(pic, port, c, buf); + n = atoi(buf); + if (n < 0 || (1 << nbits) <= n) { + read_error(pic, "invalid element in bytevector literal"); + } + len += 1; + dat = pic_realloc(pic, dat, len); + dat[len - 1] = (unsigned char)n; + c = next(port); + } + + blob = pic_make_blob(pic, len); + for (i = 0; i < len; ++i) { + blob->data[i] = dat[i]; + } + + pic_free(pic, dat); + return pic_obj_value(blob); +} + +static pic_value +read_pair(pic_state *pic, struct pic_port *port, const char *str) +{ + const int tCLOSE = (str[0] == '(') ? ')' : ']'; + pic_value car, cdr; + int c; + + retry: + + c = skip(port, ' '); + + if (c == tCLOSE) { + return pic_nil_value(); + } + if (c == '.' && isdelim(peek(port))) { + cdr = read(pic, port, next(port)); + + closing: + if ((c = skip(port, ' ')) != tCLOSE) { + if (pic_undef_p(read_nullable(pic, port, c))) { + goto closing; + } + read_error(pic, "unmatched parenthesis"); + } + return cdr; + } + else { + car = read_nullable(pic, port, c); + + if (pic_undef_p(car)) { + goto retry; + } + + cdr = read_pair(pic, port, str); + return pic_cons(pic, car, cdr); + } +} + +static pic_value +read_vector(pic_state *pic, struct pic_port *port, const char *str) +{ + pic_value list; + + list = read(pic, port, str[1]); + + return pic_obj_value(pic_make_vec_from_list(pic, list)); +} + +static pic_value +read_label_set(pic_state *pic, struct pic_port *port, int i) +{ + pic_value val; + int c; + + switch ((c = skip(port, ' '))) { + case '(': case '[': + { + pic_value tmp; + + val = pic_cons(pic, pic_none_value(), pic_none_value()); + + xh_put_int(&pic->reader->labels, i, &val); + + tmp = read(pic, port, c); + pic_pair_ptr(val)->car = pic_car(pic, tmp); + pic_pair_ptr(val)->cdr = pic_cdr(pic, tmp); + + return val; + } + case '#': + { + bool vect; + + if (peek(port) == '(') { + vect = true; + } else { + vect = false; + } + + if (vect) { + pic_vec *tmp; + + val = pic_obj_value(pic_make_vec(pic, 0)); + + xh_put_int(&pic->reader->labels, i, &val); + + tmp = pic_vec_ptr(read(pic, port, c)); + SWAP(pic_value *, tmp->data, pic_vec_ptr(val)->data); + SWAP(size_t, tmp->len, pic_vec_ptr(val)->len); + + return val; + } + + FALLTHROUGH; + } + default: + { + val = read(pic, port, c); + + xh_put_int(&pic->reader->labels, i, &val); + + return val; + } + } +} + +static pic_value +read_label_ref(pic_state *pic, struct pic_port *port, int i) +{ + xh_entry *e; + + UNUSED(port); + + e = xh_get_int(&pic->reader->labels, i); + if (! e) { + read_error(pic, "label of given index not defined"); + } + return xh_val(e, pic_value); +} + +static pic_value +read_label(pic_state *pic, struct pic_port *port, const char *str) +{ + int i, c; + + i = 0; + c = str[1]; /* initial index letter */ + do { + i = i * 10 + c; + } while (isdigit(c = next(port))); + + if (c == '=') { + return read_label_set(pic, port, i); + } + if (c == '#') { + return read_label_ref(pic, port, i); + } + read_error(pic, "broken label expression"); +} + +static pic_value +read_unmatch(pic_state *pic, struct pic_port *port, const char *str) +{ + UNUSED(port); + UNUSED(str); + + read_error(pic, "unmatched parenthesis"); +} + +static pic_value +read_nullable(pic_state *pic, struct pic_port *port, int c) +{ + struct pic_trie *trie = pic->reader->trie; + char buf[128]; + size_t i = 0; + pic_str *str; + + c = skip(port, c); + + if (c == EOF) { + read_error(pic, "unexpected EOF"); + } + + if (trie->table[c] == NULL) { + read_error(pic, "invalid character at the seeker head"); + } + + buf[i++] = (char)c; + + while (i < sizeof buf) { + trie = trie->table[c]; + + if ((c = peek(port)) == EOF) { + break; + } + if (trie->table[c] == NULL) { + break; + } + buf[i++] = (char)next(port); + } + if (i == sizeof buf) { + read_error(pic, "too long dispatch string"); + } + + if (trie->proc == NULL) { + read_error(pic, "no reader registered for current string"); + } + str = pic_make_str(pic, buf, i); + return pic_apply2(pic, trie->proc, pic_obj_value(port), pic_obj_value(str)); +} + +static pic_value +read(pic_state *pic, struct pic_port *port, int c) +{ + pic_value val; + + retry: + val = read_nullable(pic, port, c); + + if (pic_undef_p(val)) { + c = next(port); + goto retry; + } + + return val; +} + +struct pic_trie * +pic_make_trie(pic_state *pic) +{ + struct pic_trie *trie; + + trie = pic_alloc(pic, sizeof(struct pic_trie)); + trie->proc = NULL; + memset(trie->table, 0, sizeof trie->table); + + return trie; +} + +void +pic_trie_delete(pic_state *pic, struct pic_trie *trie) +{ + size_t i; + + for (i = 0; i < sizeof trie->table / sizeof(struct pic_trie *); ++i) { + if (trie->table[i] != NULL) { + pic_trie_delete(pic, trie->table[i]); + } + } + + pic_free(pic, trie); +} + +void +pic_define_reader(pic_state *pic, const char *str, pic_func_t reader) +{ + struct pic_trie *trie = pic->reader->trie; + int c; + + while ((c = *str++)) { + if (trie->table[c] == NULL) { + trie->table[c] = pic_make_trie(pic); + } + trie = trie->table[c]; + } + trie->proc = pic_make_proc(pic, reader, "reader"); +} + +#define DEFINE_READER(name) \ + static pic_value \ + pic_##name(pic_state *pic) \ + { \ + struct pic_port *port; \ + const char *str; \ + \ + pic_get_args(pic, "pz", &port, &str); \ + \ + return name(pic, port, str); \ + } + +DEFINE_READER(read_unmatch) +DEFINE_READER(read_comment) +DEFINE_READER(read_quote) +DEFINE_READER(read_quasiquote) +DEFINE_READER(read_unquote) +DEFINE_READER(read_unquote_splicing) +DEFINE_READER(read_string) +DEFINE_READER(read_pipe) +DEFINE_READER(read_plus) +DEFINE_READER(read_minus) +DEFINE_READER(read_pair) +DEFINE_READER(read_directive) +DEFINE_READER(read_block_comment) +DEFINE_READER(read_datum_comment) +DEFINE_READER(read_true) +DEFINE_READER(read_false) +DEFINE_READER(read_char) +DEFINE_READER(read_vector) +DEFINE_READER(read_blob) +DEFINE_READER(read_eval) +DEFINE_READER(read_symbol) +DEFINE_READER(read_number) +DEFINE_READER(read_label) + +void +pic_init_reader(pic_state *pic) +{ + static const char INIT[] = "!$%&*./:<=>?@^_~"; + char buf[3] = { 0 }; + size_t i; + + pic_define_reader(pic, ")", pic_read_unmatch); + pic_define_reader(pic, ";", pic_read_comment); + pic_define_reader(pic, "'", pic_read_quote); + pic_define_reader(pic, "`", pic_read_quasiquote); + pic_define_reader(pic, ",", pic_read_unquote); + pic_define_reader(pic, ",@", pic_read_unquote_splicing); + pic_define_reader(pic, "\"", pic_read_string); + pic_define_reader(pic, "|", pic_read_pipe); + pic_define_reader(pic, "+", pic_read_plus); + pic_define_reader(pic, "-", pic_read_minus); + pic_define_reader(pic, "(", pic_read_pair); + pic_define_reader(pic, "[", pic_read_pair); + + pic_define_reader(pic, "#!", pic_read_directive); + pic_define_reader(pic, "#|", pic_read_block_comment); + pic_define_reader(pic, "#;", pic_read_datum_comment); + pic_define_reader(pic, "#t", pic_read_true); + pic_define_reader(pic, "#true", pic_read_true); + pic_define_reader(pic, "#f", pic_read_false); + pic_define_reader(pic, "#false", pic_read_false); + pic_define_reader(pic, "#\\", pic_read_char); + pic_define_reader(pic, "#(", pic_read_vector); + pic_define_reader(pic, "#u", pic_read_blob); + pic_define_reader(pic, "#.", pic_read_eval); + + /* read number */ + for (buf[0] = '0'; buf[0] <= '9'; ++buf[0]) { + pic_define_reader(pic, buf, pic_read_number); + } + + /* read symbol */ + for (buf[0] = 'a'; buf[0] <= 'z'; ++buf[0]) { + pic_define_reader(pic, buf, pic_read_symbol); + } + for (buf[0] = 'A'; buf[0] <= 'Z'; ++buf[0]) { + pic_define_reader(pic, buf, pic_read_symbol); + } + for (i = 0; i < sizeof INIT; ++i) { + buf[0] = INIT[i]; + pic_define_reader(pic, buf, pic_read_symbol); + } + + /* read label */ + buf[0] = '#'; + for (buf[1] = '0'; buf[1] <= '9'; ++buf[1]) { + pic_define_reader(pic, buf, pic_read_label); + } +} + +pic_value +pic_read(pic_state *pic, struct pic_port *port) +{ + pic_value val; + int c = next(port); + + retry: + c = skip(port, c); + + if (c == EOF) { + return pic_eof_object(); + } + + val = read_nullable(pic, port, c); + + if (pic_undef_p(val)) { + c = next(port); + goto retry; + } + + return val; +} + +pic_value +pic_read_cstr(pic_state *pic, const char *str) +{ + struct pic_port *port; + + port = pic_open_input_string(pic, str); + + return pic_read(pic, port); +} + +static pic_value +pic_read_read(pic_state *pic) +{ + struct pic_port *port = pic_stdin(pic); + + pic_get_args(pic, "|p", &port); + + return pic_read(pic, port); +} + +void +pic_init_read(pic_state *pic) +{ + pic_defun(pic, "read", pic_read_read); +} diff --git a/extlib/benz/record.c b/extlib/benz/record.c new file mode 100644 index 00000000..52fbe050 --- /dev/null +++ b/extlib/benz/record.c @@ -0,0 +1,113 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/record.h" + +struct pic_record * +pic_make_record(pic_state *pic, pic_value rectype) +{ + struct pic_record *rec; + + rec = (struct pic_record *)pic_obj_alloc(pic, sizeof(struct pic_record), PIC_TT_RECORD); + xh_init_int(&rec->hash, sizeof(pic_value)); + + pic_record_set(pic, rec, pic_intern_cstr(pic, "@@type"), rectype); + + return rec; +} + +pic_value +pic_record_type(pic_state *pic, struct pic_record *rec) +{ + return pic_record_ref(pic, rec, pic_intern_cstr(pic, "@@type")); +} + +pic_value +pic_record_ref(pic_state *pic, struct pic_record *rec, pic_sym slot) +{ + xh_entry *e; + + e = xh_get_int(&rec->hash, slot); + if (! e) { + pic_errorf(pic, "slot named ~s is not found for record: ~s", pic_sym_value(slot), rec); + } + return xh_val(e, pic_value); +} + +void +pic_record_set(pic_state *pic, struct pic_record *rec, pic_sym slot, pic_value val) +{ + UNUSED(pic); + + xh_put_int(&rec->hash, slot, &val); +} + +static pic_value +pic_record_make_record(pic_state *pic) +{ + struct pic_record * rec; + pic_value rectype; + + pic_get_args(pic, "o", &rectype); + + rec = pic_make_record(pic, rectype); + + return pic_obj_value(rec); +} + +static pic_value +pic_record_record_p(pic_state *pic) +{ + pic_value rec; + + pic_get_args(pic, "o", &rec); + + return pic_bool_value(pic_record_p(rec)); +} + +static pic_value +pic_record_record_type(pic_state *pic) +{ + struct pic_record *rec; + + pic_get_args(pic, "r", &rec); + + return pic_record_type(pic, rec); +} + +static pic_value +pic_record_record_ref(pic_state *pic) +{ + struct pic_record *rec; + pic_sym slot; + + pic_get_args(pic, "rm", &rec, &slot); + + return pic_record_ref(pic, rec, slot); +} + +static pic_value +pic_record_record_set(pic_state *pic) +{ + struct pic_record *rec; + pic_sym slot; + pic_value val; + + pic_get_args(pic, "rmo", &rec, &slot, &val); + + pic_record_set(pic, rec, slot, val); + + return pic_none_value(); +} + +void +pic_init_record(pic_state *pic) +{ + pic_defun(pic, "make-record", pic_record_make_record); + pic_defun(pic, "record?", pic_record_record_p); + pic_defun(pic, "record-type", pic_record_record_type); + pic_defun(pic, "record-ref", pic_record_record_ref); + pic_defun(pic, "record-set!", pic_record_record_set); +} diff --git a/extlib/benz/state.c b/extlib/benz/state.c new file mode 100644 index 00000000..688e4a6f --- /dev/null +++ b/extlib/benz/state.c @@ -0,0 +1,239 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#include "picrin.h" +#include "picrin/gc.h" +#include "picrin/read.h" +#include "picrin/proc.h" +#include "picrin/macro.h" +#include "picrin/cont.h" +#include "picrin/port.h" +#include "picrin/error.h" + +void pic_init_core(pic_state *); + +pic_state * +pic_open(int argc, char *argv[], char **envp) +{ + struct pic_port *pic_make_standard_port(pic_state *, xFILE *, short); + char t; + + pic_state *pic; + size_t ai; + + pic = malloc(sizeof(pic_state)); + + /* root block */ + pic->wind = NULL; + + /* command line */ + pic->argc = argc; + pic->argv = argv; + pic->envp = envp; + + /* prepare VM stack */ + pic->stbase = pic->sp = calloc(PIC_STACK_SIZE, sizeof(pic_value)); + pic->stend = pic->stbase + PIC_STACK_SIZE; + + /* callinfo */ + pic->cibase = pic->ci = calloc(PIC_STACK_SIZE, sizeof(pic_callinfo)); + pic->ciend = pic->cibase + PIC_STACK_SIZE; + + /* exception handler */ + pic->xpbase = pic->xp = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_proc *)); + pic->xpend = pic->xpbase + PIC_RESCUE_SIZE; + + /* memory heap */ + pic->heap = pic_heap_open(); + + /* symbol table */ + xh_init_str(&pic->syms, sizeof(pic_sym)); + xh_init_int(&pic->sym_names, sizeof(const char *)); + pic->sym_cnt = 0; + pic->uniq_sym_cnt = 0; + + /* global variables */ + xh_init_int(&pic->globals, sizeof(pic_value)); + + /* macros */ + xh_init_int(&pic->macros, sizeof(struct pic_macro *)); + + /* attributes */ + xh_init_ptr(&pic->attrs, sizeof(struct pic_dict *)); + + /* features */ + pic->features = pic_nil_value(); + + /* libraries */ + pic->libs = pic_nil_value(); + pic->lib = NULL; + + /* reader */ + pic->reader = malloc(sizeof(struct pic_reader)); + pic->reader->typecase = PIC_CASE_DEFAULT; + pic->reader->trie = pic_make_trie(pic); + xh_init_int(&pic->reader->labels, sizeof(pic_value)); + + /* raised error object */ + pic->err = pic_undef_value(); + + /* standard ports */ + pic->xSTDIN = NULL; + pic->xSTDOUT = NULL; + pic->xSTDERR = NULL; + + /* GC arena */ + pic->arena = calloc(PIC_ARENA_SIZE, sizeof(struct pic_object **)); + pic->arena_size = PIC_ARENA_SIZE; + pic->arena_idx = 0; + + /* native stack marker */ + pic->native_stack_start = &t; + +#define S(slot,name) pic->slot = pic_intern_cstr(pic, name); + + ai = pic_gc_arena_preserve(pic); + S(sDEFINE, "define"); + S(sLAMBDA, "lambda"); + S(sIF, "if"); + S(sBEGIN, "begin"); + S(sSETBANG, "set!"); + S(sQUOTE, "quote"); + S(sQUASIQUOTE, "quasiquote"); + S(sUNQUOTE, "unquote"); + S(sUNQUOTE_SPLICING, "unquote-splicing"); + S(sDEFINE_SYNTAX, "define-syntax"); + S(sIMPORT, "import"); + S(sEXPORT, "export"); + S(sDEFINE_LIBRARY, "define-library"); + S(sIN_LIBRARY, "in-library"); + S(sCOND_EXPAND, "cond-expand"); + S(sAND, "and"); + S(sOR, "or"); + S(sELSE, "else"); + S(sLIBRARY, "library"); + S(sONLY, "only"); + S(sRENAME, "rename"); + S(sPREFIX, "prefix"); + S(sEXCEPT, "except"); + S(sCONS, "cons"); + S(sCAR, "car"); + S(sCDR, "cdr"); + S(sNILP, "null?"); + S(sADD, "+"); + S(sSUB, "-"); + S(sMUL, "*"); + S(sDIV, "/"); + S(sMINUS, "minus"); + S(sEQ, "="); + S(sLT, "<"); + S(sLE, "<="); + S(sGT, ">"); + S(sGE, ">="); + S(sNOT, "not"); + S(sREAD, "read"); + S(sFILE, "file"); + pic_gc_arena_restore(pic, ai); + +#define R(slot,name) pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name)); + + ai = pic_gc_arena_preserve(pic); + R(rDEFINE, "define"); + R(rLAMBDA, "lambda"); + R(rIF, "if"); + R(rBEGIN, "begin"); + R(rSETBANG, "set!"); + R(rQUOTE, "quote"); + R(rDEFINE_SYNTAX, "define-syntax"); + R(rIMPORT, "import"); + R(rEXPORT, "export"); + R(rDEFINE_LIBRARY, "define-library"); + R(rIN_LIBRARY, "in-library"); + R(rCOND_EXPAND, "cond-expand"); + pic_gc_arena_restore(pic, ai); + + /* root block */ + pic->wind = pic_alloc(pic, sizeof(struct pic_winder)); + pic->wind->prev = NULL; + pic->wind->depth = 0; + pic->wind->in = pic->wind->out = NULL; + + /* init readers */ + pic_init_reader(pic); + + /* standard libraries */ + pic->PICRIN_BASE = pic_open_library(pic, pic_read_cstr(pic, "(picrin base)")); + pic->PICRIN_USER = pic_open_library(pic, pic_read_cstr(pic, "(picrin user)")); + pic->lib = pic->PICRIN_USER; + + /* standard I/O */ + pic->xSTDIN = pic_make_standard_port(pic, xstdin, PIC_PORT_IN); + pic->xSTDOUT = pic_make_standard_port(pic, xstdout, PIC_PORT_OUT); + pic->xSTDERR = pic_make_standard_port(pic, xstderr, PIC_PORT_OUT); + + pic_init_core(pic); + + return pic; +} + +void +pic_close(pic_state *pic) +{ + xh_entry *it; + + /* invoke exit handlers */ + while (pic->wind) { + if (pic->wind->out) { + pic_apply0(pic, pic->wind->out); + } + pic->wind = pic->wind->prev; + } + + /* clear out root objects */ + pic->sp = pic->stbase; + pic->ci = pic->cibase; + pic->xp = pic->xpbase; + pic->arena_idx = 0; + pic->err = pic_undef_value(); + xh_clear(&pic->globals); + xh_clear(&pic->macros); + xh_clear(&pic->attrs); + pic->features = pic_nil_value(); + pic->libs = pic_nil_value(); + + /* free all heap objects */ + pic_gc_run(pic); + + /* free heaps */ + pic_heap_close(pic->heap); + + /* free runtime context */ + free(pic->stbase); + free(pic->cibase); + free(pic->xpbase); + + /* free reader struct */ + xh_destroy(&pic->reader->labels); + pic_trie_delete(pic, pic->reader->trie); + free(pic->reader); + + /* free global stacks */ + xh_destroy(&pic->syms); + xh_destroy(&pic->globals); + xh_destroy(&pic->macros); + xh_destroy(&pic->attrs); + + /* free GC arena */ + free(pic->arena); + + /* free symbol names */ + for (it = xh_begin(&pic->sym_names); it != NULL; it = xh_next(it)) { + free(xh_val(it, char *)); + } + xh_destroy(&pic->sym_names); + + free(pic); +} diff --git a/extlib/benz/string.c b/extlib/benz/string.c new file mode 100644 index 00000000..63f301d8 --- /dev/null +++ b/extlib/benz/string.c @@ -0,0 +1,497 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#include "picrin.h" +#include "picrin/string.h" +#include "picrin/pair.h" +#include "picrin/port.h" + +static pic_str * +make_str_rope(pic_state *pic, xrope *rope) +{ + pic_str *str; + + str = (pic_str *)pic_obj_alloc(pic, sizeof(pic_str), PIC_TT_STRING); + str->rope = rope; /* delegate ownership */ + return str; +} + +pic_str * +pic_make_str(pic_state *pic, const char *imbed, size_t len) +{ + if (imbed == NULL && len > 0) { + pic_errorf(pic, "zero length specified against NULL ptr"); + } + return make_str_rope(pic, xr_new_copy(imbed, len)); +} + +pic_str * +pic_make_str_cstr(pic_state *pic, const char *cstr) +{ + return pic_make_str(pic, cstr, strlen(cstr)); +} + +pic_str * +pic_make_str_fill(pic_state *pic, size_t len, char fill) +{ + size_t i; + char buf[len + 1]; + + for (i = 0; i < len; ++i) { + buf[i] = fill; + } + buf[i] = '\0'; + + return pic_make_str(pic, buf, len); +} + +size_t +pic_strlen(pic_str *str) +{ + return xr_len(str->rope); +} + +char +pic_str_ref(pic_state *pic, pic_str *str, size_t i) +{ + int c; + + c = xr_at(str->rope, i); + if (c == -1) { + pic_errorf(pic, "index out of range %d", i); + } + return (char)c; +} + +pic_str * +pic_strcat(pic_state *pic, pic_str *a, pic_str *b) +{ + return make_str_rope(pic, xr_cat(a->rope, b->rope)); +} + +pic_str * +pic_substr(pic_state *pic, pic_str *str, size_t s, size_t e) +{ + return make_str_rope(pic, xr_sub(str->rope, s, e)); +} + +int +pic_strcmp(pic_str *str1, pic_str *str2) +{ + return strcmp(xr_cstr(str1->rope), xr_cstr(str2->rope)); +} + +const char * +pic_str_cstr(pic_str *str) +{ + return xr_cstr(str->rope); +} + +pic_value +pic_xvfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap) +{ + char c; + pic_value irrs = pic_nil_value(); + + while ((c = *fmt++)) { + switch (c) { + default: + xfputc(c, file); + break; + case '%': + c = *fmt++; + if (! c) + goto exit; + switch (c) { + default: + xfputc(c, file); + break; + case '%': + xfputc('%', file); + break; + case 'c': + xfprintf(file, "%c", va_arg(ap, int)); + break; + case 's': + xfprintf(file, "%s", va_arg(ap, const char *)); + break; + case 'd': + xfprintf(file, "%d", va_arg(ap, int)); + break; + case 'p': + xfprintf(file, "%p", va_arg(ap, void *)); + break; + case 'f': + xfprintf(file, "%f", va_arg(ap, double)); + break; + } + break; + case '~': + c = *fmt++; + if (! c) + goto exit; + switch (c) { + default: + xfputc(c, file); + break; + case '~': + xfputc('~', file); + break; + case '%': + xfputc('\n', file); + break; + case 'a': + irrs = pic_cons(pic, pic_fdisplay(pic, va_arg(ap, pic_value), file), irrs); + break; + case 's': + irrs = pic_cons(pic, pic_fwrite(pic, va_arg(ap, pic_value), file), irrs); + break; + } + break; + } + } + exit: + + return pic_reverse(pic, irrs); +} + +pic_value +pic_xvformat(pic_state *pic, const char *fmt, va_list ap) +{ + struct pic_port *port; + pic_value irrs; + + port = pic_open_output_string(pic); + + irrs = pic_xvfformat(pic, port->file, fmt, ap); + irrs = pic_cons(pic, pic_obj_value(pic_get_output_string(pic, port)), irrs); + + pic_close_port(pic, port); + return irrs; +} + +pic_value +pic_xformat(pic_state *pic, const char *fmt, ...) +{ + va_list ap; + pic_value objs; + + va_start(ap, fmt); + objs = pic_xvformat(pic, fmt, ap); + va_end(ap); + + return objs; +} + +void +pic_vfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap) +{ + pic_xvfformat(pic, file, fmt, ap); +} + +pic_str * +pic_vformat(pic_state *pic, const char *fmt, va_list ap) +{ + struct pic_port *port; + pic_str *str; + + port = pic_open_output_string(pic); + + pic_vfformat(pic, port->file, fmt, ap); + str = pic_get_output_string(pic, port); + + pic_close_port(pic, port); + return str; +} + +pic_str * +pic_format(pic_state *pic, const char *fmt, ...) +{ + va_list ap; + pic_str *str; + + va_start(ap, fmt); + str = pic_vformat(pic, fmt, ap); + va_end(ap); + + return str; +} + +static pic_value +pic_str_string_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_str_p(v)); +} + +static pic_value +pic_str_string(pic_state *pic) +{ + size_t argc, i; + pic_value *argv; + pic_str *str; + char *buf; + + pic_get_args(pic, "*", &argc, &argv); + + buf = pic_alloc(pic, (size_t)argc); + + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], char); + buf[i] = pic_char(argv[i]); + } + + str = pic_make_str(pic, buf, (size_t)argc); + pic_free(pic, buf); + + return pic_obj_value(str); +} + +static pic_value +pic_str_make_string(pic_state *pic) +{ + size_t len; + char c = ' '; + + pic_get_args(pic, "k|c", &len, &c); + + return pic_obj_value(pic_make_str_fill(pic, len, c)); +} + +static pic_value +pic_str_string_length(pic_state *pic) +{ + pic_str *str; + + pic_get_args(pic, "s", &str); + + return pic_size_value(pic_strlen(str)); +} + +static pic_value +pic_str_string_ref(pic_state *pic) +{ + pic_str *str; + size_t k; + + pic_get_args(pic, "sk", &str, &k); + + return pic_char_value(pic_str_ref(pic, str, k)); +} + +#define DEFINE_STRING_CMP(name, op) \ + static pic_value \ + pic_str_string_##name(pic_state *pic) \ + { \ + size_t argc, i; \ + pic_value *argv; \ + \ + pic_get_args(pic, "*", &argc, &argv); \ + \ + if (argc < 1 || ! pic_str_p(argv[0])) { \ + return pic_false_value(); \ + } \ + \ + for (i = 1; i < argc; ++i) { \ + if (! pic_str_p(argv[i])) { \ + return pic_false_value(); \ + } \ + if (! (pic_strcmp(pic_str_ptr(argv[i-1]), pic_str_ptr(argv[i])) op 0)) { \ + return pic_false_value(); \ + } \ + } \ + return pic_true_value(); \ + } + +DEFINE_STRING_CMP(eq, ==) +DEFINE_STRING_CMP(lt, <) +DEFINE_STRING_CMP(gt, >) +DEFINE_STRING_CMP(le, <=) +DEFINE_STRING_CMP(ge, >=) + +static pic_value +pic_str_string_copy(pic_state *pic) +{ + pic_str *str; + int n; + size_t start, end; + + n = pic_get_args(pic, "s|kk", &str, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = pic_strlen(str); + } + + return pic_obj_value(pic_substr(pic, str, start, end)); +} + +static pic_value +pic_str_string_append(pic_state *pic) +{ + size_t argc, i; + pic_value *argv; + pic_str *str; + + pic_get_args(pic, "*", &argc, &argv); + + str = pic_make_str(pic, NULL, 0); + for (i = 0; i < argc; ++i) { + if (! pic_str_p(argv[i])) { + pic_errorf(pic, "type error"); + } + str = pic_strcat(pic, str, pic_str_ptr(argv[i])); + } + return pic_obj_value(str); +} + +static pic_value +pic_str_string_map(pic_state *pic) +{ + struct pic_proc *proc; + pic_value *argv, vals, val; + size_t argc, i, len, j; + + pic_get_args(pic, "l*", &proc, &argc, &argv); + + len = SIZE_MAX; + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], str); + + len = len < pic_strlen(pic_str_ptr(argv[i])) + ? len + : pic_strlen(pic_str_ptr(argv[i])); + } + if (len == SIZE_MAX) { + pic_errorf(pic, "string-map: one or more strings expected, but got zero"); + } + else { + char buf[len]; + + for (i = 0; i < len; ++i) { + vals = pic_nil_value(); + 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_apply(pic, proc, vals); + + pic_assert_type(pic, val, char); + buf[i] = pic_char(val); + } + + return pic_obj_value(pic_make_str(pic, buf, len)); + } +} + +static pic_value +pic_str_string_for_each(pic_state *pic) +{ + struct pic_proc *proc; + size_t argc, len, i, j; + pic_value *argv, vals; + + pic_get_args(pic, "l*", &proc, &argc, &argv); + + len = SIZE_MAX; + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], str); + + len = len < pic_strlen(pic_str_ptr(argv[i])) + ? len + : pic_strlen(pic_str_ptr(argv[i])); + } + if (len == SIZE_MAX) { + pic_errorf(pic, "string-map: one or more strings expected, but got zero"); + } + + for (i = 0; i < len; ++i) { + vals = pic_nil_value(); + for (j = 0; j < argc; ++j) { + pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals); + } + pic_apply(pic, proc, vals); + } + + return pic_none_value(); +} + +static pic_value +pic_str_list_to_string(pic_state *pic) +{ + pic_str *str; + pic_value list, e; + size_t i = 0; + + pic_get_args(pic, "o", &list); + + if (pic_length(pic, list) == 0) { + return pic_obj_value(pic_make_str(pic, NULL, 0)); + } else { + char buf[pic_length(pic, list)]; + + pic_for_each (e, list) { + pic_assert_type(pic, e, char); + + buf[i++] = pic_char(e); + } + + str = pic_make_str(pic, buf, i); + + return pic_obj_value(str); + } +} + +static pic_value +pic_str_string_to_list(pic_state *pic) +{ + pic_str *str; + pic_value list; + int n; + size_t start, end, i; + + n = pic_get_args(pic, "s|kk", &str, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = pic_strlen(str); + } + + list = pic_nil_value(); + + for (i = start; i < end; ++i) { + pic_push(pic, pic_char_value(pic_str_ref(pic, str, i)), list); + } + return pic_reverse(pic, list); +} + +void +pic_init_str(pic_state *pic) +{ + pic_defun(pic, "string?", pic_str_string_p); + pic_defun(pic, "string", pic_str_string); + pic_defun(pic, "make-string", pic_str_make_string); + pic_defun(pic, "string-length", pic_str_string_length); + pic_defun(pic, "string-ref", pic_str_string_ref); + pic_defun(pic, "string-copy", pic_str_string_copy); + pic_defun(pic, "string-append", pic_str_string_append); + pic_defun(pic, "string-map", pic_str_string_map); + pic_defun(pic, "string-for-each", pic_str_string_for_each); + pic_defun(pic, "list->string", pic_str_list_to_string); + pic_defun(pic, "string->list", pic_str_string_to_list); + + pic_defun(pic, "string=?", pic_str_string_eq); + pic_defun(pic, "string?", pic_str_string_gt); + pic_defun(pic, "string<=?", pic_str_string_le); + pic_defun(pic, "string>=?", pic_str_string_ge); +} diff --git a/extlib/benz/symbol.c b/extlib/benz/symbol.c new file mode 100644 index 00000000..115582c8 --- /dev/null +++ b/extlib/benz/symbol.c @@ -0,0 +1,163 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include +#include +#include + +#include "picrin.h" +#include "picrin/string.h" + +pic_sym +pic_intern(pic_state *pic, const char *str, size_t len) +{ + char *cstr; + xh_entry *e; + pic_sym id; + + cstr = (char *)pic_malloc(pic, len + 1); + cstr[len] = '\0'; + memcpy(cstr, str, len); + + e = xh_get_str(&pic->syms, cstr); + if (e) { + return xh_val(e, pic_sym); + } + + id = pic->sym_cnt++; + xh_put_str(&pic->syms, cstr, &id); + xh_put_int(&pic->sym_names, id, &cstr); + return id; +} + +pic_sym +pic_intern_cstr(pic_state *pic, const char *str) +{ + return pic_intern(pic, str, strlen(str)); +} + +pic_sym +pic_intern_str(pic_state *pic, pic_str *str) +{ + return pic_intern_cstr(pic, pic_str_cstr(str)); +} + +pic_sym +pic_gensym(pic_state *pic, pic_sym base) +{ + int uid = pic->uniq_sym_cnt++, len; + char *str, mark; + pic_sym uniq; + + if (pic_interned_p(pic, base)) { + mark = '@'; + } else { + mark = '.'; + } + + len = snprintf(NULL, 0, "%s%c%d", pic_symbol_name(pic, base), mark, uid); + str = pic_alloc(pic, (size_t)len + 1); + sprintf(str, "%s%c%d", pic_symbol_name(pic, base), mark, uid); + + /* don't put the symbol to pic->syms to keep it uninterned */ + uniq = pic->sym_cnt++; + xh_put_int(&pic->sym_names, uniq, &str); + + return uniq; +} + +pic_sym +pic_ungensym(pic_state *pic, pic_sym base) +{ + const char *name, *occr; + + if (pic_interned_p(pic, base)) { + return base; + } + + name = pic_symbol_name(pic, base); + if ((occr = strrchr(name, '@')) == NULL) { + pic_panic(pic, "logic flaw"); + } + return pic_intern(pic, name, (size_t)(occr - name)); +} + +bool +pic_interned_p(pic_state *pic, pic_sym sym) +{ + return sym == pic_intern_cstr(pic, pic_symbol_name(pic, sym)); +} + +const char * +pic_symbol_name(pic_state *pic, pic_sym sym) +{ + return xh_val(xh_get_int(&pic->sym_names, sym), const char *); +} + +static pic_value +pic_symbol_symbol_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_sym_p(v)); +} + +static pic_value +pic_symbol_symbol_eq_p(pic_state *pic) +{ + size_t argc, i; + pic_value *argv; + + pic_get_args(pic, "*", &argc, &argv); + + for (i = 0; i < argc; ++i) { + if (! pic_sym_p(argv[i])) { + return pic_false_value(); + } + if (! pic_eq_p(argv[i], argv[0])) { + return pic_false_value(); + } + } + return pic_true_value(); +} + +static pic_value +pic_symbol_symbol_to_string(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (! pic_sym_p(v)) { + pic_errorf(pic, "symbol->string: expected symbol"); + } + + return pic_obj_value(pic_make_str_cstr(pic, pic_symbol_name(pic, pic_sym(v)))); +} + +static pic_value +pic_symbol_string_to_symbol(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (! pic_str_p(v)) { + pic_errorf(pic, "string->symbol: expected string"); + } + + return pic_symbol_value(pic_intern_cstr(pic, pic_str_cstr(pic_str_ptr(v)))); +} + +void +pic_init_symbol(pic_state *pic) +{ + pic_defun(pic, "symbol?", pic_symbol_symbol_p); + pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string); + pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol); + + pic_defun(pic, "symbol=?", pic_symbol_symbol_eq_p); +} diff --git a/extlib/benz/system.c b/extlib/benz/system.c new file mode 100644 index 00000000..1b251661 --- /dev/null +++ b/extlib/benz/system.c @@ -0,0 +1,134 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#include "picrin.h" +#include "picrin/string.h" +#include "picrin/pair.h" +#include "picrin/cont.h" + +static pic_value +pic_system_cmdline(pic_state *pic) +{ + pic_value v = pic_nil_value(); + int i; + + pic_get_args(pic, ""); + + for (i = 0; i < pic->argc; ++i) { + size_t ai = pic_gc_arena_preserve(pic); + + v = pic_cons(pic, pic_obj_value(pic_make_str_cstr(pic, pic->argv[i])), v); + pic_gc_arena_restore(pic, ai); + } + + return pic_reverse(pic, v); +} + +static pic_value +pic_system_exit(pic_state *pic) +{ + pic_value v; + int argc, status = EXIT_SUCCESS; + + argc = pic_get_args(pic, "|o", &v); + if (argc == 1) { + switch (pic_type(v)) { + case PIC_TT_FLOAT: + status = (int)pic_float(v); + break; + case PIC_TT_INT: + status = pic_int(v); + break; + default: + break; + } + } + + pic_close(pic); + + exit(status); +} + +static pic_value +pic_system_emergency_exit(pic_state *pic) +{ + pic_value v; + int argc, status = EXIT_FAILURE; + + argc = pic_get_args(pic, "|o", &v); + if (argc == 1) { + switch (pic_type(v)) { + case PIC_TT_FLOAT: + status = (int)pic_float(v); + break; + case PIC_TT_INT: + status = pic_int(v); + break; + default: + break; + } + } + + _Exit(status); +} + +static pic_value +pic_system_getenv(pic_state *pic) +{ + char *str, *val; + + pic_get_args(pic, "z", &str); + + val = getenv(str); + + if (val == NULL) + return pic_nil_value(); + else + return pic_obj_value(pic_make_str_cstr(pic, val)); +} + +static pic_value +pic_system_getenvs(pic_state *pic) +{ + char **envp; + pic_value data = pic_nil_value(); + size_t ai = pic_gc_arena_preserve(pic); + + pic_get_args(pic, ""); + + if (! pic->envp) { + return pic_nil_value(); + } + + for (envp = pic->envp; *envp; ++envp) { + pic_str *key, *val; + size_t i; + + for (i = 0; (*envp)[i] != '='; ++i) + ; + + key = pic_make_str(pic, *envp, i); + val = pic_make_str_cstr(pic, getenv(pic_str_cstr(key))); + + /* push */ + data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, data); + } + + return data; +} + +void +pic_init_system(pic_state *pic) +{ + pic_defun(pic, "command-line", pic_system_cmdline); + pic_defun(pic, "exit", pic_system_exit); + pic_defun(pic, "emergency-exit", pic_system_emergency_exit); + pic_defun(pic, "get-environment-variable", pic_system_getenv); + pic_defun(pic, "get-environment-variables", pic_system_getenvs); +} diff --git a/extlib/benz/time.c b/extlib/benz/time.c new file mode 100644 index 00000000..83716db8 --- /dev/null +++ b/extlib/benz/time.c @@ -0,0 +1,47 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#include "picrin.h" + +#define UTC_TAI_DIFF 35 + +static pic_value +pic_current_second(pic_state *pic) +{ + time_t t; + + pic_get_args(pic, ""); + + time(&t); + return pic_float_value((double)t + UTC_TAI_DIFF); +} + +static pic_value +pic_current_jiffy(pic_state *pic) +{ + clock_t c; + + pic_get_args(pic, ""); + + c = clock(); + return pic_int_value((int)c); /* The year 2038 problem :-| */ +} + +static pic_value +pic_jiffies_per_second(pic_state *pic) +{ + pic_get_args(pic, ""); + + return pic_int_value(CLOCKS_PER_SEC); +} + +void +pic_init_time(pic_state *pic) +{ + pic_defun(pic, "current-second", pic_current_second); + pic_defun(pic, "current-jiffy", pic_current_jiffy); + pic_defun(pic, "jiffies-per-second", pic_jiffies_per_second); +} diff --git a/extlib/benz/var.c b/extlib/benz/var.c new file mode 100644 index 00000000..ea9cbff5 --- /dev/null +++ b/extlib/benz/var.c @@ -0,0 +1,110 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/pair.h" +#include "picrin/proc.h" +#include "picrin/dict.h" + +static pic_value +var_lookup(pic_state *pic, pic_value var) +{ + pic_value val, env; + struct pic_dict *binding; + + val = pic_ref(pic, pic->PICRIN_BASE, "current-dynamic-environment"); + if (pic_eq_p(val, var)) { + return pic_false_value(); + } + + env = pic_apply0(pic, pic_proc_ptr(val)); + while (! pic_nil_p(env)) { + pic_assert_type(pic, pic_car(pic, env), dict); + + binding = pic_dict_ptr(pic_car(pic, env)); + if (pic_dict_has(pic, binding, var)) { + return pic_dict_ref(pic, binding, var); + } + env = pic_cdr(pic, env); + } + + return pic_false_value(); +} + +static pic_value +var_call(pic_state *pic) +{ + struct pic_proc *self = pic_get_proc(pic); + pic_value val, tmp, box, conv; + int n; + + n = pic_get_args(pic, "|oo", &val, &tmp); + + box = var_lookup(pic, pic_obj_value(self)); + if (! pic_test(box)) { + box = pic_attr_ref(pic, pic_obj_value(self), "@@box"); + } + + switch (n) { + case 0: + return pic_car(pic, box); + + case 1: + conv = pic_attr_ref(pic, pic_obj_value(self), "@@converter"); + if (pic_test(conv)) { + pic_assert_type(pic, conv, proc); + + val = pic_apply1(pic, pic_proc_ptr(conv), val); + } + pic_set_car(pic, box, val); + + return pic_none_value(); + + case 2: + assert(pic_false_p(tmp)); + + conv = pic_attr_ref(pic, pic_obj_value(self), "@@converter"); + if (pic_test(conv)) { + pic_assert_type(pic, conv, proc); + + return pic_apply1(pic, pic_proc_ptr(conv), val); + } else { + return val; + } + } + UNREACHABLE(); +} + +struct pic_proc * +pic_make_var(pic_state *pic, pic_value init, struct pic_proc *conv) +{ + struct pic_proc *var; + + var = pic_make_proc(pic, var_call, ""); + pic_attr_set(pic, pic_obj_value(var), "@@box", pic_list1(pic, init)); + pic_attr_set(pic, pic_obj_value(var), "@@converter", conv ? pic_obj_value(conv) : pic_false_value()); + + return var; +} + +static pic_value +pic_var_make_parameter(pic_state *pic) +{ + struct pic_proc *conv = NULL; + pic_value init; + + pic_get_args(pic, "o|l", &init, &conv); + + return pic_obj_value(pic_make_var(pic, init, conv)); +} + +void +pic_init_var(pic_state *pic) +{ + pic_define_noexport(pic, "current-dynamic-environment", pic_false_value()); + + pic_defun(pic, "make-parameter", pic_var_make_parameter); + + pic_set(pic, pic->PICRIN_BASE, "current-dynamic-environment", pic_obj_value(pic_make_var(pic, pic_nil_value(), NULL))); +} diff --git a/extlib/benz/vector.c b/extlib/benz/vector.c new file mode 100644 index 00000000..33070d24 --- /dev/null +++ b/extlib/benz/vector.c @@ -0,0 +1,429 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/vector.h" +#include "picrin/string.h" +#include "picrin/pair.h" + +struct pic_vector * +pic_make_vec(pic_state *pic, size_t len) +{ + struct pic_vector *vec; + size_t i; + + vec = (struct pic_vector *)pic_obj_alloc(pic, sizeof(struct pic_vector), PIC_TT_VECTOR); + vec->len = len; + vec->data = (pic_value *)pic_alloc(pic, sizeof(pic_value) * len); + for (i = 0; i < len; ++i) { + vec->data[i] = pic_none_value(); + } + return vec; +} + +struct pic_vector * +pic_make_vec_from_list(pic_state *pic, pic_value data) +{ + struct pic_vector *vec; + size_t len, i; + + len = pic_length(pic, data); + + vec = pic_make_vec(pic, len); + for (i = 0; i < len; ++i) { + vec->data[i] = pic_car(pic, data); + data = pic_cdr(pic, data); + } + return vec; +} + +static pic_value +pic_vec_vector_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_vec_p(v)); +} + +static pic_value +pic_vec_vector(pic_state *pic) +{ + size_t argc, i; + pic_value *argv; + pic_vec *vec; + + pic_get_args(pic, "*", &argc, &argv); + + vec = pic_make_vec(pic, (size_t)argc); + + for (i = 0; i < argc; ++i) { + vec->data[i] = argv[i]; + } + + return pic_obj_value(vec); +} + +static pic_value +pic_vec_make_vector(pic_state *pic) +{ + pic_value v; + int n; + size_t k, i; + struct pic_vector *vec; + + n = pic_get_args(pic, "k|o", &k, &v); + + vec = pic_make_vec(pic, k); + if (n == 2) { + for (i = 0; i < k; ++i) { + vec->data[i] = v; + } + } + return pic_obj_value(vec); +} + +static pic_value +pic_vec_vector_length(pic_state *pic) +{ + struct pic_vector *v; + + pic_get_args(pic, "v", &v); + + return pic_size_value(v->len); +} + +static pic_value +pic_vec_vector_ref(pic_state *pic) +{ + struct pic_vector *v; + size_t k; + + pic_get_args(pic, "vk", &v, &k); + + if (v->len <= k) { + pic_errorf(pic, "vector-ref: index out of range"); + } + return v->data[k]; +} + +static pic_value +pic_vec_vector_set(pic_state *pic) +{ + struct pic_vector *v; + size_t k; + pic_value o; + + pic_get_args(pic, "vko", &v, &k, &o); + + if (v->len <= k) { + pic_errorf(pic, "vector-set!: index out of range"); + } + v->data[k] = o; + return pic_none_value(); +} + +static pic_value +pic_vec_vector_copy_i(pic_state *pic) +{ + pic_vec *to, *from; + int n; + size_t at, start, end; + + n = pic_get_args(pic, "vkv|kk", &to, &at, &from, &start, &end); + + switch (n) { + case 3: + start = 0; + case 4: + end = from->len; + } + + if (to == from && (start <= at && at < end)) { + /* copy in reversed order */ + at += end - start; + while (start < end) { + to->data[--at] = from->data[--end]; + } + return pic_none_value(); + } + + while (start < end) { + to->data[at++] = from->data[start++]; + } + + return pic_none_value(); +} + +static pic_value +pic_vec_vector_copy(pic_state *pic) +{ + pic_vec *vec, *to; + int n; + size_t start, end, i = 0; + + n = pic_get_args(pic, "v|kk", &vec, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = vec->len; + } + + if (end < start) { + pic_errorf(pic, "vector-copy: end index must not be less than start index"); + } + + to = pic_make_vec(pic, end - start); + while (start < end) { + to->data[i++] = vec->data[start++]; + } + + return pic_obj_value(to); +} + +static pic_value +pic_vec_vector_append(pic_state *pic) +{ + pic_value *argv; + size_t argc, i, j, len; + pic_vec *vec; + + pic_get_args(pic, "*", &argc, &argv); + + len = 0; + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], vec); + len += pic_vec_ptr(argv[i])->len; + } + + vec = pic_make_vec(pic, len); + + len = 0; + for (i = 0; i < argc; ++i) { + for (j = 0; j < pic_vec_ptr(argv[i])->len; ++j) { + vec->data[len + j] = pic_vec_ptr(argv[i])->data[j]; + } + len += pic_vec_ptr(argv[i])->len; + } + + return pic_obj_value(vec); +} + +static pic_value +pic_vec_vector_fill_i(pic_state *pic) +{ + pic_vec *vec; + pic_value obj; + int n; + size_t start, end; + + n = pic_get_args(pic, "vo|kk", &vec, &obj, &start, &end); + + switch (n) { + case 2: + start = 0; + case 3: + end = vec->len; + } + + while (start < end) { + vec->data[start++] = obj; + } + + return pic_none_value(); +} + +static pic_value +pic_vec_vector_map(pic_state *pic) +{ + struct pic_proc *proc; + size_t argc, i, len, j; + pic_value *argv, vals; + pic_vec *vec; + + pic_get_args(pic, "l*", &proc, &argc, &argv); + + len = INT_MAX; + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], vec); + + len = len < pic_vec_ptr(argv[i])->len + ? len + : pic_vec_ptr(argv[i])->len; + } + + vec = pic_make_vec(pic, len); + + for (i = 0; i < len; ++i) { + vals = pic_nil_value(); + for (j = 0; j < argc; ++j) { + pic_push(pic, pic_vec_ptr(argv[j])->data[i], vals); + } + vec->data[i] = pic_apply(pic, proc, vals); + } + + return pic_obj_value(vec); +} + +static pic_value +pic_vec_vector_for_each(pic_state *pic) +{ + struct pic_proc *proc; + size_t argc, i, len, j; + pic_value *argv, vals; + + pic_get_args(pic, "l*", &proc, &argc, &argv); + + len = INT_MAX; + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], vec); + + len = len < pic_vec_ptr(argv[i])->len + ? len + : pic_vec_ptr(argv[i])->len; + } + + for (i = 0; i < len; ++i) { + vals = pic_nil_value(); + for (j = 0; j < argc; ++j) { + pic_push(pic, pic_vec_ptr(argv[j])->data[i], vals); + } + pic_apply(pic, proc, vals); + } + + return pic_none_value(); +} + +static pic_value +pic_vec_list_to_vector(pic_state *pic) +{ + struct pic_vector *vec; + pic_value list, e, *data; + + pic_get_args(pic, "o", &list); + + vec = pic_make_vec(pic, pic_length(pic, list)); + + data = vec->data; + + pic_for_each (e, list) { + *data++ = e; + } + return pic_obj_value(vec); +} + +static pic_value +pic_vec_vector_to_list(pic_state *pic) +{ + struct pic_vector *vec; + pic_value list; + int n; + size_t start, end, i; + + n = pic_get_args(pic, "v|kk", &vec, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = vec->len; + } + + list = pic_nil_value(); + + for (i = start; i < end; ++i) { + pic_push(pic, vec->data[i], list); + } + return pic_reverse(pic, list); +} + +static pic_value +pic_vec_vector_to_string(pic_state *pic) +{ + pic_vec *vec; + char *buf; + int n; + size_t start, end, i; + pic_str *str; + + n = pic_get_args(pic, "v|kk", &vec, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = vec->len; + } + + if (end < start) { + pic_errorf(pic, "vector->string: end index must not be less than start index"); + } + + buf = pic_alloc(pic, end - start); + + for (i = start; i < end; ++i) { + pic_assert_type(pic, vec->data[i], char); + + buf[i - start] = pic_char(vec->data[i]); + } + + str = pic_make_str(pic, buf, end - start); + pic_free(pic, buf); + + return pic_obj_value(str); +} + +static pic_value +pic_vec_string_to_vector(pic_state *pic) +{ + pic_str *str; + int n; + size_t start, end; + size_t i; + pic_vec *vec; + + n = pic_get_args(pic, "s|kk", &str, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = pic_strlen(str); + } + + if (end < start) { + pic_errorf(pic, "string->vector: end index must not be less than start index"); + } + + vec = pic_make_vec(pic, end - start); + + for (i = 0; i < end - start; ++i) { + vec->data[i] = pic_char_value(pic_str_ref(pic, str, i + start)); + } + return pic_obj_value(vec); +} + +void +pic_init_vector(pic_state *pic) +{ + pic_defun(pic, "vector?", pic_vec_vector_p); + pic_defun(pic, "vector", pic_vec_vector); + pic_defun(pic, "make-vector", pic_vec_make_vector); + pic_defun(pic, "vector-length", pic_vec_vector_length); + pic_defun(pic, "vector-ref", pic_vec_vector_ref); + pic_defun(pic, "vector-set!", pic_vec_vector_set); + pic_defun(pic, "vector-copy!", pic_vec_vector_copy_i); + pic_defun(pic, "vector-copy", pic_vec_vector_copy); + pic_defun(pic, "vector-append", pic_vec_vector_append); + pic_defun(pic, "vector-fill!", pic_vec_vector_fill_i); + pic_defun(pic, "vector-map", pic_vec_vector_map); + pic_defun(pic, "vector-for-each", pic_vec_vector_for_each); + pic_defun(pic, "list->vector", pic_vec_list_to_vector); + pic_defun(pic, "vector->list", pic_vec_vector_to_list); + pic_defun(pic, "string->vector", pic_vec_string_to_vector); + pic_defun(pic, "vector->string", pic_vec_vector_to_string); +} diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c new file mode 100644 index 00000000..8eb67b71 --- /dev/null +++ b/extlib/benz/vm.c @@ -0,0 +1,1151 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include +#include +#include +#include + +#include "picrin.h" +#include "picrin/pair.h" +#include "picrin/string.h" +#include "picrin/vector.h" +#include "picrin/proc.h" +#include "picrin/port.h" +#include "picrin/irep.h" +#include "picrin/blob.h" +#include "picrin/lib.h" +#include "picrin/macro.h" +#include "picrin/error.h" +#include "picrin/dict.h" +#include "picrin/record.h" + +#define GET_OPERAND(pic,n) ((pic)->ci->fp[(n)]) + +struct pic_proc * +pic_get_proc(pic_state *pic) +{ + pic_value v = GET_OPERAND(pic,0); + + if (! pic_proc_p(v)) { + pic_errorf(pic, "fatal error"); + } + return pic_proc_ptr(v); +} + +/** + * char type desc. + * ---- ---- ---- + * o pic_value * object + * i int * int + * I int *, bool * int with exactness + * k size_t * size_t implicitly converted from int + * f double * float + * F double *, bool * float with exactness + * s pic_str ** string object + * z char ** c string + * m pic_sym * symbol + * v pic_vec ** vector object + * b pic_blob ** bytevector object + * c char * char + * l struct pic_proc ** lambda object + * p struct pic_port ** port object + * d struct pic_dict ** dictionary object + * e struct pic_error ** error object + * + * | optional operator + * * size_t *, pic_value ** variable length operator + */ + +int +pic_get_args(pic_state *pic, const char *format, ...) +{ + char c; + int i = 1, argc = pic->ci->argc; + va_list ap; + bool opt = false; + + va_start(ap, format); + while ((c = *format++)) { + switch (c) { + default: + if (argc <= i && ! opt) { + pic_errorf(pic, "wrong number of arguments"); + } + break; + case '|': + break; + case '*': + break; + } + + /* in order to run out of all arguments passed to this function + (i.e. do va_arg for each argument), optional argument existence + check is done in every case closure */ + + if (c == '*') + break; + + switch (c) { + case '|': + opt = true; + break; + case 'o': { + pic_value *p; + + p = va_arg(ap, pic_value*); + if (i < argc) { + *p = GET_OPERAND(pic,i); + i++; + } + break; + } + case 'f': { + double *f; + + f = va_arg(ap, double *); + if (i < argc) { + pic_value v; + + v = GET_OPERAND(pic, i); + switch (pic_type(v)) { + case PIC_TT_FLOAT: + *f = pic_float(v); + break; + case PIC_TT_INT: + *f = pic_int(v); + break; + default: + pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); + } + i++; + } + break; + } + case 'F': { + double *f; + bool *e; + + f = va_arg(ap, double *); + e = va_arg(ap, bool *); + if (i < argc) { + pic_value v; + + v = GET_OPERAND(pic, i); + switch (pic_type(v)) { + case PIC_TT_FLOAT: + *f = pic_float(v); + *e = false; + break; + case PIC_TT_INT: + *f = pic_int(v); + *e = true; + break; + default: + pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); + } + i++; + } + break; + } + case 'I': { + int *k; + bool *e; + + k = va_arg(ap, int *); + e = va_arg(ap, bool *); + if (i < argc) { + pic_value v; + + v = GET_OPERAND(pic, i); + switch (pic_type(v)) { + case PIC_TT_FLOAT: + *k = (int)pic_float(v); + *e = false; + break; + case PIC_TT_INT: + *k = pic_int(v); + *e = true; + break; + default: + pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); + } + i++; + } + break; + } + case 'i': { + int *k; + + k = va_arg(ap, int *); + if (i < argc) { + pic_value v; + + v = GET_OPERAND(pic, i); + switch (pic_type(v)) { + case PIC_TT_FLOAT: + *k = (int)pic_float(v); + break; + case PIC_TT_INT: + *k = pic_int(v); + break; + default: + pic_errorf(pic, "pic_get_args: expected int, but got ~s", v); + } + i++; + } + break; + } + case 'k': { + size_t *k; + + k = va_arg(ap, size_t *); + if (i < argc) { + pic_value v; + int x; + + v = GET_OPERAND(pic, i); + switch (pic_type(v)) { + case PIC_TT_INT: + x = pic_int(v); + if (x < 0) { + pic_errorf(pic, "pic_get_args: expected non-negative int, but got ~s", v); + } + if (sizeof(unsigned) > sizeof(size_t)) { + if ((unsigned)x > (unsigned)SIZE_MAX) { + pic_errorf(pic, "pic_get_args: int unrepresentable with size_t ~s", v); + } + } + *k = (size_t)x; + break; + default: + pic_errorf(pic, "pic_get_args: expected int, but got ~s", v); + } + i++; + } + break; + } + case 's': { + pic_str **str; + pic_value v; + + str = va_arg(ap, pic_str **); + if (i < argc) { + v = GET_OPERAND(pic,i); + if (pic_str_p(v)) { + *str = pic_str_ptr(v); + } + else { + pic_errorf(pic, "pic_get_args: expected string, but got ~s", v); + } + i++; + } + break; + } + case 'z': { + const char **cstr; + pic_value v; + + cstr = va_arg(ap, const char **); + if (i < argc) { + v = GET_OPERAND(pic,i); + if (! pic_str_p(v)) { + pic_errorf(pic, "pic_get_args: expected string, but got ~s", v); + } + *cstr = pic_str_cstr(pic_str_ptr(v)); + i++; + } + break; + } + case 'm': { + pic_sym *m; + pic_value v; + + m = va_arg(ap, pic_sym *); + if (i < argc) { + v = GET_OPERAND(pic,i); + if (pic_sym_p(v)) { + *m = pic_sym(v); + } + else { + pic_errorf(pic, "pic_get_args: expected symbol, but got ~s", v); + } + i++; + } + break; + } + case 'v': { + struct pic_vector **vec; + pic_value v; + + vec = va_arg(ap, struct pic_vector **); + if (i < argc) { + v = GET_OPERAND(pic,i); + if (pic_vec_p(v)) { + *vec = pic_vec_ptr(v); + } + else { + pic_errorf(pic, "pic_get_args: expected vector, but got ~s", v); + } + i++; + } + break; + } + case 'b': { + struct pic_blob **b; + pic_value v; + + b = va_arg(ap, struct pic_blob **); + if (i < argc) { + v = GET_OPERAND(pic,i); + if (pic_blob_p(v)) { + *b = pic_blob_ptr(v); + } + else { + pic_errorf(pic, "pic_get_args: expected bytevector, but got ~s", v); + } + i++; + } + break; + } + case 'c': { + char *k; + pic_value v; + + k = va_arg(ap, char *); + if (i < argc) { + v = GET_OPERAND(pic,i); + if (pic_char_p(v)) { + *k = pic_char(v); + } + else { + pic_errorf(pic, "pic_get_args: expected char, but got ~s", v); + } + i++; + } + break; + } + case 'l': { + struct pic_proc **l; + pic_value v; + + l = va_arg(ap, struct pic_proc **); + if (i < argc) { + v = GET_OPERAND(pic,i); + if (pic_proc_p(v)) { + *l = pic_proc_ptr(v); + } + else { + pic_errorf(pic, "pic_get_args, expected procedure, but got ~s", v); + } + i++; + } + break; + } + case 'p': { + struct pic_port **p; + pic_value v; + + p = va_arg(ap, struct pic_port **); + if (i < argc) { + v = GET_OPERAND(pic,i); + if (pic_port_p(v)) { + *p = pic_port_ptr(v); + } + else { + pic_errorf(pic, "pic_get_args, expected port, but got ~s", v); + } + i++; + } + break; + } + case 'd': { + struct pic_dict **d; + pic_value v; + + d = va_arg(ap, struct pic_dict **); + if (i < argc) { + v = GET_OPERAND(pic,i); + if (pic_dict_p(v)) { + *d = pic_dict_ptr(v); + } + else { + pic_errorf(pic, "pic_get_args, expected dictionary, but got ~s", v); + } + i++; + } + break; + } + case 'r': { + struct pic_record **r; + pic_value v; + + r = va_arg(ap, struct pic_record **); + if (i < argc) { + v = GET_OPERAND(pic,i); + if (pic_record_p(v)) { + *r = pic_record_ptr(v); + } + else { + pic_errorf(pic, "pic_get_args: expected record, but got ~s", v); + } + i++; + } + break; + } + case 'e': { + struct pic_error **e; + pic_value v; + + e = va_arg(ap, struct pic_error **); + if (i < argc) { + v = GET_OPERAND(pic,i); + if (pic_error_p(v)) { + *e = pic_error_ptr(v); + } + else { + pic_errorf(pic, "pic_get_args, expected error"); + } + i++; + } + break; + } + default: + pic_errorf(pic, "pic_get_args: invalid argument specifier '%c' given", c); + } + } + if ('*' == c) { + size_t *n; + pic_value **argv; + + n = va_arg(ap, size_t *); + argv = va_arg(ap, pic_value **); + if (i <= argc) { + *n = (size_t)(argc - i); + *argv = &GET_OPERAND(pic, i); + i = argc; + } + } + else if (argc > i) { + pic_errorf(pic, "wrong number of arguments"); + } + va_end(ap); + return i - 1; +} + +void +pic_define_noexport(pic_state *pic, const char *name, pic_value val) +{ + pic_sym sym, rename; + + sym = pic_intern_cstr(pic, name); + + if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) { + rename = pic_add_rename(pic, pic->lib->env, sym); + } else { + pic_warn(pic, "redefining global"); + } + + xh_put_int(&pic->globals, rename, &val); +} + +void +pic_define(pic_state *pic, const char *name, pic_value val) +{ + pic_define_noexport(pic, name, val); + + pic_export(pic, pic_intern_cstr(pic, name)); +} + +pic_value +pic_ref(pic_state *pic, struct pic_lib *lib, const char *name) +{ + pic_sym sym, rename; + + sym = pic_intern_cstr(pic, name); + + if (! pic_find_rename(pic, lib->env, sym, &rename)) { + pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); + } + + return xh_val(xh_get_int(&pic->globals, rename), pic_value); +} + +void +pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val) +{ + pic_sym sym, rename; + + sym = pic_intern_cstr(pic, name); + + if (! pic_find_rename(pic, lib->env, sym, &rename)) { + pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); + } + + xh_put_int(&pic->globals, rename, &val); +} + +pic_value +pic_funcall(pic_state *pic, struct pic_lib *lib, const char *name, pic_list args) +{ + pic_value proc; + + proc = pic_ref(pic, lib, name); + + pic_assert_type(pic, proc, proc); + + return pic_apply(pic, pic_proc_ptr(proc), args); +} + +void +pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) +{ + struct pic_proc *proc; + + proc = pic_make_proc(pic, cfunc, name); + pic_define(pic, name, pic_obj_value(proc)); +} + +void +pic_defvar(pic_state *pic, const char *name, pic_value init, struct pic_proc *conv) +{ + pic_define(pic, name, pic_obj_value(pic_make_var(pic, init, conv))); +} + +static void +vm_push_env(pic_state *pic) +{ + pic_callinfo *ci = pic->ci; + + ci->env = (struct pic_env *)pic_obj_alloc(pic, offsetof(struct pic_env, storage) + sizeof(pic_value) * (size_t)(ci->regc), PIC_TT_ENV); + ci->env->up = ci->up; + ci->env->regc = ci->regc; + ci->env->regs = ci->regs; +} + +static void +vm_tear_off(pic_callinfo *ci) +{ + struct pic_env *env; + int i; + + assert(ci->env != NULL); + + env = ci->env; + + if (env->regs == env->storage) { + return; /* is torn off */ + } + for (i = 0; i < env->regc; ++i) { + env->storage[i] = env->regs[i]; + } + env->regs = env->storage; +} + +void +pic_vm_tear_off(pic_state *pic) +{ + pic_callinfo *ci; + + for (ci = pic->ci; ci > pic->cibase; ci--) { + if (ci->env != NULL) { + vm_tear_off(ci); + } + } +} + +pic_value +pic_apply0(pic_state *pic, struct pic_proc *proc) +{ + return pic_apply(pic, proc, pic_nil_value()); +} + +pic_value +pic_apply1(pic_state *pic, struct pic_proc *proc, pic_value arg1) +{ + return pic_apply(pic, proc, pic_list1(pic, arg1)); +} + +pic_value +pic_apply2(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2) +{ + return pic_apply(pic, proc, pic_list2(pic, arg1, arg2)); +} + +pic_value +pic_apply3(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3) +{ + return pic_apply(pic, proc, pic_list3(pic, arg1, arg2, arg3)); +} + +pic_value +pic_apply4(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4) +{ + return pic_apply(pic, proc, pic_list4(pic, arg1, arg2, arg3, arg4)); +} + +pic_value +pic_apply5(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4, pic_value arg5) +{ + return pic_apply(pic, proc, pic_list5(pic, arg1, arg2, arg3, arg4, arg5)); +} + +#if VM_DEBUG +# define OPCODE_EXEC_HOOK pic_dump_code(c) +#else +# define OPCODE_EXEC_HOOK ((void)0) +#endif + +#if PIC_DIRECT_THREADED_VM +# define VM_LOOP JUMP; +# define CASE(x) L_##x: OPCODE_EXEC_HOOK; +# define NEXT pic->ip++; JUMP; +# define JUMP c = *pic->ip; goto *oplabels[c.insn]; +# define VM_LOOP_END +#else +# define VM_LOOP for (;;) { c = *pic->ip; switch (c.insn) { +# define CASE(x) case x: +# define NEXT pic->ip++; break +# define JUMP break +# define VM_LOOP_END } } +#endif + +#define PUSH(v) (*pic->sp++ = (v)) +#define POP() (*--pic->sp) + +#define PUSHCI() (++pic->ci) +#define POPCI() (pic->ci--) + +#if VM_DEBUG +# define VM_BOOT_PRINT \ + do { \ + puts("### booting VM... ###"); \ + stbase = pic->sp; \ + cibase = pic->ci; \ + } while (0) +#else +# define VM_BOOT_PRINT +#endif + +#if VM_DEBUG +# define VM_END_PRINT \ + do { \ + puts("**VM END STATE**"); \ + printf("stbase\t= %p\nsp\t= %p\n", (void *)stbase, (void *)pic->sp); \ + printf("cibase\t= %p\nci\t= %p\n", (void *)cibase, (void *)pic->ci); \ + if (stbase < pic->sp - 1) { \ + pic_value *sp; \ + printf("* stack trace:"); \ + for (sp = stbase; pic->sp != sp; ++sp) { \ + pic_debug(pic, *sp); \ + puts(""); \ + } \ + } \ + if (stbase > pic->sp - 1) { \ + puts("*** stack underflow!"); \ + } \ + } while (0) +#else +# define VM_END_PRINT +#endif + +#if VM_DEBUG +# define VM_CALL_PRINT \ + do { \ + puts("\n== calling proc..."); \ + printf(" proc = "); \ + pic_debug(pic, pic_obj_value(proc)); \ + puts(""); \ + printf(" argv = ("); \ + for (short i = 1; i < c.u.i; ++i) { \ + if (i > 1) \ + printf(" "); \ + pic_debug(pic, pic->sp[-c.u.i + i]); \ + } \ + puts(")"); \ + if (! pic_proc_func_p(proc)) { \ + printf(" irep = %p\n", proc->u.irep); \ + printf(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); \ + pic_dump_irep(proc->u.irep); \ + } \ + else { \ + printf(" cfunc = %p\n", (void *)proc->u.func.f); \ + printf(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); \ + } \ + puts("== end\n"); \ + } while (0) +#else +# define VM_CALL_PRINT +#endif + +pic_value +pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) +{ + pic_code c; + size_t ai = pic_gc_arena_preserve(pic); + pic_code boot[2]; + +#if PIC_DIRECT_THREADED_VM + static void *oplabels[] = { + &&L_OP_NOP, &&L_OP_POP, &&L_OP_PUSHNIL, &&L_OP_PUSHTRUE, &&L_OP_PUSHFALSE, + &&L_OP_PUSHINT, &&L_OP_PUSHCHAR, &&L_OP_PUSHCONST, + &&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF, &&L_OP_LSET, &&L_OP_CREF, &&L_OP_CSET, + &&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_NOT, &&L_OP_CALL, &&L_OP_TAILCALL, &&L_OP_RET, + &&L_OP_LAMBDA, &&L_OP_CONS, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP, + &&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV, &&L_OP_MINUS, + &&L_OP_EQ, &&L_OP_LT, &&L_OP_LE, &&L_OP_STOP + }; +#endif + +#if VM_DEBUG + pic_value *stbase; + pic_callinfo *cibase; +#endif + + if (! pic_list_p(args)) { + pic_errorf(pic, "argv must be a proper list"); + } + else { + int argc, i; + + argc = (int)pic_length(pic, args) + 1; + + VM_BOOT_PRINT; + + PUSH(pic_obj_value(proc)); + for (i = 1; i < argc; ++i) { + PUSH(pic_car(pic, args)); + args = pic_cdr(pic, args); + } + + /* boot! */ + boot[0].insn = OP_CALL; + boot[0].u.i = argc; + boot[1].insn = OP_STOP; + pic->ip = boot; + } + + VM_LOOP { + CASE(OP_NOP) { + NEXT; + } + CASE(OP_POP) { + (void)(POP()); + NEXT; + } + CASE(OP_PUSHNIL) { + PUSH(pic_nil_value()); + NEXT; + } + CASE(OP_PUSHTRUE) { + PUSH(pic_true_value()); + NEXT; + } + CASE(OP_PUSHFALSE) { + PUSH(pic_false_value()); + NEXT; + } + CASE(OP_PUSHINT) { + PUSH(pic_int_value(c.u.i)); + NEXT; + } + CASE(OP_PUSHCHAR) { + PUSH(pic_char_value(c.u.c)); + NEXT; + } + CASE(OP_PUSHCONST) { + pic_value self; + struct pic_irep *irep; + + self = pic->ci->fp[0]; + if (! pic_proc_p(self)) { + pic_errorf(pic, "logic flaw"); + } + irep = pic_proc_ptr(self)->u.irep; + if (! pic_proc_irep_p(pic_proc_ptr(self))) { + pic_errorf(pic, "logic flaw"); + } + PUSH(irep->pool[c.u.i]); + NEXT; + } + CASE(OP_GREF) { + xh_entry *e; + + if ((e = xh_get_int(&pic->globals, c.u.i)) == NULL) { + pic_errorf(pic, "logic flaw; reference to uninitialized global variable: %s", pic_symbol_name(pic, c.u.i)); + } + PUSH(xh_val(e, pic_value)); + NEXT; + } + CASE(OP_GSET) { + pic_value val; + + val = POP(); + xh_put_int(&pic->globals, c.u.i, &val); + NEXT; + } + CASE(OP_LREF) { + pic_callinfo *ci = pic->ci; + struct pic_irep *irep; + + if (ci->env != NULL && ci->env->regs == ci->env->storage) { + irep = pic_get_proc(pic)->u.irep; + if (c.u.i >= irep->argc + irep->localc) { + PUSH(ci->env->regs[c.u.i - (ci->regs - ci->fp)]); + NEXT; + } + } + PUSH(pic->ci->fp[c.u.i]); + NEXT; + } + CASE(OP_LSET) { + pic_callinfo *ci = pic->ci; + struct pic_irep *irep; + + if (ci->env != NULL && ci->env->regs == ci->env->storage) { + irep = pic_get_proc(pic)->u.irep; + if (c.u.i >= irep->argc + irep->localc) { + ci->env->regs[c.u.i - (ci->regs - ci->fp)] = POP(); + NEXT; + } + } + pic->ci->fp[c.u.i] = POP(); + NEXT; + } + CASE(OP_CREF) { + int depth = c.u.r.depth; + struct pic_env *env; + + env = pic->ci->up; + while (--depth) { + env = env->up; + } + PUSH(env->regs[c.u.r.idx]); + NEXT; + } + CASE(OP_CSET) { + int depth = c.u.r.depth; + struct pic_env *env; + + env = pic->ci->up; + while (--depth) { + env = env->up; + } + env->regs[c.u.r.idx] = POP(); + NEXT; + } + CASE(OP_JMP) { + pic->ip += c.u.i; + JUMP; + } + CASE(OP_JMPIF) { + pic_value v; + + v = POP(); + if (! pic_false_p(v)) { + pic->ip += c.u.i; + JUMP; + } + NEXT; + } + CASE(OP_NOT) { + pic_value v; + + v = pic_false_p(POP()) ? pic_true_value() : pic_false_value(); + PUSH(v); + NEXT; + } + CASE(OP_CALL) { + pic_value x, v; + pic_callinfo *ci; + + if (c.u.i == -1) { + pic->sp += pic->ci[1].retc - 1; + c.u.i = pic->ci[1].retc + 1; + } + + L_CALL: + x = pic->sp[-c.u.i]; + if (! pic_proc_p(x)) { + pic_errorf(pic, "invalid application: ~s", x); + } + proc = pic_proc_ptr(x); + + VM_CALL_PRINT; + + if (pic->sp >= pic->stend) { + pic_panic(pic, "VM stack overflow"); + } + + ci = PUSHCI(); + ci->argc = c.u.i; + ci->retc = 1; + ci->ip = pic->ip; + ci->fp = pic->sp - c.u.i; + ci->env = NULL; + if (pic_proc_func_p(pic_proc_ptr(x))) { + + /* invoke! */ + v = proc->u.func.f(pic); + pic->sp[0] = v; + pic->sp += pic->ci->retc; + + pic_gc_arena_restore(pic, ai); + goto L_RET; + } + else { + struct pic_irep *irep = proc->u.irep; + int i; + pic_value rest; + + if (ci->argc != irep->argc) { + if (! (irep->varg && ci->argc >= irep->argc)) { + pic_errorf(pic, "wrong number of arguments (%d for %d%s)", ci->argc - 1, irep->argc - 1, (irep->varg ? "+" : "")); + } + } + /* prepare rest args */ + if (irep->varg) { + rest = pic_nil_value(); + for (i = 0; i < ci->argc - irep->argc; ++i) { + pic_gc_protect(pic, v = POP()); + rest = pic_cons(pic, v, rest); + } + PUSH(rest); + } + /* prepare local variable area */ + if (irep->localc > 0) { + int l = irep->localc; + if (irep->varg) { + --l; + } + for (i = 0; i < l; ++i) { + PUSH(pic_undef_value()); + } + } + + /* prepare env */ + ci->up = proc->env; + ci->regc = irep->capturec; + ci->regs = ci->fp + irep->argc + irep->localc; + + pic->ip = irep->code; + pic_gc_arena_restore(pic, ai); + JUMP; + } + } + CASE(OP_TAILCALL) { + int i, argc; + pic_value *argv; + pic_callinfo *ci; + + if (pic->ci->env != NULL) { + vm_tear_off(pic->ci); + } + + if (c.u.i == -1) { + pic->sp += pic->ci[1].retc - 1; + c.u.i = pic->ci[1].retc + 1; + } + + argc = c.u.i; + argv = pic->sp - argc; + for (i = 0; i < argc; ++i) { + pic->ci->fp[i] = argv[i]; + } + ci = POPCI(); + pic->sp = ci->fp + argc; + pic->ip = ci->ip; + + /* c is not changed */ + goto L_CALL; + } + CASE(OP_RET) { + int i, retc; + pic_value *retv; + pic_callinfo *ci; + + if (pic->ci->env != NULL) { + vm_tear_off(pic->ci); + } + + pic->ci->retc = c.u.i; + + L_RET: + retc = pic->ci->retc; + retv = pic->sp - retc; + if (retc == 0) { + pic->ci->fp[0] = retv[0]; /* copy at least once */ + } + for (i = 0; i < retc; ++i) { + pic->ci->fp[i] = retv[i]; + } + ci = POPCI(); + pic->sp = ci->fp + 1; /* advance only one! */ + pic->ip = ci->ip; + + NEXT; + } + CASE(OP_LAMBDA) { + pic_value self; + struct pic_irep *irep; + + self = pic->ci->fp[0]; + if (! pic_proc_p(self)) { + pic_errorf(pic, "logic flaw"); + } + irep = pic_proc_ptr(self)->u.irep; + if (! pic_proc_irep_p(pic_proc_ptr(self))) { + pic_errorf(pic, "logic flaw"); + } + + if (pic->ci->env == NULL) { + vm_push_env(pic); + } + + proc = pic_make_proc_irep(pic, irep->irep[c.u.i], pic->ci->env); + PUSH(pic_obj_value(proc)); + pic_gc_arena_restore(pic, ai); + NEXT; + } + CASE(OP_CONS) { + pic_value a, b; + pic_gc_protect(pic, b = POP()); + pic_gc_protect(pic, a = POP()); + PUSH(pic_cons(pic, a, b)); + pic_gc_arena_restore(pic, ai); + NEXT; + } + CASE(OP_CAR) { + pic_value p; + p = POP(); + PUSH(pic_car(pic, p)); + NEXT; + } + CASE(OP_CDR) { + pic_value p; + p = POP(); + PUSH(pic_cdr(pic, p)); + NEXT; + } + CASE(OP_NILP) { + pic_value p; + p = POP(); + PUSH(pic_bool_value(pic_nil_p(p))); + NEXT; + } + +#define DEFINE_ARITH_OP(opcode, op, guard) \ + CASE(opcode) { \ + pic_value a, b; \ + b = POP(); \ + a = POP(); \ + if (pic_int_p(a) && pic_int_p(b)) { \ + double f = (double)pic_int(a) op (double)pic_int(b); \ + if (INT_MIN <= f && f <= INT_MAX && (guard)) { \ + PUSH(pic_int_value((int)f)); \ + } \ + else { \ + PUSH(pic_float_value(f)); \ + } \ + } \ + else if (pic_float_p(a) && pic_float_p(b)) { \ + PUSH(pic_float_value(pic_float(a) op pic_float(b))); \ + } \ + else if (pic_int_p(a) && pic_float_p(b)) { \ + PUSH(pic_float_value(pic_int(a) op pic_float(b))); \ + } \ + else if (pic_float_p(a) && pic_int_p(b)) { \ + PUSH(pic_float_value(pic_float(a) op pic_int(b))); \ + } \ + else { \ + pic_errorf(pic, #op " got non-number operands"); \ + } \ + NEXT; \ + } + + DEFINE_ARITH_OP(OP_ADD, +, true); + DEFINE_ARITH_OP(OP_SUB, -, true); + DEFINE_ARITH_OP(OP_MUL, *, true); + DEFINE_ARITH_OP(OP_DIV, /, f == round(f)); + + CASE(OP_MINUS) { + pic_value n; + n = POP(); + if (pic_int_p(n)) { + PUSH(pic_int_value(-pic_int(n))); + } + else if (pic_float_p(n)) { + PUSH(pic_float_value(-pic_float(n))); + } + else { + pic_errorf(pic, "unary - got a non-number operand"); + } + NEXT; + } + +#define DEFINE_COMP_OP(opcode, op) \ + CASE(opcode) { \ + pic_value a, b; \ + b = POP(); \ + a = POP(); \ + if (pic_int_p(a) && pic_int_p(b)) { \ + PUSH(pic_bool_value(pic_int(a) op pic_int(b))); \ + } \ + else if (pic_float_p(a) && pic_float_p(b)) { \ + PUSH(pic_bool_value(pic_float(a) op pic_float(b))); \ + } \ + else if (pic_int_p(a) && pic_float_p(b)) { \ + PUSH(pic_bool_value(pic_int(a) op pic_float(b))); \ + } \ + else if (pic_float_p(a) && pic_int_p(b)) { \ + PUSH(pic_bool_value(pic_float(a) op pic_int(b))); \ + } \ + else { \ + pic_errorf(pic, #op " got non-number operands"); \ + } \ + NEXT; \ + } + + DEFINE_COMP_OP(OP_EQ, ==); + DEFINE_COMP_OP(OP_LT, <); + DEFINE_COMP_OP(OP_LE, <=); + + CASE(OP_STOP) { + + VM_END_PRINT; + + return pic_gc_protect(pic, POP()); + } + } VM_LOOP_END; +} + +pic_value +pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args) +{ + static const pic_code iseq[2] = { + { OP_NOP, { .i = 0 } }, + { OP_TAILCALL, { .i = -1 } } + }; + + pic_value v, *sp; + pic_callinfo *ci; + + *pic->sp++ = pic_obj_value(proc); + + sp = pic->sp; + pic_for_each (v, args) { + *sp++ = v; + } + + ci = PUSHCI(); + ci->ip = (pic_code *)iseq; + ci->fp = pic->sp; + ci->retc = (int)pic_length(pic, args); + + if (ci->retc == 0) { + return pic_none_value(); + } else { + return pic_car(pic, args); + } +} diff --git a/extlib/benz/write.c b/extlib/benz/write.c new file mode 100644 index 00000000..fb01addc --- /dev/null +++ b/extlib/benz/write.c @@ -0,0 +1,504 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include + +#include "picrin.h" +#include "picrin/port.h" +#include "picrin/pair.h" +#include "picrin/string.h" +#include "picrin/vector.h" +#include "picrin/blob.h" +#include "picrin/dict.h" +#include "picrin/record.h" +#include "picrin/proc.h" + +static bool +is_tagged(pic_state *pic, pic_sym tag, pic_value pair) +{ + return pic_pair_p(pic_cdr(pic, pair)) + && pic_nil_p(pic_cddr(pic, pair)) + && pic_eq_p(pic_car(pic, pair), pic_symbol_value(tag)); +} + +static bool +is_quote(pic_state *pic, pic_value pair) +{ + return is_tagged(pic, pic->sQUOTE, pair); +} + +static bool +is_unquote(pic_state *pic, pic_value pair) +{ + return is_tagged(pic, pic->sUNQUOTE, pair); +} + +static bool +is_unquote_splicing(pic_state *pic, pic_value pair) +{ + return is_tagged(pic, pic->sUNQUOTE_SPLICING, pair); +} + +static bool +is_quasiquote(pic_state *pic, pic_value pair) +{ + return is_tagged(pic, pic->sQUASIQUOTE, pair); +} + +struct writer_control { + pic_state *pic; + xFILE *file; + int mode; + xhash labels; /* object -> int */ + xhash visited; /* object -> int */ + int cnt; +}; + +#define WRITE_MODE 1 +#define DISPLAY_MODE 2 + +static void +writer_control_init(struct writer_control *p, pic_state *pic, xFILE *file, int mode) +{ + p->pic = pic; + p->file = file; + p->mode = mode; + p->cnt = 0; + xh_init_ptr(&p->labels, sizeof(int)); + xh_init_ptr(&p->visited, sizeof(int)); +} + +static void +writer_control_destroy(struct writer_control *p) +{ + xh_destroy(&p->labels); + xh_destroy(&p->visited); +} + +static void +traverse_shared(struct writer_control *p, pic_value obj) +{ + xh_entry *e; + size_t i; + int c; + + switch (pic_type(obj)) { + case PIC_TT_PAIR: + case PIC_TT_VECTOR: + e = xh_get_ptr(&p->labels, pic_obj_ptr(obj)); + if (e == NULL) { + c = -1; + xh_put_ptr(&p->labels, pic_obj_ptr(obj), &c); + } + else if (xh_val(e, int) == -1) { + c = p->cnt++; + xh_put_ptr(&p->labels, pic_obj_ptr(obj), &c); + break; + } + else { + break; + } + + if (pic_pair_p(obj)) { + traverse_shared(p, pic_car(p->pic, obj)); + traverse_shared(p, pic_cdr(p->pic, obj)); + } + else { + for (i = 0; i < pic_vec_ptr(obj)->len; ++i) { + traverse_shared(p, pic_vec_ptr(obj)->data[i]); + } + } + break; + default: + /* pass */ + break; + } +} + +static void write_core(struct writer_control *p, pic_value); + +static void +write_pair(struct writer_control *p, struct pic_pair *pair) +{ + xh_entry *e; + int c; + + write_core(p, pair->car); + + if (pic_nil_p(pair->cdr)) { + return; + } + else if (pic_pair_p(pair->cdr)) { + + /* shared objects */ + if ((e = xh_get_ptr(&p->labels, pic_obj_ptr(pair->cdr))) && xh_val(e, int) != -1) { + xfprintf(p->file, " . "); + + if ((xh_get_ptr(&p->visited, pic_obj_ptr(pair->cdr)))) { + xfprintf(p->file, "#%d#", xh_val(e, int)); + return; + } + else { + xfprintf(p->file, "#%d=", xh_val(e, int)); + c = 1; + xh_put_ptr(&p->visited, pic_obj_ptr(pair->cdr), &c); + } + } + else { + xfprintf(p->file, " "); + } + + write_pair(p, pic_pair_ptr(pair->cdr)); + return; + } + else { + xfprintf(p->file, " . "); + write_core(p, pair->cdr); + } +} + +static void +write_str(pic_state *pic, struct pic_string *str, xFILE *file) +{ + size_t i; + const char *cstr = pic_str_cstr(str); + + UNUSED(pic); + + for (i = 0; i < pic_strlen(str); ++i) { + if (cstr[i] == '"' || cstr[i] == '\\') { + xfputc('\\', file); + } + xfputc(cstr[i], file); + } +} + +static void +write_record(pic_state *pic, struct pic_record *rec, xFILE *file) +{ + const pic_sym sWRITER = pic_intern_cstr(pic, "writer"); + pic_value type, writer, str; + +#if DEBUG + + xfprintf(file, "#", rec); + +#else + + type = pic_record_type(pic, rec); + if (! pic_record_p(type)) { + pic_errorf(pic, "\"@@type\" property of record object is not of record type"); + } + writer = pic_record_ref(pic, pic_record_ptr(type), sWRITER); + if (! pic_proc_p(writer)) { + pic_errorf(pic, "\"writer\" property of record type object is not a procedure"); + } + str = pic_apply1(pic, pic_proc_ptr(writer), pic_obj_value(rec)); + if (! pic_str_p(str)) { + pic_errorf(pic, "return value from writer procedure is not of string type"); + } + xfprintf(file, "%s", pic_str_cstr(pic_str_ptr(str))); + +#endif +} + +static void +write_core(struct writer_control *p, pic_value obj) +{ + pic_state *pic = p->pic; + xFILE *file = p->file; + size_t i; + xh_entry *e, *it; + int c; + double f; + + /* shared objects */ + if (pic_vtype(obj) == PIC_VTYPE_HEAP + && (e = xh_get_ptr(&p->labels, pic_obj_ptr(obj))) + && xh_val(e, int) != -1) { + if ((xh_get_ptr(&p->visited, pic_obj_ptr(obj)))) { + xfprintf(file, "#%d#", xh_val(e, int)); + return; + } + else { + xfprintf(file, "#%d=", xh_val(e, int)); + c = 1; + xh_put_ptr(&p->visited, pic_obj_ptr(obj), &c); + } + } + + switch (pic_type(obj)) { + case PIC_TT_UNDEF: + xfprintf(file, "#"); + break; + case PIC_TT_NIL: + xfprintf(file, "()"); + break; + case PIC_TT_BOOL: + if (pic_true_p(obj)) + xfprintf(file, "#t"); + else + xfprintf(file, "#f"); + break; + case PIC_TT_PAIR: + if (is_quote(pic, obj)) { + xfprintf(file, "'"); + write_core(p, pic_list_ref(pic, obj, 1)); + break; + } + else if (is_unquote(pic, obj)) { + xfprintf(file, ","); + write_core(p, pic_list_ref(pic, obj, 1)); + break; + } + else if (is_unquote_splicing(pic, obj)) { + xfprintf(file, ",@"); + write_core(p, pic_list_ref(pic, obj, 1)); + break; + } + else if (is_quasiquote(pic, obj)) { + xfprintf(file, "`"); + write_core(p, pic_list_ref(pic, obj, 1)); + break; + } + xfprintf(file, "("); + write_pair(p, pic_pair_ptr(obj)); + xfprintf(file, ")"); + break; + case PIC_TT_SYMBOL: + xfprintf(file, "%s", pic_symbol_name(pic, pic_sym(obj))); + break; + case PIC_TT_CHAR: + if (p->mode == DISPLAY_MODE) { + xfputc(pic_char(obj), file); + break; + } + switch (pic_char(obj)) { + default: xfprintf(file, "#\\%c", pic_char(obj)); break; + case '\a': xfprintf(file, "#\\alarm"); break; + case '\b': xfprintf(file, "#\\backspace"); break; + case 0x7f: xfprintf(file, "#\\delete"); break; + case 0x1b: xfprintf(file, "#\\escape"); break; + case '\n': xfprintf(file, "#\\newline"); break; + case '\r': xfprintf(file, "#\\return"); break; + case ' ': xfprintf(file, "#\\space"); break; + case '\t': xfprintf(file, "#\\tab"); break; + } + break; + case PIC_TT_FLOAT: + f = pic_float(obj); + if (isnan(f)) { + xfprintf(file, signbit(f) ? "-nan.0" : "+nan.0"); + } else if (isinf(f)) { + xfprintf(file, signbit(f) ? "-inf.0" : "+inf.0"); + } else { + xfprintf(file, "%f", pic_float(obj)); + } + break; + case PIC_TT_INT: + xfprintf(file, "%d", pic_int(obj)); + break; + case PIC_TT_EOF: + xfprintf(file, "#.(eof-object)"); + break; + case PIC_TT_STRING: + if (p->mode == DISPLAY_MODE) { + xfprintf(file, "%s", pic_str_cstr(pic_str_ptr(obj))); + break; + } + xfprintf(file, "\""); + write_str(pic, pic_str_ptr(obj), file); + xfprintf(file, "\""); + break; + case PIC_TT_VECTOR: + xfprintf(file, "#("); + for (i = 0; i < pic_vec_ptr(obj)->len; ++i) { + write_core(p, pic_vec_ptr(obj)->data[i]); + if (i + 1 < pic_vec_ptr(obj)->len) { + xfprintf(file, " "); + } + } + xfprintf(file, ")"); + break; + case PIC_TT_BLOB: + xfprintf(file, "#u8("); + for (i = 0; i < pic_blob_ptr(obj)->len; ++i) { + xfprintf(file, "%d", pic_blob_ptr(obj)->data[i]); + if (i + 1 < pic_blob_ptr(obj)->len) { + xfprintf(file, " "); + } + } + xfprintf(file, ")"); + break; + case PIC_TT_DICT: + xfprintf(file, "#.(dictionary"); + for (it = xh_begin(&pic_dict_ptr(obj)->hash); it != NULL; it = xh_next(it)) { + xfprintf(file, " '"); + write_core(p, xh_key(it, pic_value)); + xfprintf(file, " '"); + write_core(p, xh_val(it, pic_value)); + } + xfprintf(file, ")"); + break; + case PIC_TT_RECORD: + write_record(pic, pic_record_ptr(obj), file); + break; + default: + xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj)); + break; + } +} + +static void +write(pic_state *pic, pic_value obj, xFILE *file) +{ + struct writer_control p; + + writer_control_init(&p, pic, file, WRITE_MODE); + + traverse_shared(&p, obj); /* FIXME */ + + write_core(&p, obj); + + writer_control_destroy(&p); +} + +static void +write_simple(pic_state *pic, pic_value obj, xFILE *file) +{ + struct writer_control p; + + writer_control_init(&p, pic, file, WRITE_MODE); + + /* no traverse here! */ + + write_core(&p, obj); + + writer_control_destroy(&p); +} + +static void +write_shared(pic_state *pic, pic_value obj, xFILE *file) +{ + struct writer_control p; + + writer_control_init(&p, pic, file, WRITE_MODE); + + traverse_shared(&p, obj); + + write_core(&p, obj); + + writer_control_destroy(&p); +} + +static void +display(pic_state *pic, pic_value obj, xFILE *file) +{ + struct writer_control p; + + writer_control_init(&p, pic, file, DISPLAY_MODE); + + traverse_shared(&p, obj); /* FIXME */ + + write_core(&p, obj); + + writer_control_destroy(&p); +} + +pic_value +pic_write(pic_state *pic, pic_value obj) +{ + return pic_fwrite(pic, obj, xstdout); +} + +pic_value +pic_fwrite(pic_state *pic, pic_value obj, xFILE *file) +{ + write(pic, obj, file); + xfflush(file); + return obj; +} + +pic_value +pic_display(pic_state *pic, pic_value obj) +{ + return pic_fdisplay(pic, obj, xstdout); +} + +pic_value +pic_fdisplay(pic_state *pic, pic_value obj, xFILE *file) +{ + display(pic, obj, file); + xfflush(file); + return obj; +} + +void +pic_printf(pic_state *pic, const char *fmt, ...) +{ + va_list ap; + pic_str *str; + + va_start(ap, fmt); + + str = pic_str_ptr(pic_car(pic, pic_xvformat(pic, fmt, ap))); + + va_end(ap); + + xprintf("%s", pic_str_cstr(str)); + xfflush(xstdout); +} + +static pic_value +pic_write_write(pic_state *pic) +{ + pic_value v; + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "o|p", &v, &port); + write(pic, v, port->file); + return pic_none_value(); +} + +static pic_value +pic_write_write_simple(pic_state *pic) +{ + pic_value v; + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "o|p", &v, &port); + write_simple(pic, v, port->file); + return pic_none_value(); +} + +static pic_value +pic_write_write_shared(pic_state *pic) +{ + pic_value v; + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "o|p", &v, &port); + write_shared(pic, v, port->file); + return pic_none_value(); +} + +static pic_value +pic_write_display(pic_state *pic) +{ + pic_value v; + struct pic_port *port = pic_stdout(pic); + + pic_get_args(pic, "o|p", &v, &port); + display(pic, v, port->file); + return pic_none_value(); +} + +void +pic_init_write(pic_state *pic) +{ + pic_defun(pic, "write", pic_write_write); + pic_defun(pic, "write-simple", pic_write_write_simple); + pic_defun(pic, "write-shared", pic_write_write_shared); + pic_defun(pic, "display", pic_write_display); +}