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

Merge upstream master into record-vector-optimization

This commit is contained in:
Doug Currie 2016-02-08 11:52:01 -05:00
parent 469ae52ba4 c7f8293368
commit 21fc081e41
50 changed files with 3108 additions and 3358 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
contrib/10.attribute/attr.scm Normal file
View File

@ -0,0 +1,13 @@
(define-library (picrin base)
(define attribute-table (make-register))
(define (attribute obj)
(let ((r (attribute-table obj)))
(if r
(cdr r)
(let ((dict (make-dictionary)))
(attribute-table obj dict)
dict))))
(export attribute))

2
contrib/10.attribute/nitro.mk Normal file
View File

@ -0,0 +1,2 @@
CONTRIB_LIBS += \
contrib/10.attribute/attr.scm

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

@ -218,15 +218,14 @@ restore_cont(pic_state *pic, struct pic_fullcont *cont)
PIC_NORETURN static pic_value
cont_call(pic_state *pic)
{
struct pic_proc *proc;
struct pic_proc *self;
int argc;
pic_value *argv;
struct pic_fullcont *cont;
proc = pic_get_proc(pic);
pic_get_args(pic, "*", &argc, &argv);
pic_get_args(pic, "&*", &self, &argc, &argv);
cont = pic_data_ptr(pic_proc_env_ref(pic, proc, "cont"))->data;
cont = pic_data_ptr(pic_proc_env_ref(pic, self, "cont"))->data;
cont->results = pic_list_by_array(pic, argc, argv);
/* execute guard handlers */

17
contrib/10.macro/macro.scm
View File

@ -6,10 +6,9 @@
(export define-macro
make-identifier
identifier?
identifier=?
identifier-variable
identifier-environment
variable?
variable=?)
identifier-environment)
;; simple macro
@ -51,7 +50,7 @@
id))))))
(walk (lambda (f form)
(cond
((variable? form)
((identifier? form)
(f form))
((pair? form)
(cons (walk f (car form)) (walk f (cdr form))))
@ -64,7 +63,7 @@
(let loop ((free free))
(if (null? free)
(wrap free)
(if (variable=? var (car free))
(if (identifier=? var (car free))
var
(loop (cdr free))))))))
(walk f form))))
@ -78,7 +77,7 @@
(identifier-variable var)))
(walk (lambda (f form)
(cond
((variable? form)
((identifier? form)
(f form))
((pair? form)
(cons (walk f (car form)) (walk f (cdr form))))
@ -112,7 +111,7 @@
(register var id)
id))))))
(compare (lambda (x y)
(variable=?
(identifier=?
(make-identifier x use-env)
(make-identifier y use-env)))))
(f form rename compare))))
@ -145,7 +144,7 @@
(rename var2)))))
(walk (lambda (f form)
(cond
((variable? form)
((identifier? form)
(f form))
((pair? form)
(cons (walk f (car form)) (walk f (cdr form))))
@ -154,7 +153,7 @@
(else
form))))
(compare (lambda (x y)
(variable=?
(identifier=?
(make-identifier x mac-env)
(make-identifier y mac-env)))))
(walk flip (f (walk inject form) inject compare))))))

36
contrib/20.r7rs/scheme/base.scm
View File

@ -208,17 +208,17 @@
(define (constant? obj)
(and (not (pair? obj))
(not (variable? obj))))
(not (identifier? obj))))
(define (literal? obj)
(and (variable? obj)
(and (identifier? obj)
(memq obj literals)))
(define (many? pat)
(and (pair? pat)
(pair? (cdr pat))
(variable? (cadr pat))
(variable=? (cadr pat) ellipsis)))
(identifier? (cadr pat))
(identifier=? (cadr pat) ellipsis)))
(define (pattern-validator pat) ; pattern -> validator
(letrec
@ -228,8 +228,8 @@
((constant? pat)
#`(equal? '#,pat #,form))
((literal? pat)
#`(and (variable? #,form) (variable=? #'#,pat #,form)))
((variable? pat)
#`(and (identifier? #,form) (identifier=? #'#,pat #,form)))
((identifier? pat)
#t)
((many? pat)
(let ((head #`(drop-tail #,(length (cddr pat)) #,form))
@ -252,7 +252,7 @@
'())
((literal? pat)
'())
((variable? pat)
((identifier? pat)
`(,pat))
((many? pat)
(append (pattern-variables (car pat))
@ -267,7 +267,7 @@
'())
((literal? pat)
'())
((variable? pat)
((identifier? pat)
`((,pat . 0)))
((many? pat)
(append (map-values succ (pattern-levels (car pat)))
@ -285,7 +285,7 @@
'())
((literal? pat)
'())
((variable? pat)
((identifier? pat)
`((,pat . ,form)))
((many? pat)
(let ((head #`(drop-tail #,(length (cddr pat)) #,form))
@ -303,7 +303,7 @@
(cond
((constant? pat)
pat)
((variable? pat)
((identifier? pat)
(let ((it (assq pat levels)))
(if it
(if (= 0 (cdr it))
@ -410,14 +410,18 @@
(export define-syntax)
;; 5.5 Recored-type definitions
;; 5.5 Record-type definitions
(define (make-record-type name)
(vector name)) ; TODO
(define-syntax (define-record-constructor type field-alist name . fields)
(let ((record #'record))
#`(define (#,name . #,fields)
(let ((#,record (make-record #,type #,(length field-alist))))
(let ((#,record (make-record #,type (make-vector #,(length field-alist)))))
#,@(map
(lambda (field) #`(record-set! #,record #,(cdr (assq field field-alist)) #,field))
(lambda (field)
#`(vector-set! (record-datum #,record) #,(cdr (assq field field-alist)) #,field))
fields)
#,record))))
@ -429,13 +433,13 @@
(define-syntax (define-record-accessor pred field-alist field accessor)
#`(define (#,accessor record)
(if (#,pred record)
(record-ref record #,(cdr (assq field field-alist)))
(vector-ref (record-datum record) #,(cdr (assq field field-alist)))
(error (string-append (symbol->string '#,accessor) ": wrong record type") record))))
(define-syntax (define-record-modifier pred field-alist field modifier)
#`(define (#,modifier record val)
(if (#,pred record)
(record-set! record #,(cdr (assq field field-alist)) val) ;; '#,field
(vector-set! (record-datum record) #,(cdr (assq field field-alist)) val)
(error (string-append (symbol->string '#,modifier) ": wrong record type") record))))
(define-syntax (define-record-field pred field-alist field accessor . modifier-opt)
@ -455,7 +459,7 @@
(cons (if (pair? (car fds)) (car (car fds)) (car fds)) idx)
alst))))))
#`(begin
(define #,name (make-record <record-type> 0))
(define #,name (make-record-type '#,name))
(define-record-constructor #,name #,field-alist #,@ctor)
(define-record-predicate #,name #,pred)
#,@(map (lambda (field) #`(define-record-field #,pred #,field-alist #,@field)) fields))))

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

@ -1,15 +1,19 @@
(define-library (scheme eval)
(import (picrin base))
(define environment
(let ((counter 0))
(lambda specs
(let ((library-name `(picrin @@my-environment ,(string->symbol (number->string counter)))))
(set! counter (+ counter 1))
(eval
`(define-library ,library-name
,@(map (lambda (spec) `(import ,spec)) specs))
(library-environment (find-library '(scheme base))))
(library-environment (find-library library-name))))))
(define counter 0)
(define-syntax (inc! n)
#`(set! #,n (+ #,n 1)))
(define (number->symbol n)
(string->symbol (number->string n)))
(define (environment . specs)
(let ((library-name `(picrin @@my-environment ,(number->symbol counter))))
(inc! counter)
(let ((lib (make-library library-name)))
(eval `(import ,@specs) lib)
lib)))
(export environment eval))

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

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

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

@ -11,7 +11,7 @@ file_error(pic_state *pic, const char *msg)
{
struct pic_error *e;
e = pic_make_error(pic, pic_intern(pic, "file"), msg, pic_nil_value());
e = pic_make_error(pic, pic_intern_lit(pic, "file"), msg, pic_nil_value());
pic_raise(pic, pic_obj_value(e));
}

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

@ -17,7 +17,7 @@ pic_system_cmdline(pic_state *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);
v = pic_cons(pic, pic_obj_value(pic_make_cstr(pic, pic->argv[i])), v);
pic_gc_arena_restore(pic, ai);
}
@ -84,7 +84,7 @@ pic_system_getenv(pic_state *pic)
if (val == NULL)
return pic_nil_value();
else
return pic_obj_value(pic_make_str_cstr(pic, val));
return pic_obj_value(pic_make_cstr(pic, val));
}
static pic_value
@ -108,7 +108,7 @@ pic_system_getenvs(pic_state *pic)
;
key = pic_make_str(pic, *envp, i);
val = pic_make_str_cstr(pic, getenv(pic_str_cstr(pic, key)));
val = pic_make_cstr(pic, getenv(pic_str_cstr(pic, key)));
/* push */
data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data);

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

@ -19,7 +19,7 @@ pic_rl_readline(pic_state *pic)
result = readline(prompt);
if(result)
return pic_obj_value(pic_make_str_cstr(pic, result));
return pic_obj_value(pic_make_cstr(pic, result));
else
return pic_eof_object();
}
@ -87,7 +87,7 @@ pic_rl_current_history(pic_state *pic)
{
pic_get_args(pic, "");
return pic_obj_value(pic_make_str_cstr(pic, current_history()->line));
return pic_obj_value(pic_make_cstr(pic, current_history()->line));
}
static pic_value
@ -100,7 +100,7 @@ pic_rl_history_get(pic_state *pic)
e = history_get(i);
return e ? pic_obj_value(pic_make_str_cstr(pic, e->line))
return e ? pic_obj_value(pic_make_cstr(pic, e->line))
: pic_false_value();
}
@ -114,7 +114,7 @@ pic_rl_remove_history(pic_state *pic)
e = remove_history(i);
return e ? pic_obj_value(pic_make_str_cstr(pic, e->line))
return e ? pic_obj_value(pic_make_cstr(pic, e->line))
: pic_false_value();
}
@ -148,7 +148,7 @@ pic_rl_previous_history(pic_state *pic)
e = previous_history();
return e ? pic_obj_value(pic_make_str_cstr(pic, e->line))
return e ? pic_obj_value(pic_make_cstr(pic, e->line))
: pic_false_value();
}
@ -161,7 +161,7 @@ pic_rl_next_history(pic_state *pic)
e = next_history();
return e ? pic_obj_value(pic_make_str_cstr(pic, e->line))
return e ? pic_obj_value(pic_make_cstr(pic, e->line))
: pic_false_value();
}
@ -240,7 +240,7 @@ pic_rl_history_expand(pic_state *pic)
if(status == -1 || status == 2)
pic_errorf(pic, "%s\n", result);
return pic_obj_value(pic_make_str_cstr(pic, result));
return pic_obj_value(pic_make_cstr(pic, result));
}
void

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

@ -146,7 +146,7 @@ pic_regexp_regexp_split(pic_state *pic)
input += match.rm_eo;
}
pic_push(pic, pic_obj_value(pic_make_str_cstr(pic, input)), output);
pic_push(pic, pic_obj_value(pic_make_cstr(pic, input)), output);
return pic_reverse(pic, output);
}
@ -157,7 +157,7 @@ pic_regexp_regexp_replace(pic_state *pic)
pic_value reg;
const char *input;
regmatch_t match;
pic_str *txt, *output = pic_make_str(pic, NULL, 0);
pic_str *txt, *output = pic_make_lit(pic, "");
pic_get_args(pic, "ozs", &reg, &input, &txt);

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

@ -115,7 +115,7 @@ pic_socket_make_socket(pic_state *pic)
continue;
}
if (it->ai_flags & AI_PASSIVE) {
if (hints.ai_flags & AI_PASSIVE) {
int yes = 1;
if (setsockopt(fd, SOL_SOCKET, SO_REUSEADDR, &yes, sizeof(int)) == 0 &&
bind(fd, it->ai_addr, it->ai_addrlen) == 0) {

2
contrib/50.destructuring-bind/lambda.scm
View File

@ -4,7 +4,7 @@
(define-syntax (destructuring-bind formal value . body)
(cond
((variable? formal)
((identifier? formal)
#`(let ((#,formal #,value))
#,@body))
((pair? formal)

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

@ -19,10 +19,7 @@
(define (add-history str)
#f))))
(define user-env (library-environment (find-library '(picrin user))))
(define (init-env)
(current-library (find-library '(picrin user)))
(eval
'(import (scheme base)
(scheme load)
@ -34,9 +31,10 @@
(scheme cxr)
(scheme lazy)
(scheme time)
(scheme eval)
(scheme r5rs)
(picrin macro))
user-env)
(current-library (find-library '(picrin repl))))
(find-library '(picrin user))))
(define (repl)
(init-env)
@ -67,7 +65,7 @@
(lambda (port)
(let next ((expr (read port)))
(unless (eof-object? expr)
(write (eval expr user-env))
(write (eval expr (find-library '(picrin user))))
(newline)
(set! str "")
(next (read port))))))))))

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

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

48
extlib/benz/attr.c
View File

@ -1,48 +0,0 @@
#include "picrin.h"
struct pic_dict *
pic_attr(pic_state *pic, pic_value obj)
{
struct pic_dict *dict;
if (! pic_obj_p(obj)) {
pic_errorf(pic, "attribute: expected heap object, but got immediate value ~s", obj);
}
if (! pic_reg_has(pic, pic->attrs, pic_ptr(obj))) {
dict = pic_make_dict(pic);
pic_reg_set(pic, pic->attrs, pic_ptr(obj), pic_obj_value(dict));
return dict;
}
return pic_dict_ptr(pic_reg_ref(pic, pic->attrs, pic_ptr(obj)));
}
pic_value
pic_attr_ref(pic_state *pic, pic_value obj, const char *key)
{
return pic_dict_ref(pic, pic_attr(pic, obj), pic_intern(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_intern(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);
}

9
extlib/benz/bool.c
View File

@ -40,11 +40,15 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m)
switch (pic_type(x)) {
case PIC_TT_ID: {
struct pic_id *id1, *id2;
pic_sym *s1, *s2;
id1 = pic_id_ptr(x);
id2 = pic_id_ptr(y);
return pic_resolve(pic, id1->var, id1->env) == pic_resolve(pic, id2->var, id2->env);
s1 = pic_lookup_identifier(pic, id1->u.id.id, id1->u.id.env);
s2 = pic_lookup_identifier(pic, id2->u.id.id, id2->u.id.env);
return s1 == s2;
}
case PIC_TT_STRING: {
return pic_str_cmp(pic, pic_str_ptr(x), pic_str_ptr(y)) == 0;
@ -114,6 +118,9 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m)
}
return true;
}
case PIC_TT_DATA: {
return pic_data_ptr(x)->data == pic_data_ptr(y)->data;
}
default:
return false;
}

600
extlib/benz/boot.c
View File

@ -71,7 +71,7 @@ my $src = <<'EOL';
(builtin:define-macro set!
(builtin:lambda (form env)
(if (= (length form) 3)
(if (variable? (cadr form))
(if (identifier? (cadr form))
(cons the-builtin-set! (cdr form))
(error "illegal set! form" form))
(error "illegal set! form" form))))
@ -80,10 +80,10 @@ my $src = <<'EOL';
(builtin:lambda (formal)
(if (null? formal)
#t
(if (variable? formal)
(if (identifier? formal)
#t
(if (pair? formal)
(if (variable? (car formal))
(if (identifier? (car formal))
(check-formal (cdr formal))
#f)
#f)))))
@ -101,7 +101,7 @@ my $src = <<'EOL';
((lambda (len)
(if (= len 1)
(error "illegal define form" form)
(if (variable? (cadr form))
(if (identifier? (cadr form))
(if (= len 3)
(cons the-builtin-define (cdr form))
(error "illegal define form" form))
@ -115,7 +115,7 @@ my $src = <<'EOL';
(builtin:define-macro define-macro
(lambda (form env)
(if (= (length form) 3)
(if (variable? (cadr form))
(if (identifier? (cadr form))
(cons the-builtin-define-macro (cdr form))
(error "define-macro: binding to non-variable object" form))
(error "illegal define-macro form" form))))
@ -145,7 +145,7 @@ my $src = <<'EOL';
(define-macro let
(lambda (form env)
(if (variable? (cadr form))
(if (identifier? (cadr form))
(list
(list the-lambda '()
(list the-define (cadr form)
@ -189,15 +189,15 @@ my $src = <<'EOL';
(if (null? clauses)
#undefined
(let ((clause (car clauses)))
(if (and (variable? (car clause))
(variable=? (the 'else) (make-identifier (car clause) env)))
(if (and (identifier? (car clause))
(identifier=? (the 'else) (make-identifier (car clause) env)))
(cons the-begin (cdr clause))
(if (null? (cdr clause))
(let ((tmp (make-identifier 'tmp here)))
(list (the 'let) (list (list tmp (car clause)))
(list the-if tmp tmp (cons (the 'cond) (cdr clauses)))))
(if (and (variable? (cadr clause))
(variable=? (the '=>) (make-identifier (cadr clause) env)))
(if (and (identifier? (cadr clause))
(identifier=? (the '=>) (make-identifier (cadr clause) env)))
(let ((tmp (make-identifier 'tmp here)))
(list (the 'let) (list (list tmp (car clause)))
(list the-if tmp
@ -212,19 +212,19 @@ my $src = <<'EOL';
(define (quasiquote? form)
(and (pair? form)
(variable? (car form))
(variable=? (the 'quasiquote) (make-identifier (car form) env))))
(identifier? (car form))
(identifier=? (the 'quasiquote) (make-identifier (car form) env))))
(define (unquote? form)
(and (pair? form)
(variable? (car form))
(variable=? (the 'unquote) (make-identifier (car form) env))))
(identifier? (car form))
(identifier=? (the 'unquote) (make-identifier (car form) env))))
(define (unquote-splicing? form)
(and (pair? form)
(pair? (car form))
(variable? (caar form))
(variable=? (the 'unquote-splicing) (make-identifier (caar form) env))))
(identifier? (caar form))
(identifier=? (the 'unquote-splicing) (make-identifier (caar form) env))))
(define (qq depth expr)
(cond
@ -314,7 +314,7 @@ my $src = <<'EOL';
,@(let loop ((formal formal))
(if (pair? formal)
`((,the-define ,(car formal) #undefined) ,@(loop (cdr formal)))
(if (variable? formal)
(if (identifier? formal)
`((,the-define ,formal #undefined))
'())))
(,(the 'call-with-values) (,the-lambda () ,@body)
@ -323,7 +323,7 @@ my $src = <<'EOL';
,@(let loop ((formal formal) (args arguments))
(if (pair? formal)
`((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))
(if (variable? formal)
(if (identifier? formal)
`((,the-set! ,formal ,args))
'()))))))))))
@ -368,12 +368,12 @@ my $src = <<'EOL';
(if (null? clauses)
#undefined
(let ((clause (car clauses)))
`(,the-if ,(if (and (variable? (car clause))
(variable=? (the 'else) (make-identifier (car clause) env)))
`(,the-if ,(if (and (identifier? (car clause))
(identifier=? (the 'else) (make-identifier (car clause) env)))
#t
`(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))
,(if (and (variable? (cadr clause))
(variable=? (the '=>) (make-identifier (cadr clause) env)))
,(if (and (identifier? (cadr clause))
(identifier=? (the '=>) (make-identifier (cadr clause) env)))
`(,(car (cdr (cdr clause))) ,the-key)
`(,the-begin ,@(cdr clause)))
,(loop (cdr clauses)))))))))))
@ -400,7 +400,7 @@ my $src = <<'EOL';
(rename var))))))
(walk (lambda (f form)
(cond
((variable? form)
((identifier? form)
(f form))
((pair? form)
`(,(the 'cons) (walk f (car form)) (walk f (cdr form))))
@ -427,19 +427,19 @@ my $src = <<'EOL';
(define (syntax-quasiquote? form)
(and (pair? form)
(variable? (car form))
(variable=? (the 'syntax-quasiquote) (make-identifier (car form) env))))
(identifier? (car form))
(identifier=? (the 'syntax-quasiquote) (make-identifier (car form) env))))
(define (syntax-unquote? form)
(and (pair? form)
(variable? (car form))
(variable=? (the 'syntax-unquote) (make-identifier (car form) env))))
(identifier? (car form))
(identifier=? (the 'syntax-unquote) (make-identifier (car form) env))))
(define (syntax-unquote-splicing? form)
(and (pair? form)
(pair? (car form))
(variable? (caar form))
(variable=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env))))
(identifier? (caar form))
(identifier=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env))))
(define (qq depth expr)
(cond
@ -474,8 +474,8 @@ my $src = <<'EOL';
;; vector
((vector? expr)
(list (the 'list->vector) (qq depth (vector->list expr))))
;; variable
((variable? expr)
;; identifier
((identifier? expr)
(rename expr))
;; simple datum
(else
@ -506,7 +506,7 @@ my $src = <<'EOL';
var2))))
(walk (lambda (f form)
(cond
((variable? form)
((identifier? form)
(f form))
((pair? form)
(cons (walk f (car form)) (walk f (cdr form))))
@ -546,12 +546,8 @@ my $src = <<'EOL';
(lambda (form _)
(let ((name (cadr form))
(body (cddr form)))
(let ((old-library (current-library))
(new-library (or (find-library name) (make-library name))))
(let ((env (library-environment new-library)))
(current-library new-library)
(for-each (lambda (expr) (eval expr env)) body)
(current-library old-library))))))
(let ((new-library (or (find-library name) (make-library name))))
(for-each (lambda (expr) (eval expr new-library)) body)))))
(define-macro cond-expand
(lambda (form _)
@ -745,271 +741,269 @@ const char pic_boot[][80] = {
" (cdr form))\n (list the-builtin-begin\n ",
" (cadr form)\n (cons the-begin (cddr form)))))))\n (le",
"ngth form))))\n\n(builtin:define-macro set!\n (builtin:lambda (form env)\n (if (",
"= (length form) 3)\n (if (variable? (cadr form))\n (cons the-bui",
"ltin-set! (cdr form))\n (error \"illegal set! form\" form))\n (err",
"or \"illegal set! form\" form))))\n\n(builtin:define check-formal\n (builtin:lambda ",
"(formal)\n (if (null? formal)\n #t\n (if (variable? formal)\n ",
" #t\n (if (pair? formal)\n (if (variable? (car form",
"al))\n (check-formal (cdr formal))\n #f)\n ",
" #f)))))\n\n(builtin:define-macro lambda\n (builtin:lambda (form env)\n",
" (if (= (length form) 1)\n (error \"illegal lambda form\" form)\n (",
"if (check-formal (cadr form))\n (list the-builtin-lambda (cadr form) (",
"cons the-begin (cddr form)))\n (error \"illegal lambda form\" form)))))\n",
"\n(builtin:define-macro define\n (lambda (form env)\n ((lambda (len)\n (if",
" (= len 1)\n (error \"illegal define form\" form)\n (if (variabl",
"e? (cadr form))\n (if (= len 3)\n (cons the-builti",
"n-define (cdr form))\n (error \"illegal define form\" form))\n ",
" (if (pair? (cadr form))\n (list the-define\n ",
" (car (cadr form))\n (cons the-lambda (con",
"s (cdr (cadr form)) (cddr form))))\n (error \"define: binding to",
" non-varaible object\" form)))))\n (length form))))\n\n(builtin:define-macro def",
"ine-macro\n (lambda (form env)\n (if (= (length form) 3)\n (if (variable",
"? (cadr form))\n (cons the-builtin-define-macro (cdr form))\n ",
" (error \"define-macro: binding to non-variable object\" form))\n (error \"i",
"llegal define-macro form\" form))))\n\n\n(define-macro syntax-error\n (lambda (form ",
"_)\n (apply error (cdr form))))\n\n(define-macro define-auxiliary-syntax\n (lamb",
"da (form _)\n (define message\n (string-append\n \"invalid use of auxi",
"liary syntax: '\" (symbol->string (cadr form)) \"'\"))\n (list\n the-define-ma",
"cro\n (cadr form)\n (list the-lambda '_\n (list (the 'error) mess",
"age)))))\n\n(define-auxiliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-au",
"xiliary-syntax unquote)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxil",
"iary-syntax syntax-unquote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(",
"define-macro let\n (lambda (form env)\n (if (variable? (cadr form))\n (l",
"ist\n (list the-lambda '()\n (list the-define (cadr form)\n ",
" (cons the-lambda\n (cons (map car (c",
"ar (cddr form)))\n (cdr (cddr form)))))\n ",
" (cons (cadr form) (map cadr (car (cddr form))))))\n (cons\n (",
"cons\n the-lambda\n (cons (map car (cadr form))\n ",
"(cddr form)))\n (map cadr (cadr form))))))\n\n(define-macro and\n (lambda (",
"form env)\n (if (null? (cdr form))\n #t\n (if (null? (cddr form))\n",
" (cadr form)\n (list the-if\n (cadr form)\n ",
" (cons (the 'and) (cddr form))\n #f)))))\n\n(defin",
"e-macro or\n (lambda (form env)\n (if (null? (cdr form))\n #f\n (l",
"et ((tmp (make-identifier 'it env)))\n (list (the 'let)\n ",
"(list (list tmp (cadr form)))\n (list the-if\n ",
" tmp\n tmp\n (cons (the 'or) (cddr form)",
")))))))\n\n(define-macro cond\n (lambda (form env)\n (let ((clauses (cdr form)))",
"\n (if (null? clauses)\n #undefined\n (let ((clause (car cla",
"uses)))\n (if (and (variable? (car clause))\n (vari",
"able=? (the 'else) (make-identifier (car clause) env)))\n (cons th",
"e-begin (cdr clause))\n (if (null? (cdr clause))\n ",
" (let ((tmp (make-identifier 'tmp here)))\n (list (the 'le",
"t) (list (list tmp (car clause)))\n (list the-if tmp t",
"mp (cons (the 'cond) (cdr clauses)))))\n (if (and (variable? (",
"cadr clause))\n (variable=? (the '=>) (make-identifie",
"r (cadr clause) env)))\n (let ((tmp (make-identifier 'tmp ",
"here)))\n (list (the 'let) (list (list tmp (car clause))",
")\n (list the-if tmp\n ",
" (list (car (cddr clause)) tmp)\n (c",
"ons (the 'cond) (cdr clauses)))))\n (list the-if (car clau",
"se)\n (cons the-begin (cdr clause))\n ",
" (cons (the 'cond) (cdr clauses)))))))))))\n\n(define-macro quasiquot",
"e\n (lambda (form env)\n\n (define (quasiquote? form)\n (and (pair? form)\n ",
" (variable? (car form))\n (variable=? (the 'quasiquote) (make-",
"identifier (car form) env))))\n\n (define (unquote? form)\n (and (pair? for",
"m)\n (variable? (car form))\n (variable=? (the 'unquote) (make",
"-identifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and ",
"(pair? form)\n (pair? (car form))\n (variable? (caar form))\n ",
" (variable=? (the 'unquote-splicing) (make-identifier (caar form) env)))",
")\n\n (define (qq depth expr)\n (cond\n ;; unquote\n ((unquote? e",
"xpr)\n (if (= depth 1)\n (car (cdr expr))\n (list (the",
" 'list)\n (list (the 'quote) (the 'unquote))\n (",
"qq (- depth 1) (car (cdr expr))))))\n ;; unquote-splicing\n ((unquote-",
"splicing? expr)\n (if (= depth 1)\n (list (the 'append)\n ",
" (car (cdr (car expr)))\n (qq depth (cdr expr)))\n ",
" (list (the 'cons)\n (list (the 'list)\n ",
" (list (the 'quote) (the 'unquote-splicing))\n (qq (- d",
"epth 1) (car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ",
" ;; quasiquote\n ((quasiquote? expr)\n (list (the 'list)\n ",
" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) (car (cd",
"r expr)))))\n ;; list\n ((pair? expr)\n (list (the 'cons)\n ",
" (qq depth (car expr))\n (qq depth (cdr expr))))\n ;; ve",
"ctor\n ((vector? expr)\n (list (the 'list->vector) (qq depth (vector-",
">list expr))))\n ;; simple datum\n (else\n (list (the 'quote) ex",
"pr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(define-macro let*\n (lamb",
"da (form env)\n (let ((bindings (car (cdr form)))\n (body (cdr (cd",
"r form))))\n (if (null? bindings)\n `(,(the 'let) () ,@body)\n ",
" `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n (,",
"(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n(define-macro letrec\n ",
" (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n\n(define-macro letrec*",
"\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ",
"(cdr (cdr form))))\n (let ((variables (map (lambda (v) `(,v #f)) (map car bi",
"ndings)))\n (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings)",
"))\n `(,(the 'let) (,@variables)\n ,@initials\n ,@body))))",
")\n\n(define-macro let-values\n (lambda (form env)\n `(,(the 'let*-values) ,@(cd",
"r form))))\n\n(define-macro let*-values\n (lambda (form env)\n (let ((formal (ca",
"r (cdr form)))\n (body (cdr (cdr form))))\n (if (null? formal)\n ",
" `(,(the 'let) () ,@body)\n `(,(the 'call-with-values) (,the-lambd",
"a () ,@(cdr (car formal)))\n (,(the 'lambda) (,@(car (car formal)))\n ",
" (,(the 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n(d",
"efine-macro define-values\n (lambda (form env)\n (let ((formal (car (cdr form)",
"))\n (body (cdr (cdr form))))\n (let ((arguments (make-identifier ",
"'arguments here)))\n `(,the-begin\n ,@(let loop ((formal formal))\n",
" (if (pair? formal)\n `((,the-define ,(car formal) ",
"#undefined) ,@(loop (cdr formal)))\n (if (variable? formal)\n ",
" `((,the-define ,formal #undefined))\n '())",
"))\n (,(the 'call-with-values) (,the-lambda () ,@body)\n (,the-",
"lambda\n ,arguments\n ,@(let loop ((formal formal) (args arg",
"uments))\n (if (pair? formal)\n `((,the-set! ,(c",
"ar formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))\n ",
" (if (variable? formal)\n `((,the-set! ,for",
"mal ,args))\n '()))))))))))\n\n(define-macro do\n (lambda (f",
"orm env)\n (let ((bindings (car (cdr form)))\n (test (car (car (cd",
"r (cdr form)))))\n (cleanup (cdr (car (cdr (cdr form)))))\n (bo",
"dy (cdr (cdr (cdr form)))))\n (let ((loop (make-identifier 'loop here)))",
"\n `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings)\n",
" (,the-if ,test\n (,the-begin\n ,@cl",
"eanup)\n (,the-begin\n ,@body\n ",
" (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car x) (car (cdr (cdr ",
"x))))) bindings)))))))))\n\n(define-macro when\n (lambda (form env)\n (let ((tes",
"t (car (cdr form)))\n (body (cdr (cdr form))))\n `(,the-if ,test\n ",
" (,the-begin ,@body)\n #undefined))))\n\n(define-macro u",
"nless\n (lambda (form env)\n (let ((test (car (cdr form)))\n (body (cd",
"r (cdr form))))\n `(,the-if ,test\n #undefined\n ",
" (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (form env)\n (let ((key",
" (car (cdr form)))\n (clauses (cdr (cdr form))))\n (let ((the-ke",
"y (make-identifier 'key here)))\n `(,(the 'let) ((,the-key ,key))\n ",
" ,(let loop ((clauses clauses))\n (if (null? clauses)\n ",
" #undefined\n (let ((clause (car clauses)))\n ",
"`(,the-if ,(if (and (variable? (car clause))\n ",
" (variable=? (the 'else) (make-identifier (car clause) env)))\n ",
" #t\n `(,(the 'or) ,@(map (lam",
"bda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ",
" ,(if (and (variable? (cadr clause))\n ",
" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ",
" `(,(car (cdr (cdr clause))) ,the-key)\n ",
" `(,the-begin ,@(cdr clause)))\n ,(loo",
"p (cdr clauses)))))))))))\n\n(define-macro parameterize\n (lambda (form env)\n (",
"let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(,(th",
"e 'with-parameter)\n (,(the 'lambda) ()\n ,@formal\n ,@body)",
"))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (let ((renames '()))\n ",
" (letrec\n ((rename (lambda (var)\n (let ((x (ass",
"q var renames)))\n (if x\n (cadr x",
")\n (begin\n (set! renames `",
"((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,rena",
"mes))\n (rename var))))))\n (walk (lambda (f",
" form)\n (cond\n ((variable? form)\n ",
" (f form))\n ((pair? form)\n `(,(",
"the 'cons) (walk f (car form)) (walk f (cdr form))))\n ((vecto",
"r? form)\n `(,(the 'list->vector) (walk f (vector->list form)",
")))\n (else\n `(,(the 'quote) ,form))))))\n ",
" (let ((form (walk rename (cadr form))))\n `(,(the 'let)\n ",
" ,(map cdr renames)\n ,form))))))\n\n(define-macro syntax-quasiquote\n ",
" (lambda (form env)\n (let ((renames '()))\n (letrec\n ((rename (l",
"ambda (var)\n (let ((x (assq var renames)))\n ",
" (if x\n (cadr x)\n (begi",
"n\n (set! renames `((,var ,(make-identifier var env) ",
"(,(the 'make-identifier) ',var ',env)) . ,renames))\n ",
" (rename var)))))))\n\n (define (syntax-quasiquote? form)\n (and (p",
"air? form)\n (variable? (car form))\n (variable=? (the",
" 'syntax-quasiquote) (make-identifier (car form) env))))\n\n (define (synta",
"x-unquote? form)\n (and (pair? form)\n (variable? (car form",
"))\n (variable=? (the 'syntax-unquote) (make-identifier (car form) ",
"env))))\n\n (define (syntax-unquote-splicing? form)\n (and (pair? f",
"orm)\n (pair? (car form))\n (variable? (caar form))\n ",
" (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar f",
"orm) env))))\n\n (define (qq depth expr)\n (cond\n ;; synt",
"ax-unquote\n ((syntax-unquote? expr)\n (if (= depth 1)\n ",
" (car (cdr expr))\n (list (the 'list)\n ",
" (list (the 'quote) (the 'syntax-unquote))\n (qq (- depth ",
"1) (car (cdr expr))))))\n ;; syntax-unquote-splicing\n ((synta",
"x-unquote-splicing? expr)\n (if (= depth 1)\n (list (the",
" 'append)\n (car (cdr (car expr)))\n (qq",
" depth (cdr expr)))\n (list (the 'cons)\n (lis",
"t (the 'list)\n (list (the 'quote) (the 'syntax-unquot",
"e-splicing))\n (qq (- depth 1) (car (cdr (car expr))))",
")\n (qq depth (cdr expr)))))\n ;; syntax-quasiquote",
"\n ((syntax-quasiquote? expr)\n (list (the 'list)\n ",
" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) (",
"car (cdr expr)))))\n ;; list\n ((pair? expr)\n (list",
" (the 'cons)\n (qq depth (car expr))\n (qq depth",
" (cdr expr))))\n ;; vector\n ((vector? expr)\n (list",
" (the 'list->vector) (qq depth (vector->list expr))))\n ;; variable\n ",
" ((variable? expr)\n (rename expr))\n ;; simple datum\n",
" (else\n (list (the 'quote) expr))))\n\n (let ((body (q",
"q 1 (cadr form))))\n `(,(the 'let)\n ,(map cdr renames)\n ",
" ,body))))))\n\n(define (transformer f)\n (lambda (form env)\n (let ((regis",
"ter1 (make-register))\n (register2 (make-register)))\n (letrec\n ",
" ((wrap (lambda (var1)\n (let ((var2 (register1 var1)))\n ",
" (if var2\n (cdr var2)\n ",
" (let ((var2 (make-identifier var1 env)))\n (reg",
"ister1 var1 var2)\n (register2 var2 var1)\n ",
" var2)))))\n (unwrap (lambda (var2)\n (",
"let ((var1 (register2 var2)))\n (if var1\n ",
" (cdr var1)\n var2))))\n (walk (lambda",
" (f form)\n (cond\n ((variable? form)\n ",
" (f form))\n ((pair? form)\n (",
"cons (walk f (car form)) (walk f (cdr form))))\n ((vector? for",
"m)\n (list->vector (walk f (vector->list form))))\n ",
" (else\n form)))))\n (let ((form (cdr form)))\n ",
" (walk unwrap (apply f (walk wrap form))))))))\n\n(define-macro define-syn",
"tax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n (body (",
"cdr (cdr form))))\n (if (pair? formal)\n `(,(the 'define-syntax) ,(c",
"ar formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-define-macro ,fo",
"rmal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(define-macro letrec-syntax",
"\n (lambda (form env)\n (let ((formal (car (cdr form)))\n (body (cdr",
" (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n `(,(",
"the 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n ,@body",
"))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ",
",@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro define-library\n (lambda",
" (form _)\n (let ((name (cadr form))\n (body (cddr form)))\n (let ",
"((old-library (current-library))\n (new-library (or (find-library name",
") (make-library name))))\n (let ((env (library-environment new-library)))\n",
" (current-library new-library)\n (for-each (lambda (expr) (eval",
" expr env)) body)\n (current-library old-library))))))\n\n(define-macro co",
"nd-expand\n (lambda (form _)\n (letrec\n ((test (lambda (form)\n ",
" (or\n (eq? form 'else)\n (and (symbol? f",
"orm)\n (memq form (features)))\n (and (pair",
"? form)\n (case (car form)\n ((libra",
"ry) (find-library (cadr form)))\n ((not) (not (test (cadr",
" form))))\n ((and) (let loop ((form (cdr form)))\n ",
" (or (null? form)\n ",
" (and (test (car form)) (loop (cdr form))))))\n ((or) (le",
"t loop ((form (cdr form)))\n (and (pair? form)\n ",
" (or (test (car form)) (loop (cdr form))))))\n",
" (else #f)))))))\n (let loop ((clauses (cdr form)))\n",
" (if (null? clauses)\n #undefined\n (if (test (caar c",
"lauses))\n `(,the-begin ,@(cdar clauses))\n (loop (c",
"dr clauses))))))))\n\n(define-macro import\n (lambda (form _)\n (let ((caddr\n ",
" (lambda (x) (car (cdr (cdr x)))))\n (prefix\n (lambda (",
"prefix symbol)\n (string->symbol\n (string-append\n ",
" (symbol->string prefix)\n (symbol->string symbol))))))\n ",
" (letrec\n ((extract\n (lambda (spec)\n (case (ca",
"r spec)\n ((only rename prefix except)\n (extract (",
"cadr spec)))\n (else\n (or (find-library spec) (err",
"or \"library not found\" spec))))))\n (collect\n (lambda (spec)",
"\n (case (car spec)\n ((only)\n (let ((",
"alist (collect (cadr spec))))\n (map (lambda (var) (assq var al",
"ist)) (cddr spec))))\n ((rename)\n (let ((alist (co",
"llect (cadr spec)))\n (renames (map (lambda (x) `((car x) .",
" (cadr x))) (cddr spec))))\n (map (lambda (s) (or (assq (car s)",
" renames) s)) alist)))\n ((prefix)\n (let ((alist (",
"collect (cadr spec))))\n (map (lambda (s) (cons (prefix (caddr ",
"spec) (car s)) (cdr s))) alist)))\n ((except)\n (le",
"t ((alist (collect (cadr spec))))\n (let loop ((alist alist))\n ",
" (if (null? alist)\n '()\n ",
" (if (memq (caar alist) (cddr spec))\n (lo",
"op (cdr alist))\n (cons (car alist) (loop (cdr alist)",
")))))))\n (else\n (let ((lib (or (find-library spec",
") (error \"library not found\" spec))))\n (map (lambda (x) (cons ",
"x x)) (library-exports lib))))))))\n (letrec\n ((import\n ",
" (lambda (spec)\n (let ((lib (extract spec))\n ",
" (alist (collect spec)))\n (for-each\n ",
" (lambda (slot)\n (library-import lib (cdr slot) (car slot)",
"))\n alist)))))\n (for-each import (cdr form)))))))\n\n(",
"define-macro export\n (lambda (form _)\n (letrec\n ((collect\n (",
"lambda (spec)\n (cond\n ((symbol? spec)\n `(,sp",
"ec . ,spec))\n ((and (list? spec) (= (length spec) 3) (eq? (car spec)",
" 'rename))\n `(,(list-ref spec 1) . ,(list-ref spec 2)))\n ",
" (else\n (error \"malformed export\")))))\n (export\n ",
" (lambda (spec)\n (let ((slot (collect spec)))\n (librar",
"y-export (car slot) (cdr slot))))))\n (for-each export (cdr form)))))\n\n(expo",
"rt define lambda quote set! if begin define-macro\n let let* letrec letrec",
"*\n let-values let*-values define-values\n quasiquote unquote unquot",
"e-splicing\n and or\n cond case else =>\n do when unless\n ",
" parameterize\n define-syntax\n syntax-quote syntax-unquote\n ",
" syntax-quasiquote syntax-unquote-splicing\n let-syntax letrec-syntax\n ",
" syntax-error)\n\n\n",
"= (length form) 3)\n (if (identifier? (cadr form))\n (cons the-b",
"uiltin-set! (cdr form))\n (error \"illegal set! form\" form))\n (e",
"rror \"illegal set! form\" form))))\n\n(builtin:define check-formal\n (builtin:lambd",
"a (formal)\n (if (null? formal)\n #t\n (if (identifier? formal)\n ",
" #t\n (if (pair? formal)\n (if (identifier? (ca",
"r formal))\n (check-formal (cdr formal))\n #",
"f)\n #f)))))\n\n(builtin:define-macro lambda\n (builtin:lambda (form",
" env)\n (if (= (length form) 1)\n (error \"illegal lambda form\" form)\n ",
" (if (check-formal (cadr form))\n (list the-builtin-lambda (cadr f",
"orm) (cons the-begin (cddr form)))\n (error \"illegal lambda form\" form",
")))))\n\n(builtin:define-macro define\n (lambda (form env)\n ((lambda (len)\n ",
" (if (= len 1)\n (error \"illegal define form\" form)\n (if (i",
"dentifier? (cadr form))\n (if (= len 3)\n (cons th",
"e-builtin-define (cdr form))\n (error \"illegal define form\" for",
"m))\n (if (pair? (cadr form))\n (list the-define\n ",
" (car (cadr form))\n (cons the-lam",
"bda (cons (cdr (cadr form)) (cddr form))))\n (error \"define: bi",
"nding to non-varaible object\" form)))))\n (length form))))\n\n(builtin:define-m",
"acro define-macro\n (lambda (form env)\n (if (= (length form) 3)\n (if (",
"identifier? (cadr form))\n (cons the-builtin-define-macro (cdr form))\n",
" (error \"define-macro: binding to non-variable object\" form))\n ",
" (error \"illegal define-macro form\" form))))\n\n\n(define-macro syntax-error\n (lam",
"bda (form _)\n (apply error (cdr form))))\n\n(define-macro define-auxiliary-synt",
"ax\n (lambda (form _)\n (define message\n (string-append\n \"invalid u",
"se of auxiliary syntax: '\" (symbol->string (cadr form)) \"'\"))\n (list\n the",
"-define-macro\n (cadr form)\n (list the-lambda '_\n (list (the 'e",
"rror) message)))))\n\n(define-auxiliary-syntax else)\n(define-auxiliary-syntax =>)\n",
"(define-auxiliary-syntax unquote)\n(define-auxiliary-syntax unquote-splicing)\n(de",
"fine-auxiliary-syntax syntax-unquote)\n(define-auxiliary-syntax syntax-unquote-sp",
"licing)\n\n(define-macro let\n (lambda (form env)\n (if (identifier? (cadr form)",
")\n (list\n (list the-lambda '()\n (list the-define (c",
"adr form)\n (cons the-lambda\n (cons",
" (map car (car (cddr form)))\n (cdr (cddr form)))",
"))\n (cons (cadr form) (map cadr (car (cddr form))))))\n (con",
"s\n (cons\n the-lambda\n (cons (map car (cadr form))\n ",
" (cddr form)))\n (map cadr (cadr form))))))\n\n(define-macro and",
"\n (lambda (form env)\n (if (null? (cdr form))\n #t\n (if (null? (",
"cddr form))\n (cadr form)\n (list the-if\n (",
"cadr form)\n (cons (the 'and) (cddr form))\n #f)",
"))))\n\n(define-macro or\n (lambda (form env)\n (if (null? (cdr form))\n #",
"f\n (let ((tmp (make-identifier 'it env)))\n (list (the 'let)\n ",
" (list (list tmp (cadr form)))\n (list the-if\n ",
" tmp\n tmp\n (cons (the 'or)",
" (cddr form))))))))\n\n(define-macro cond\n (lambda (form env)\n (let ((clauses ",
"(cdr form)))\n (if (null? clauses)\n #undefined\n (let ((cla",
"use (car clauses)))\n (if (and (identifier? (car clause))\n ",
" (identifier=? (the 'else) (make-identifier (car clause) env)))\n ",
" (cons the-begin (cdr clause))\n (if (null? (cdr clause))\n ",
" (let ((tmp (make-identifier 'tmp here)))\n ",
" (list (the 'let) (list (list tmp (car clause)))\n (l",
"ist the-if tmp tmp (cons (the 'cond) (cdr clauses)))))\n (if (",
"and (identifier? (cadr clause))\n (identifier=? (the ",
"'=>) (make-identifier (cadr clause) env)))\n (let ((tmp (m",
"ake-identifier 'tmp here)))\n (list (the 'let) (list (li",
"st tmp (car clause)))\n (list the-if tmp\n ",
" (list (car (cddr clause)) tmp)\n ",
" (cons (the 'cond) (cdr clauses)))))\n (l",
"ist the-if (car clause)\n (cons the-begin (cdr claus",
"e))\n (cons (the 'cond) (cdr clauses)))))))))))\n\n(de",
"fine-macro quasiquote\n (lambda (form env)\n\n (define (quasiquote? form)\n ",
" (and (pair? form)\n (identifier? (car form))\n (identifier=? ",
"(the 'quasiquote) (make-identifier (car form) env))))\n\n (define (unquote? for",
"m)\n (and (pair? form)\n (identifier? (car form))\n (ident",
"ifier=? (the 'unquote) (make-identifier (car form) env))))\n\n (define (unquote",
"-splicing? form)\n (and (pair? form)\n (pair? (car form))\n ",
" (identifier? (caar form))\n (identifier=? (the 'unquote-splicing) (ma",
"ke-identifier (caar form) env))))\n\n (define (qq depth expr)\n (cond\n ",
" ;; unquote\n ((unquote? expr)\n (if (= depth 1)\n (car (c",
"dr expr))\n (list (the 'list)\n (list (the 'quote) (th",
"e 'unquote))\n (qq (- depth 1) (car (cdr expr))))))\n ;; un",
"quote-splicing\n ((unquote-splicing? expr)\n (if (= depth 1)\n ",
" (list (the 'append)\n (car (cdr (car expr)))\n ",
" (qq depth (cdr expr)))\n (list (the 'cons)\n (list ",
"(the 'list)\n (list (the 'quote) (the 'unquote-splicing))\n",
" (qq (- depth 1) (car (cdr (car expr)))))\n ",
" (qq depth (cdr expr)))))\n ;; quasiquote\n ((quasiquote? expr)\n ",
" (list (the 'list)\n (list (the 'quote) (the 'quasiquote))\n ",
" (qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n",
" (list (the 'cons)\n (qq depth (car expr))\n (qq ",
"depth (cdr expr))))\n ;; vector\n ((vector? expr)\n (list (the '",
"list->vector) (qq depth (vector->list expr))))\n ;; simple datum\n (el",
"se\n (list (the 'quote) expr))))\n\n (let ((x (cadr form)))\n (qq 1 x",
"))))\n\n(define-macro let*\n (lambda (form env)\n (let ((bindings (car (cdr form",
")))\n (body (cdr (cdr form))))\n (if (null? bindings)\n ",
"`(,(the 'let) () ,@body)\n `(,(the 'let) ((,(car (car bindings)) ,@(cdr ",
"(car bindings))))\n (,(the 'let*) (,@(cdr bindings))\n ,@bo",
"dy))))))\n\n(define-macro letrec\n (lambda (form env)\n `(,(the 'letrec*) ,@(cdr",
" form))))\n\n(define-macro letrec*\n (lambda (form env)\n (let ((bindings (car (",
"cdr form)))\n (body (cdr (cdr form))))\n (let ((variables (map (",
"lambda (v) `(,v #f)) (map car bindings)))\n (initials (map (lambda (v",
") `(,(the 'set!) ,@v)) bindings)))\n `(,(the 'let) (,@variables)\n ",
" ,@initials\n ,@body)))))\n\n(define-macro let-values\n (lambda (form env)",
"\n `(,(the 'let*-values) ,@(cdr form))))\n\n(define-macro let*-values\n (lambda ",
"(form env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form)",
")))\n (if (null? formal)\n `(,(the 'let) () ,@body)\n `(,(th",
"e 'call-with-values) (,the-lambda () ,@(cdr (car formal)))\n (,(the 'l",
"ambda) (,@(car (car formal)))\n (,(the 'let*-values) (,@(cdr formal))",
"\n ,@body)))))))\n\n(define-macro define-values\n (lambda (form env)\n ",
" (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n (l",
"et ((arguments (make-identifier 'arguments here)))\n `(,the-begin\n ",
" ,@(let loop ((formal formal))\n (if (pair? formal)\n ",
" `((,the-define ,(car formal) #undefined) ,@(loop (cdr formal)))\n ",
" (if (identifier? formal)\n `((,the-define ,formal #unde",
"fined))\n '())))\n (,(the 'call-with-values) (,the-l",
"ambda () ,@body)\n (,the-lambda\n ,arguments\n ,@(l",
"et loop ((formal formal) (args arguments))\n (if (pair? formal)\n ",
" `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr f",
"ormal) `(,(the 'cdr) ,args)))\n (if (identifier? formal)\n ",
" `((,the-set! ,formal ,args))\n '())))))",
")))))\n\n(define-macro do\n (lambda (form env)\n (let ((bindings (car (cdr form)",
"))\n (test (car (car (cdr (cdr form)))))\n (cleanup (cdr (c",
"ar (cdr (cdr form)))))\n (body (cdr (cdr (cdr form)))))\n (let (",
"(loop (make-identifier 'loop here)))\n `(,(the 'let) ,loop ,(map (lambda (",
"x) `(,(car x) ,(cadr x))) bindings)\n (,the-if ,test\n ",
"(,the-begin\n ,@cleanup)\n (,the-begin\n ",
" ,@body\n (,loop ,@(map (lambda (x) (if (null? (c",
"dr (cdr x))) (car x) (car (cdr (cdr x))))) bindings)))))))))\n\n(define-macro when",
"\n (lambda (form env)\n (let ((test (car (cdr form)))\n (body (cdr (cd",
"r form))))\n `(,the-if ,test\n (,the-begin ,@body)\n ",
" #undefined))))\n\n(define-macro unless\n (lambda (form env)\n (let ((test (",
"car (cdr form)))\n (body (cdr (cdr form))))\n `(,the-if ,test\n ",
" #undefined\n (,the-begin ,@body)))))\n\n(define-macro case",
"\n (lambda (form env)\n (let ((key (car (cdr form)))\n (clauses (c",
"dr (cdr form))))\n (let ((the-key (make-identifier 'key here)))\n `(,(",
"the 'let) ((,the-key ,key))\n ,(let loop ((clauses clauses))\n ",
" (if (null? clauses)\n #undefined\n (let ((clause",
" (car clauses)))\n `(,the-if ,(if (and (identifier? (car clause",
"))\n (identifier=? (the 'else) (make-identi",
"fier (car clause) env)))\n #t\n ",
" `(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-qu",
"ote ,x))) (car clause))))\n ,(if (and (identifier? (c",
"adr clause))\n (identifier=? (the '=>) (mak",
"e-identifier (cadr clause) env)))\n `(,(car (cdr",
" (cdr clause))) ,the-key)\n `(,the-begin ,@(cdr ",
"clause)))\n ,(loop (cdr clauses)))))))))))\n\n(define-m",
"acro parameterize\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ",
" (body (cdr (cdr form))))\n `(,(the 'with-parameter)\n (,(the 'l",
"ambda) ()\n ,@formal\n ,@body)))))\n\n(define-macro syntax-quote\n (",
"lambda (form env)\n (let ((renames '()))\n (letrec\n ((rename (lam",
"bda (var)\n (let ((x (assq var renames)))\n ",
" (if x\n (cadr x)\n (begin\n",
" (set! renames `((,var ,(make-identifier var env) (,",
"(the 'make-identifier) ',var ',env)) . ,renames))\n (",
"rename var))))))\n (walk (lambda (f form)\n (cond\n ",
" ((identifier? form)\n (f form))\n ",
" ((pair? form)\n `(,(the 'cons) (walk f (car form)) (wa",
"lk f (cdr form))))\n ((vector? form)\n `(,(",
"the 'list->vector) (walk f (vector->list form))))\n (else\n ",
" `(,(the 'quote) ,form))))))\n (let ((form (walk rename (c",
"adr form))))\n `(,(the 'let)\n ,(map cdr renames)\n ",
",form))))))\n\n(define-macro syntax-quasiquote\n (lambda (form env)\n (let ((ren",
"ames '()))\n (letrec\n ((rename (lambda (var)\n (",
"let ((x (assq var renames)))\n (if x\n ",
" (cadr x)\n (begin\n (se",
"t! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',e",
"nv)) . ,renames))\n (rename var)))))))\n\n (defi",
"ne (syntax-quasiquote? form)\n (and (pair? form)\n (identif",
"ier? (car form))\n (identifier=? (the 'syntax-quasiquote) (make-ide",
"ntifier (car form) env))))\n\n (define (syntax-unquote? form)\n (an",
"d (pair? form)\n (identifier? (car form))\n (identifie",
"r=? (the 'syntax-unquote) (make-identifier (car form) env))))\n\n (define (",
"syntax-unquote-splicing? form)\n (and (pair? form)\n (pair?",
" (car form))\n (identifier? (caar form))\n (identifier",
"=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env))))\n\n ",
"(define (qq depth expr)\n (cond\n ;; syntax-unquote\n ",
"((syntax-unquote? expr)\n (if (= depth 1)\n (car (cdr ex",
"pr))\n (list (the 'list)\n (list (the 'quote) ",
"(the 'syntax-unquote))\n (qq (- depth 1) (car (cdr expr)))))",
")\n ;; syntax-unquote-splicing\n ((syntax-unquote-splicing? ex",
"pr)\n (if (= depth 1)\n (list (the 'append)\n ",
" (car (cdr (car expr)))\n (qq depth (cdr expr)))\n ",
" (list (the 'cons)\n (list (the 'list)\n ",
" (list (the 'quote) (the 'syntax-unquote-splicing))\n ",
" (qq (- depth 1) (car (cdr (car expr)))))\n ",
" (qq depth (cdr expr)))))\n ;; syntax-quasiquote\n ((syntax-q",
"uasiquote? expr)\n (list (the 'list)\n (list (the 'quo",
"te) (the 'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))))\n ",
" ;; list\n ((pair? expr)\n (list (the 'cons)\n ",
" (qq depth (car expr))\n (qq depth (cdr expr))))\n ",
" ;; vector\n ((vector? expr)\n (list (the 'list->vector) (",
"qq depth (vector->list expr))))\n ;; identifier\n ((identifier",
"? expr)\n (rename expr))\n ;; simple datum\n (else\n ",
" (list (the 'quote) expr))))\n\n (let ((body (qq 1 (cadr form))))",
"\n `(,(the 'let)\n ,(map cdr renames)\n ,body))))))\n",
"\n(define (transformer f)\n (lambda (form env)\n (let ((register1 (make-registe",
"r))\n (register2 (make-register)))\n (letrec\n ((wrap (lambd",
"a (var1)\n (let ((var2 (register1 var1)))\n ",
"(if var2\n (cdr var2)\n (let ((var",
"2 (make-identifier var1 env)))\n (register1 var1 var2)\n",
" (register2 var2 var1)\n var2",
")))))\n (unwrap (lambda (var2)\n (let ((var1 (regist",
"er2 var2)))\n (if var1\n (cdr var1",
")\n var2))))\n (walk (lambda (f form)\n ",
" (cond\n ((identifier? form)\n (f",
" form))\n ((pair? form)\n (cons (walk f (ca",
"r form)) (walk f (cdr form))))\n ((vector? form)\n ",
" (list->vector (walk f (vector->list form))))\n (else\n ",
" form)))))\n (let ((form (cdr form)))\n (walk u",
"nwrap (apply f (walk wrap form))))))))\n\n(define-macro define-syntax\n (lambda (f",
"orm env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form)))",
")\n (if (pair? formal)\n `(,(the 'define-syntax) ,(car formal) (,the",
"-lambda ,(cdr formal) ,@body))\n `(,the-define-macro ,formal (,(the 'tra",
"nsformer) (,the-begin ,@body)))))))\n\n(define-macro letrec-syntax\n (lambda (form",
" env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n ",
" `(let ()\n ,@(map (lambda (x)\n `(,(the 'define-synt",
"ax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n(define-ma",
"cro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(cdr form))))\n",
"\n\n;;; library primitives\n\n(define-macro define-library\n (lambda (form _)\n (l",
"et ((name (cadr form))\n (body (cddr form)))\n (let ((new-library (o",
"r (find-library name) (make-library name))))\n (for-each (lambda (expr) (e",
"val expr new-library)) body)))))\n\n(define-macro cond-expand\n (lambda (form _)\n ",
" (letrec\n ((test (lambda (form)\n (or\n ",
"(eq? form 'else)\n (and (symbol? form)\n (m",
"emq form (features)))\n (and (pair? form)\n ",
" (case (car form)\n ((library) (find-library (cadr form))",
")\n ((not) (not (test (cadr form))))\n ",
" ((and) (let loop ((form (cdr form)))\n (or ",
"(null? form)\n (and (test (car form)) (loop ",
"(cdr form))))))\n ((or) (let loop ((form (cdr form)))\n ",
" (and (pair? form)\n ",
" (or (test (car form)) (loop (cdr form))))))\n (else",
" #f)))))))\n (let loop ((clauses (cdr form)))\n (if (null? clauses)\n ",
" #undefined\n (if (test (caar clauses))\n `(,th",
"e-begin ,@(cdar clauses))\n (loop (cdr clauses))))))))\n\n(define-ma",
"cro import\n (lambda (form _)\n (let ((caddr\n (lambda (x) (car (cdr ",
"(cdr x)))))\n (prefix\n (lambda (prefix symbol)\n (s",
"tring->symbol\n (string-append\n (symbol->string prefix",
")\n (symbol->string symbol))))))\n (letrec\n ((extract\n",
" (lambda (spec)\n (case (car spec)\n ((only",
" rename prefix except)\n (extract (cadr spec)))\n (",
"else\n (or (find-library spec) (error \"library not found\" spec)))",
")))\n (collect\n (lambda (spec)\n (case (car spec",
")\n ((only)\n (let ((alist (collect (cadr spec))))\n",
" (map (lambda (var) (assq var alist)) (cddr spec))))\n ",
" ((rename)\n (let ((alist (collect (cadr spec)))\n ",
" (renames (map (lambda (x) `((car x) . (cadr x))) (cddr spec))))\n ",
" (map (lambda (s) (or (assq (car s) renames) s)) alist)))\n ",
" ((prefix)\n (let ((alist (collect (cadr spec))))\n ",
" (map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist",
")))\n ((except)\n (let ((alist (collect (cadr spec)",
")))\n (let loop ((alist alist))\n (if (null?",
" alist)\n '()\n (if (memq (caar al",
"ist) (cddr spec))\n (loop (cdr alist))\n ",
" (cons (car alist) (loop (cdr alist))))))))\n (else\n",
" (let ((lib (or (find-library spec) (error \"library not found\" s",
"pec))))\n (map (lambda (x) (cons x x)) (library-exports lib))))",
"))))\n (letrec\n ((import\n (lambda (spec)\n ",
" (let ((lib (extract spec))\n (alist (collect spec)",
"))\n (for-each\n (lambda (slot)\n ",
" (library-import lib (cdr slot) (car slot)))\n alist))",
")))\n (for-each import (cdr form)))))))\n\n(define-macro export\n (lambda ",
"(form _)\n (letrec\n ((collect\n (lambda (spec)\n (con",
"d\n ((symbol? spec)\n `(,spec . ,spec))\n ((an",
"d (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n `(,(l",
"ist-ref spec 1) . ,(list-ref spec 2)))\n (else\n (error \"",
"malformed export\")))))\n (export\n (lambda (spec)\n (",
"let ((slot (collect spec)))\n (library-export (car slot) (cdr slot)",
")))))\n (for-each export (cdr form)))))\n\n(export define lambda quote set! if",
" begin define-macro\n let let* letrec letrec*\n let-values let*-valu",
"es define-values\n quasiquote unquote unquote-splicing\n and or\n ",
" cond case else =>\n do when unless\n parameterize\n define",
"-syntax\n syntax-quote syntax-unquote\n syntax-quasiquote syntax-unq",
"uote-splicing\n let-syntax letrec-syntax\n syntax-error)\n\n\n",
"",
""
};

1152
extlib/benz/codegen.c
View File

File diff suppressed because it is too large Load Diff

4
extlib/benz/cont.c
View File

@ -85,13 +85,13 @@ pic_load_point(pic_state *pic, struct pic_cont *cont)
static pic_value
cont_call(pic_state *pic)
{
struct pic_proc *self = pic_get_proc(pic);
struct pic_proc *self;
int argc;
pic_value *argv;
int id;
struct pic_cont *cc, *cont;
pic_get_args(pic, "*", &argc, &argv);
pic_get_args(pic, "&*", &self, &argc, &argv);
id = pic_int(pic_proc_env_ref(pic, self, "id"));

12
extlib/benz/debug.c
View File

@ -11,18 +11,18 @@ pic_get_backtrace(pic_state *pic)
pic_callinfo *ci;
pic_str *trace;
trace = pic_make_str(pic, NULL, 0);
trace = pic_make_lit(pic, "");
for (ci = pic->ci; ci != pic->cibase; --ci) {
struct pic_proc *proc = pic_proc_ptr(ci->fp[0]);
trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " at "));
trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, "(anonymous lambda)"));
trace = pic_str_cat(pic, trace, pic_make_lit(pic, " at "));
trace = pic_str_cat(pic, trace, pic_make_lit(pic, "(anonymous lambda)"));
if (pic_proc_func_p(proc)) {
trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (native function)\n"));
trace = pic_str_cat(pic, trace, pic_make_lit(pic, " (native function)\n"));
} else if (pic_proc_irep_p(proc)) {
trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (unknown location)\n")); /* TODO */
trace = pic_str_cat(pic, trace, pic_make_lit(pic, " (unknown location)\n")); /* TODO */
}
}
@ -45,7 +45,7 @@ pic_print_backtrace(pic_state *pic, xFILE *file)
pic_value elem, it;
e = pic_error_ptr(pic->err);
if (e->type != pic_intern(pic, "")) {
if (e->type != pic_intern_lit(pic, "")) {
pic_fwrite(pic, pic_obj_value(e->type), file);
xfprintf(pic, file, " ");
}

25
extlib/benz/error.c
View File

@ -21,43 +21,42 @@ void
pic_warnf(pic_state *pic, const char *fmt, ...)
{
va_list ap;
pic_value err_line;
pic_str *err;
va_start(ap, fmt);
err_line = pic_xvformat(pic, fmt, ap);
err = pic_vformat(pic, fmt, ap);
va_end(ap);
xfprintf(pic, pic_stderr(pic)->file, "warn: %s\n", pic_str_cstr(pic, pic_str_ptr(pic_car(pic, err_line))));
xfprintf(pic, pic_stderr(pic)->file, "warn: %s\n", pic_str_cstr(pic, err));
}
void
pic_errorf(pic_state *pic, const char *fmt, ...)
{
va_list ap;
pic_value err_line, irrs;
const char *msg;
pic_str *err;
va_start(ap, fmt);
err_line = pic_xvformat(pic, fmt, ap);
err = pic_vformat(pic, fmt, ap);
va_end(ap);
msg = pic_str_cstr(pic, pic_str_ptr(pic_car(pic, err_line)));
irrs = pic_cdr(pic, err_line);
msg = pic_str_cstr(pic, err);
pic_error(pic, msg, irrs);
pic_error(pic, msg, pic_nil_value());
}
pic_value
pic_native_exception_handler(pic_state *pic)
{
pic_value err;
struct pic_proc *cont;
struct pic_proc *self, *cont;
pic_get_args(pic, "o", &err);
pic_get_args(pic, "&o", &self, &err);
pic->err = err;
cont = pic_proc_ptr(pic_proc_env_ref(pic, pic_get_proc(pic), "cont"));
cont = pic_proc_ptr(pic_proc_env_ref(pic, self, "cont"));
pic_apply1(pic, cont, pic_false_value());
@ -101,7 +100,7 @@ pic_make_error(pic_state *pic, pic_sym *type, const char *msg, pic_value irrs)
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->msg = pic_make_cstr(pic, msg);
e->irrs = irrs;
e->stack = stack;
@ -142,7 +141,7 @@ pic_error(pic_state *pic, const char *msg, pic_value irrs)
{
struct pic_error *e;
e = pic_make_error(pic, pic_intern(pic, ""), msg, irrs);
e = pic_make_error(pic, pic_intern_lit(pic, ""), msg, irrs);
pic_raise(pic, pic_obj_value(e));
}

905
extlib/benz/eval.c
View File

@ -3,27 +3,916 @@
*/
#include "picrin.h"
#include "picrin/opcode.h"
static pic_value
optimize_beta(pic_state *pic, pic_value expr)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value functor, formals, args, tmp, val, it, defs;
if (! pic_list_p(expr))
return expr;
if (pic_nil_p(expr))
return expr;
if (pic_sym_p(pic_list_ref(pic, expr, 0))) {
pic_sym *sym = pic_sym_ptr(pic_list_ref(pic, expr, 0));
if (sym == pic->sQUOTE) {
return expr;
} else if (sym == pic->sLAMBDA) {
return pic_list3(pic, pic_list_ref(pic, expr, 0), pic_list_ref(pic, expr, 1), optimize_beta(pic, pic_list_ref(pic, expr, 2)));
}
}
tmp = pic_nil_value();
pic_for_each (val, expr, it) {
pic_push(pic, optimize_beta(pic, val), tmp);
}
expr = pic_reverse(pic, tmp);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, expr);
functor = pic_list_ref(pic, expr, 0);
if (pic_pair_p(functor) && pic_eq_p(pic_car(pic, functor), pic_obj_value(pic->sLAMBDA))) {
formals = pic_list_ref(pic, functor, 1);
if (! pic_list_p(formals))
goto exit; /* TODO: support ((lambda args x) 1 2) */
args = pic_cdr(pic, expr);
if (pic_length(pic, formals) != pic_length(pic, args))
goto exit;
defs = pic_nil_value();
pic_for_each (val, args, it) {
pic_push(pic, pic_list3(pic, pic_obj_value(pic->sDEFINE), pic_car(pic, formals), val), defs);
formals = pic_cdr(pic, formals);
}
expr = pic_list_ref(pic, functor, 2);
pic_for_each (val, defs, it) {
expr = pic_list3(pic, pic_obj_value(pic->sBEGIN), val, expr);
}
}
exit:
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, expr);
return expr;
}
static pic_value
pic_optimize(pic_state *pic, pic_value expr)
{
return optimize_beta(pic, expr);
}
KHASH_DECLARE(a, pic_sym *, int)
KHASH_DEFINE2(a, pic_sym *, int, 0, kh_ptr_hash_func, kh_ptr_hash_equal)
/**
* TODO: don't use khash_t, use kvec_t instead
*/
typedef struct analyze_scope {
int depth;
pic_sym *rest; /* Nullable */
khash_t(a) args, locals, captures; /* rest args variable is counted as a local */
pic_value defer;
struct analyze_scope *up;
} analyze_scope;
static void
analyzer_scope_init(pic_state *pic, analyze_scope *scope, pic_value formal, analyze_scope *up)
{
int ret;
kh_init(a, &scope->args);
kh_init(a, &scope->locals);
kh_init(a, &scope->captures);
/* analyze formal */
for (; pic_pair_p(formal); formal = pic_cdr(pic, formal)) {
kh_put(a, &scope->args, pic_sym_ptr(pic_car(pic, formal)), &ret);
}
if (pic_nil_p(formal)) {
scope->rest = NULL;
}
else {
scope->rest = pic_sym_ptr(formal);
kh_put(a, &scope->locals, pic_sym_ptr(formal), &ret);
}
scope->up = up;
scope->depth = up ? up->depth + 1 : 0;
scope->defer = pic_list1(pic, pic_nil_value());
}
static void
analyzer_scope_destroy(pic_state *pic, analyze_scope *scope)
{
kh_destroy(a, &scope->args);
kh_destroy(a, &scope->locals);
kh_destroy(a, &scope->captures);
}
static bool
search_scope(pic_state *pic, analyze_scope *scope, pic_sym *sym)
{
return kh_get(a, &scope->args, sym) != kh_end(&scope->args) || kh_get(a, &scope->locals, sym) != kh_end(&scope->locals) || scope->depth == 0;
}
static int
find_var(pic_state *pic, analyze_scope *scope, pic_sym *sym)
{
int depth = 0, ret;
while (scope) {
if (search_scope(pic, scope, sym)) {
if (depth > 0) {
kh_put(a, &scope->captures, sym, &ret); /* capture! */
}
return depth;
}
depth++;
scope = scope->up;
}
PIC_UNREACHABLE();
}
static void
define_var(pic_state *pic, analyze_scope *scope, pic_sym *sym)
{
int ret;
if (search_scope(pic, scope, sym)) {
if (scope->depth > 0 || pic_reg_has(pic, pic->globals, sym)) {
pic_warnf(pic, "redefining variable: ~s", pic_obj_value(sym));
}
return;
}
pic_reg_set(pic, pic->globals, sym, pic_invalid_value());
kh_put(a, &scope->locals, sym, &ret);
}
static pic_value analyze(pic_state *, analyze_scope *, pic_value);
static pic_value analyze_lambda(pic_state *, analyze_scope *, pic_value);
#define GREF pic_intern_lit(pic, "gref")
#define LREF pic_intern_lit(pic, "lref")
#define CREF pic_intern_lit(pic, "cref")
#define CALL pic_intern_lit(pic, "call")
static pic_value
analyze_var(pic_state *pic, analyze_scope *scope, pic_sym *sym)
{
int depth;
depth = find_var(pic, scope, sym);
if (depth == scope->depth) {
return pic_list2(pic, pic_obj_value(GREF), pic_obj_value(sym));
} else if (depth == 0) {
return pic_list2(pic, pic_obj_value(LREF), pic_obj_value(sym));
} else {
return pic_list3(pic, pic_obj_value(CREF), pic_int_value(depth), pic_obj_value(sym));
}
}
static pic_value
analyze_defer(pic_state *pic, analyze_scope *scope, pic_value form)
{
pic_value skel = pic_cons(pic, pic_invalid_value(), pic_invalid_value());
pic_set_car(pic, scope->defer, pic_acons(pic, form, skel, pic_car(pic, scope->defer)));
return skel;
}
static void
analyze_deferred(pic_state *pic, analyze_scope *scope)
{
pic_value defer, val, src, dst, it;
scope->defer = pic_car(pic, scope->defer);
pic_for_each (defer, pic_reverse(pic, scope->defer), it) {
src = pic_car(pic, defer);
dst = pic_cdr(pic, defer);
val = analyze_lambda(pic, scope, src);
/* copy */
pic_set_car(pic, dst, pic_car(pic, val));
pic_set_cdr(pic, dst, pic_cdr(pic, val));
}
}
static pic_value
analyze_lambda(pic_state *pic, analyze_scope *up, pic_value form)
{
analyze_scope s, *scope = &s;
pic_value formals, body;
pic_value rest = pic_undef_value();
pic_vec *args, *locals, *captures;
int i, j;
khiter_t it;
formals = pic_list_ref(pic, form, 1);
body = pic_list_ref(pic, form, 2);
analyzer_scope_init(pic, scope, formals, up);
/* analyze body */
body = analyze(pic, scope, body);
analyze_deferred(pic, scope);
args = pic_make_vec(pic, kh_size(&scope->args));
for (i = 0; pic_pair_p(formals); formals = pic_cdr(pic, formals), i++) {
args->data[i] = pic_car(pic, formals);
}
if (scope->rest != NULL) {
rest = pic_obj_value(scope->rest);
}
locals = pic_make_vec(pic, kh_size(&scope->locals));
j = 0;
if (scope->rest != NULL) {
locals->data[j++] = pic_obj_value(scope->rest);
}
for (it = kh_begin(&scope->locals); it < kh_end(&scope->locals); ++it) {
if (kh_exist(&scope->locals, it)) {
if (scope->rest != NULL && kh_key(&scope->locals, it) == scope->rest)
continue;
locals->data[j++] = pic_obj_value(kh_key(&scope->locals, it));
}
}
captures = pic_make_vec(pic, kh_size(&scope->captures));
for (it = kh_begin(&scope->captures), j = 0; it < kh_end(&scope->captures); ++it) {
if (kh_exist(&scope->captures, it)) {
captures->data[j++] = pic_obj_value(kh_key(&scope->captures, it));
}
}
analyzer_scope_destroy(pic, scope);
return pic_list6(pic, pic_obj_value(pic->sLAMBDA), rest, pic_obj_value(args), pic_obj_value(locals), pic_obj_value(captures), body);
}
static pic_value
analyze_list(pic_state *pic, analyze_scope *scope, pic_value obj)
{
pic_value seq = pic_nil_value(), val, it;
pic_for_each (val, obj, it) {
pic_push(pic, analyze(pic, scope, val), seq);
}
return pic_reverse(pic, seq);
}
static pic_value
analyze_define(pic_state *pic, analyze_scope *scope, pic_value obj)
{
define_var(pic, scope, pic_sym_ptr(pic_list_ref(pic, obj, 1)));
return pic_cons(pic, pic_car(pic, obj), analyze_list(pic, scope, pic_cdr(pic, obj)));
}
static pic_value
analyze_call(pic_state *pic, analyze_scope *scope, pic_value obj)
{
return pic_cons(pic, pic_obj_value(CALL), analyze_list(pic, scope, obj));
}
static pic_value
analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj)
{
switch (pic_type(obj)) {
case PIC_TT_SYMBOL: {
return analyze_var(pic, scope, pic_sym_ptr(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_ptr(proc);
if (sym == pic->sDEFINE) {
return analyze_define(pic, scope, obj);
}
else if (sym == pic->sLAMBDA) {
return analyze_defer(pic, scope, obj);
}
else if (sym == pic->sQUOTE) {
return obj;
}
else if (sym == pic->sBEGIN || sym == pic->sSETBANG || sym == pic->sIF) {
return pic_cons(pic, pic_car(pic, obj), analyze_list(pic, scope, pic_cdr(pic, obj)));
}
}
return analyze_call(pic, scope, obj);
}
default:
return pic_list2(pic, pic_obj_value(pic->sQUOTE), obj);
}
}
static pic_value
analyze(pic_state *pic, analyze_scope *scope, pic_value obj)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value res;
res = analyze_node(pic, scope, obj);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, res);
return res;
}
static pic_value
pic_analyze(pic_state *pic, pic_value obj)
{
analyze_scope s, *scope = &s;
analyzer_scope_init(pic, scope, pic_nil_value(), NULL);
obj = analyze(pic, scope, obj);
analyze_deferred(pic, scope);
analyzer_scope_destroy(pic, scope);
return obj;
}
typedef struct codegen_context {
/* rest args variable is counted as a local */
pic_sym *rest;
pic_vec *args, *locals, *captures;
/* actual bit code sequence */
pic_code *code;
size_t clen, ccapa;
/* child ireps */
union irep_node *irep;
size_t ilen, icapa;
/* constant object pool */
int *ints;
size_t klen, kcapa;
double *nums;
size_t flen, fcapa;
struct pic_object **pool;
size_t plen, pcapa;
struct codegen_context *up;
} codegen_context;
static void create_activation(pic_state *, codegen_context *);
static void
codegen_context_init(pic_state *pic, codegen_context *cxt, codegen_context *up, pic_sym *rest, pic_vec *args, pic_vec *locals, pic_vec *captures)
{
cxt->up = up;
cxt->rest = rest;
cxt->args = args;
cxt->locals = locals;
cxt->captures = captures;
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(union irep_node));
cxt->ilen = 0;
cxt->icapa = PIC_IREP_SIZE;
cxt->pool = pic_calloc(pic, PIC_POOL_SIZE, sizeof(struct pic_object *));
cxt->plen = 0;
cxt->pcapa = PIC_POOL_SIZE;
cxt->ints = pic_calloc(pic, PIC_POOL_SIZE, sizeof(int));
cxt->klen = 0;
cxt->kcapa = PIC_POOL_SIZE;
cxt->nums = pic_calloc(pic, PIC_POOL_SIZE, sizeof(double));
cxt->flen = 0;
cxt->fcapa = PIC_POOL_SIZE;
create_activation(pic, cxt);
}
static struct pic_irep *
codegen_context_destroy(pic_state *pic, codegen_context *cxt)
{
struct pic_irep *irep;
/* create irep */
irep = pic_malloc(pic, sizeof(struct pic_irep));
irep->refc = 1;
irep->varg = cxt->rest != NULL;
irep->argc = (int)cxt->args->len + 1;
irep->localc = (int)cxt->locals->len;
irep->capturec = (int)cxt->captures->len;
irep->u.s.code = pic_realloc(pic, cxt->code, sizeof(pic_code) * cxt->clen);
irep->u.s.irep = pic_realloc(pic, cxt->irep, sizeof(union irep_node) * cxt->ilen);
irep->u.s.ints = pic_realloc(pic, cxt->ints, sizeof(int) * cxt->klen);
irep->u.s.nums = pic_realloc(pic, cxt->nums, sizeof(double) * cxt->flen);
irep->pool = pic_realloc(pic, cxt->pool, sizeof(struct pic_object *) * cxt->plen);
irep->ncode = cxt->clen;
irep->nirep = cxt->ilen;
irep->nints = cxt->klen;
irep->nnums = cxt->flen;
irep->npool = cxt->plen;
irep->list.next = pic->ireps.next;
irep->list.prev = &pic->ireps;
irep->list.next->prev = &irep->list;
irep->list.prev->next = &irep->list;
return irep;
}
#define check_size(pic, cxt, x, name, type) do { \
if (cxt->x##len >= cxt->x##capa) { \
cxt->x##capa *= 2; \
cxt->name = pic_realloc(pic, cxt->name, sizeof(type) * cxt->x##capa); \
} \
} while (0)
#define check_code_size(pic, cxt) check_size(pic, cxt, c, code, pic_code)
#define check_irep_size(pic, cxt) check_size(pic, cxt, i, irep, struct pic_irep *)
#define check_pool_size(pic, cxt) check_size(pic, cxt, p, pool, struct pic_object *)
#define check_ints_size(pic, cxt) check_size(pic, cxt, k, ints, int)
#define check_nums_size(pic, cxt) check_size(pic, cxt, f, nums, double)
#define emit_n(pic, cxt, ins) do { \
check_code_size(pic, cxt); \
cxt->code[cxt->clen].insn = ins; \
cxt->clen++; \
} while (0) \
#define emit_i(pic, cxt, ins, I) do { \
check_code_size(pic, cxt); \
cxt->code[cxt->clen].insn = ins; \
cxt->code[cxt->clen].a = I; \
cxt->clen++; \
} while (0) \
#define emit_r(pic, cxt, ins, D, I) do { \
check_code_size(pic, cxt); \
cxt->code[cxt->clen].insn = ins; \
cxt->code[cxt->clen].a = D; \
cxt->code[cxt->clen].b = I; \
cxt->clen++; \
} while (0) \
#define emit_ret(pic, cxt, tailpos) if (tailpos) emit_n(pic, cxt, OP_RET)
static int
index_capture(codegen_context *cxt, pic_sym *sym, int depth)
{
int i;
while (depth-- > 0) {
cxt = cxt->up;
}
for (i = 0; i < cxt->captures->len; ++i) {
if (pic_sym_ptr(cxt->captures->data[i]) == sym)
return i;
}
return -1;
}
static int
index_local(codegen_context *cxt, pic_sym *sym)
{
int i, offset;
offset = 1;
for (i = 0; i < cxt->args->len; ++i) {
if (pic_sym_ptr(cxt->args->data[i]) == sym)
return i + offset;
}
offset += i;
for (i = 0; i < cxt->locals->len; ++i) {
if (pic_sym_ptr(cxt->locals->data[i]) == sym)
return i + offset;
}
return -1;
}
static int
index_global(pic_state *pic, codegen_context *cxt, pic_sym *name)
{
int pidx;
check_pool_size(pic, cxt);
pidx = (int)cxt->plen++;
cxt->pool[pidx] = (struct pic_object *)name;
return pidx;
}
static void
create_activation(pic_state *pic, codegen_context *cxt)
{
int i, n;
for (i = 0; i < cxt->captures->len; ++i) {
n = index_local(cxt, pic_sym_ptr(cxt->captures->data[i]));
assert(n != -1);
if (n <= cxt->args->len || cxt->rest == pic_sym_ptr(cxt->captures->data[i])) {
/* copy arguments to capture variable area */
emit_i(pic, cxt, OP_LREF, n);
} else {
/* otherwise, just extend the stack */
emit_n(pic, cxt, OP_PUSHUNDEF);
}
}
}
static void codegen(pic_state *, codegen_context *, pic_value, bool);
static void
codegen_ref(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
{
pic_sym *sym;
sym = pic_sym_ptr(pic_car(pic, obj));
if (sym == GREF) {
pic_sym *name;
name = pic_sym_ptr(pic_list_ref(pic, obj, 1));
emit_i(pic, cxt, OP_GREF, index_global(pic, cxt, name));
emit_ret(pic, cxt, tailpos);
}
else if (sym == CREF) {
pic_sym *name;
int depth;
depth = pic_int(pic_list_ref(pic, obj, 1));
name = pic_sym_ptr(pic_list_ref(pic, obj, 2));
emit_r(pic, cxt, OP_CREF, depth, index_capture(cxt, name, depth));
emit_ret(pic, cxt, tailpos);
}
else if (sym == LREF) {
pic_sym *name;
int i;
name = pic_sym_ptr(pic_list_ref(pic, obj, 1));
if ((i = index_capture(cxt, name, 0)) != -1) {
emit_i(pic, cxt, OP_LREF, i + (int)cxt->args->len + (int)cxt->locals->len + 1);
emit_ret(pic, cxt, tailpos);
} else {
emit_i(pic, cxt, OP_LREF, index_local(cxt, name));
emit_ret(pic, cxt, tailpos);
}
}
}
static void
codegen_set(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
{
pic_value var, val;
pic_sym *type;
val = pic_list_ref(pic, obj, 2);
codegen(pic, cxt, val, false);
var = pic_list_ref(pic, obj, 1);
type = pic_sym_ptr(pic_list_ref(pic, var, 0));
if (type == GREF) {
pic_sym *name;
name = pic_sym_ptr(pic_list_ref(pic, var, 1));
emit_i(pic, cxt, OP_GSET, index_global(pic, cxt, name));
emit_ret(pic, cxt, tailpos);
}
else if (type == CREF) {
pic_sym *name;
int depth;
depth = pic_int(pic_list_ref(pic, var, 1));
name = pic_sym_ptr(pic_list_ref(pic, var, 2));
emit_r(pic, cxt, OP_CSET, depth, index_capture(cxt, name, depth));
emit_ret(pic, cxt, tailpos);
}
else if (type == LREF) {
pic_sym *name;
int i;
name = pic_sym_ptr(pic_list_ref(pic, var, 1));
if ((i = index_capture(cxt, name, 0)) != -1) {
emit_i(pic, cxt, OP_LSET, i + (int)cxt->args->len + (int)cxt->locals->len + 1);
emit_ret(pic, cxt, tailpos);
} else {
emit_i(pic, cxt, OP_LSET, index_local(cxt, name));
emit_ret(pic, cxt, tailpos);
}
}
}
static void
codegen_lambda(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
{
codegen_context c, *inner_cxt = &c;
pic_value rest_opt, body;
pic_sym *rest = NULL;
pic_vec *args, *locals, *captures;
check_irep_size(pic, cxt);
/* extract arguments */
rest_opt = pic_list_ref(pic, obj, 1);
if (pic_sym_p(rest_opt)) {
rest = pic_sym_ptr(rest_opt);
}
args = pic_vec_ptr(pic_list_ref(pic, obj, 2));
locals = pic_vec_ptr(pic_list_ref(pic, obj, 3));
captures = pic_vec_ptr(pic_list_ref(pic, obj, 4));
body = pic_list_ref(pic, obj, 5);
/* emit irep */
codegen_context_init(pic, inner_cxt, cxt, rest, args, locals, captures);
codegen(pic, inner_cxt, body, true);
cxt->irep[cxt->ilen].i = codegen_context_destroy(pic, inner_cxt);
/* emit OP_LAMBDA */
emit_i(pic, cxt, OP_LAMBDA, cxt->ilen++);
emit_ret(pic, cxt, tailpos);
}
static void
codegen_if(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
{
int s, t;
codegen(pic, cxt, pic_list_ref(pic, obj, 1), false);
s = (int)cxt->clen;
emit_n(pic, cxt, OP_JMPIF);
/* if false branch */
codegen(pic, cxt, pic_list_ref(pic, obj, 3), tailpos);
t = (int)cxt->clen;
emit_n(pic, cxt, OP_JMP);
cxt->code[s].a = (int)cxt->clen - s;
/* if true branch */
codegen(pic, cxt, pic_list_ref(pic, obj, 2), tailpos);
cxt->code[t].a = (int)cxt->clen - t;
}
static void
codegen_begin(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
{
codegen(pic, cxt, pic_list_ref(pic, obj, 1), false);
emit_n(pic, cxt, OP_POP);
codegen(pic, cxt, pic_list_ref(pic, obj, 2), tailpos);
}
static void
codegen_quote(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
{
int pidx;
obj = pic_list_ref(pic, obj, 1);
switch (pic_type(obj)) {
case PIC_TT_UNDEF:
emit_n(pic, cxt, OP_PUSHUNDEF);
break;
case PIC_TT_BOOL:
emit_n(pic, cxt, (pic_true_p(obj) ? OP_PUSHTRUE : OP_PUSHFALSE));
break;
case PIC_TT_INT:
check_ints_size(pic, cxt);
pidx = (int)cxt->klen++;
cxt->ints[pidx] = pic_int(obj);
emit_i(pic, cxt, OP_PUSHINT, pidx);
break;
case PIC_TT_FLOAT:
check_nums_size(pic, cxt);
pidx = (int)cxt->flen++;
cxt->nums[pidx] = pic_float(obj);
emit_i(pic, cxt, OP_PUSHFLOAT, pidx);
break;
case PIC_TT_NIL:
emit_n(pic, cxt, OP_PUSHNIL);
break;
case PIC_TT_EOF:
emit_n(pic, cxt, OP_PUSHEOF);
break;
case PIC_TT_CHAR:
check_ints_size(pic, cxt);
pidx = (int)cxt->klen++;
cxt->ints[pidx] = pic_char(obj);
emit_i(pic, cxt, OP_PUSHCHAR, pidx);
break;
default:
assert(pic_obj_p(obj));
check_pool_size(pic, cxt);
pidx = (int)cxt->plen++;
cxt->pool[pidx] = pic_obj_ptr(obj);
emit_i(pic, cxt, OP_PUSHCONST, pidx);
break;
}
emit_ret(pic, cxt, tailpos);
}
#define VM(uid, op) \
if (sym == uid) { \
emit_i(pic, cxt, op, len - 1); \
emit_ret(pic, cxt, tailpos); \
return; \
}
static void
codegen_call(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
{
int len = (int)pic_length(pic, obj);
pic_value elt, it, functor;
pic_for_each (elt, pic_cdr(pic, obj), it) {
codegen(pic, cxt, elt, false);
}
functor = pic_list_ref(pic, obj, 1);
if (pic_sym_ptr(pic_list_ref(pic, functor, 0)) == GREF) {
pic_sym *sym;
sym = pic_sym_ptr(pic_list_ref(pic, functor, 1));
VM(pic->sCONS, OP_CONS)
VM(pic->sCAR, OP_CAR)
VM(pic->sCDR, OP_CDR)
VM(pic->sNILP, OP_NILP)
VM(pic->sSYMBOLP, OP_SYMBOLP)
VM(pic->sPAIRP, OP_PAIRP)
VM(pic->sNOT, OP_NOT)
VM(pic->sEQ, OP_EQ)
VM(pic->sLT, OP_LT)
VM(pic->sLE, OP_LE)
VM(pic->sGT, OP_GT)
VM(pic->sGE, OP_GE)
VM(pic->sADD, OP_ADD)
VM(pic->sSUB, OP_SUB)
VM(pic->sMUL, OP_MUL)
VM(pic->sDIV, OP_DIV)
}
emit_i(pic, cxt, (tailpos ? OP_TAILCALL : OP_CALL), len - 1);
}
static void
codegen(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
{
pic_sym *sym;
sym = pic_sym_ptr(pic_car(pic, obj));
if (sym == GREF || sym == CREF || sym == LREF) {
codegen_ref(pic, cxt, obj, tailpos);
}
else if (sym == pic->sSETBANG || sym == pic->sDEFINE) {
codegen_set(pic, cxt, obj, tailpos);
}
else if (sym == pic->sLAMBDA) {
codegen_lambda(pic, cxt, obj, tailpos);
}
else if (sym == pic->sIF) {
codegen_if(pic, cxt, obj, tailpos);
}
else if (sym == pic->sBEGIN) {
codegen_begin(pic, cxt, obj, tailpos);
}
else if (sym == pic->sQUOTE) {
codegen_quote(pic, cxt, obj, tailpos);
}
else if (sym == CALL) {
codegen_call(pic, cxt, obj, tailpos);
}
else {
pic_errorf(pic, "codegen: unknown AST type ~s", obj);
}
}
static struct pic_irep *
pic_codegen(pic_state *pic, pic_value obj)
{
pic_vec *empty = pic_make_vec(pic, 0);
codegen_context c, *cxt = &c;
codegen_context_init(pic, cxt, NULL, NULL, empty, empty, empty);
codegen(pic, cxt, obj, true);
return codegen_context_destroy(pic, cxt);
}
#define SAVE(pic, ai, obj) pic_gc_arena_restore(pic, ai); pic_gc_protect(pic, obj)
struct pic_proc *
pic_compile(pic_state *pic, pic_value obj)
{
struct pic_irep *irep;
struct pic_proc *proc;
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_write(pic, obj);
fprintf(stdout, "\n");
fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
#endif
/* optimize */
obj = pic_optimize(pic, obj);
#if DEBUG
fprintf(stdout, "## optimize completed\n");
pic_write(pic, obj);
fprintf(stdout, "\n");
fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
#endif
SAVE(pic, ai, obj);
/* analyze */
obj = pic_analyze(pic, obj);
#if DEBUG
fprintf(stdout, "## analyzer completed\n");
pic_write(pic, obj);
fprintf(stdout, "\n");
fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
#endif
SAVE(pic, ai, obj);
/* 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
proc = pic_make_proc_irep(pic, irep, NULL);
pic_irep_decref(pic, irep);
return proc;
}
pic_value
pic_eval(pic_state *pic, pic_value program, struct pic_env *env)
pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib)
{
struct pic_proc *proc;
struct pic_lib *prev_lib = pic->lib;
pic_value r;
proc = pic_compile(pic, program, env);
pic->lib = lib;
pic_try {
r = pic_apply0(pic, pic_compile(pic, pic_expand(pic, program, lib->env)));
}
pic_catch {
pic->lib = prev_lib;
pic_raise(pic, pic->err);
}
pic->lib = prev_lib;
return pic_apply0(pic, proc);
return r;
}
static pic_value
pic_eval_eval(pic_state *pic)
{
pic_value program, env;
pic_value program, lib;
pic_get_args(pic, "oo", &program, &env);
pic_get_args(pic, "oo", &program, &lib);
pic_assert_type(pic, env, env);
pic_assert_type(pic, lib, lib);
return pic_eval(pic, program, pic_env_ptr(env));
return pic_eval(pic, program, pic_lib_ptr(lib));
}
void

82
extlib/benz/gc.c
View File

@ -32,11 +32,9 @@ struct pic_object {
struct pic_env env;
struct pic_proc proc;
struct pic_context cxt;
struct pic_irep irep;
struct pic_port port;
struct pic_error err;
struct pic_lib lib;
struct pic_box box;
struct pic_checkpoint cp;
} u;
};
@ -300,7 +298,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
}
case PIC_TT_PROC: {
if (pic_proc_irep_p(&obj->u.proc)) {
gc_mark_object(pic, (struct pic_object *)obj->u.proc.u.i.irep);
if (obj->u.proc.u.i.cxt) {
LOOP(obj->u.proc.u.i.cxt);
}
@ -335,8 +332,8 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
break;
}
case PIC_TT_ID: {
gc_mark(pic, obj->u.id.var);
LOOP(obj->u.id.env);
gc_mark_object(pic, (struct pic_object *)obj->u.id.u.id.id);
LOOP(obj->u.id.u.id.env);
break;
}
case PIC_TT_ENV: {
@ -345,10 +342,13 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
for (it = kh_begin(h); it != kh_end(h); ++it) {
if (kh_exist(h, it)) {
gc_mark_object(pic, kh_key(h, it));
gc_mark_object(pic, (struct pic_object *)kh_key(h, it));
gc_mark_object(pic, (struct pic_object *)kh_val(h, it));
}
}
if (obj->u.env.prefix) {
gc_mark_object(pic, (struct pic_object *)obj->u.env.prefix);
}
if (obj->u.env.up) {
LOOP(obj->u.env.up);
}
@ -360,17 +360,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
LOOP(obj->u.lib.exports);
break;
}
case PIC_TT_IREP: {
size_t i;
for (i = 0; i < obj->u.irep.ilen; ++i) {
gc_mark_object(pic, (struct pic_object *)obj->u.irep.irep[i]);
}
for (i = 0; i < obj->u.irep.plen; ++i) {
gc_mark(pic, obj->u.irep.pool[i]);
}
break;
}
case PIC_TT_DATA: {
if (obj->u.data.type->mark) {
obj->u.data.type->mark(pic, obj->u.data.data, gc_mark);
@ -388,11 +377,14 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
break;
}
case PIC_TT_RECORD: {
gc_mark_object(pic, (struct pic_object *)obj->u.rec.type);
LOOP(obj->u.rec.data);
gc_mark(pic, obj->u.rec.type);
if (pic_obj_p(obj->u.rec.datum)) {
LOOP(pic_obj_ptr(obj->u.rec.datum));
}
break;
}
case PIC_TT_SYMBOL: {
LOOP(obj->u.sym.str);
break;
}
case PIC_TT_REG: {
@ -402,12 +394,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
pic->heap->regs = reg;
break;
}
case PIC_TT_BOX: {
if (pic_obj_p(obj->u.box.value)) {
LOOP(pic_obj_ptr(obj->u.box.value));
}
break;
}
case PIC_TT_CP: {
if (obj->u.cp.prev) {
gc_mark_object(pic, (struct pic_object *)obj->u.cp.prev);
@ -433,7 +419,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
}
#define M(x) gc_mark_object(pic, (struct pic_object *)pic->x)
#define P(x) gc_mark(pic, pic->x)
static void
gc_mark_phase(pic_state *pic)
@ -441,6 +426,7 @@ gc_mark_phase(pic_state *pic)
pic_value *stack;
pic_callinfo *ci;
struct pic_proc **xhandler;
struct pic_list *list;
size_t j;
assert(pic->heap->regs == NULL);
@ -472,23 +458,22 @@ gc_mark_phase(pic_state *pic)
gc_mark_object(pic, (struct pic_object *)pic->arena[j]);
}
/* ireps */
for (list = pic->ireps.next; list != &pic->ireps; list = list->next) {
struct pic_irep *irep = (struct pic_irep *)list;
for (j = 0; j < irep->npool; ++j) {
gc_mark_object(pic, irep->pool[j]);
}
}
/* mark reserved symbols */
M(sDEFINE); M(sDEFINE_MACRO); M(sLAMBDA); M(sIF); M(sBEGIN); M(sSETBANG);
M(sQUOTE); M(sQUASIQUOTE); M(sUNQUOTE); M(sUNQUOTE_SPLICING);
M(sSYNTAX_QUOTE); M(sSYNTAX_QUASIQUOTE); M(sSYNTAX_UNQUOTE); M(sSYNTAX_UNQUOTE_SPLICING);
M(sDEFINE_LIBRARY); M(sIMPORT); M(sEXPORT); M(sCOND_EXPAND);
M(uDEFINE); M(uLAMBDA); M(uIF); M(uBEGIN); M(uQUOTE); M(uSETBANG); M(uDEFINE_MACRO);
M(uDEFINE_LIBRARY); M(uIMPORT); M(uEXPORT); M(uCOND_EXPAND);
M(uCONS); M(uCAR); M(uCDR); M(uNILP); M(uSYMBOLP); M(uPAIRP);
M(uADD); M(uSUB); M(uMUL); M(uDIV); M(uEQ); M(uLT); M(uLE); M(uGT); M(uGE); M(uNOT);
/* mark system procedures */
P(pCONS); P(pCAR); P(pCDR); P(pNILP); P(pSYMBOLP); P(pPAIRP); P(pNOT);
P(pADD); P(pSUB); P(pMUL); P(pDIV); P(pEQ); P(pLT); P(pLE); P(pGT); P(pGE);
M(cCONS); M(cCAR); M(cCDR); M(cNILP); M(cSYMBOLP); M(cPAIRP); M(cNOT);
M(cADD); M(cSUB); M(cMUL); M(cDIV); M(cEQ); M(cLT); M(cLE); M(cGT); M(cGE);
M(sCONS); M(sCAR); M(sCDR); M(sNILP); M(sSYMBOLP); M(sPAIRP);
M(sADD); M(sSUB); M(sMUL); M(sDIV); M(sEQ); M(sLT); M(sLE); M(sGT); M(sGE); M(sNOT);
/* global variables */
if (pic->globals) {
@ -500,11 +485,6 @@ gc_mark_phase(pic_state *pic)
gc_mark_object(pic, (struct pic_object *)pic->macros);
}
/* attribute table */
if (pic->attrs) {
gc_mark_object(pic, (struct pic_object *)pic->attrs);
}
/* error object */
gc_mark(pic, pic->err);
@ -569,12 +549,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
kh_destroy(env, &obj->u.env.map);
break;
}
case PIC_TT_IREP: {
pic_free(pic, obj->u.irep.code);
pic_free(pic, obj->u.irep.irep);
pic_free(pic, obj->u.irep.pool);
break;
}
case PIC_TT_DATA: {
if (obj->u.data.type->dtor) {
obj->u.data.type->dtor(pic, obj->u.data.data);
@ -586,24 +560,28 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
break;
}
case PIC_TT_SYMBOL: {
pic_free(pic, (void *)obj->u.sym.cstr);
/* TODO: remove this symbol's entry from pic->syms immediately */
break;
}
case PIC_TT_REG: {
kh_destroy(reg, &obj->u.reg.hash);
break;
}
case PIC_TT_PROC: {
if (pic_proc_irep_p(&obj->u.proc)) {
pic_irep_decref(pic, obj->u.proc.u.i.irep);
}
break;
}
case PIC_TT_PAIR:
case PIC_TT_CXT:
case PIC_TT_PROC:
case PIC_TT_PORT:
case PIC_TT_ERROR:
case PIC_TT_ID:
case PIC_TT_LIB:
case PIC_TT_RECORD:
case PIC_TT_CP:
case PIC_TT_BOX:
break;
case PIC_TT_NIL:

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

@ -35,7 +35,6 @@ extern "C" {
#include "picrin/config.h"
#include "picrin/compat.h"
#include "picrin/kvec.h"
#include "picrin/khash.h"
typedef struct pic_state pic_state;
@ -46,7 +45,7 @@ typedef struct pic_state pic_state;
#include "picrin/read.h"
#include "picrin/gc.h"
KHASH_DECLARE(s, const char *, pic_sym *)
KHASH_DECLARE(s, pic_str *, pic_sym *)
typedef struct pic_checkpoint {
PIC_OBJECT_HEADER
@ -95,22 +94,13 @@ struct pic_state {
struct pic_lib *lib, *prev_lib;
pic_sym *sDEFINE, *sDEFINE_MACRO, *sLAMBDA, *sIF, *sBEGIN, *sSETBANG;
pic_sym *sQUOTE, *sQUASIQUOTE, *sUNQUOTE, *sUNQUOTE_SPLICING;
pic_sym *sSYNTAX_QUOTE, *sSYNTAX_QUASIQUOTE;
pic_sym *sSYNTAX_UNQUOTE, *sSYNTAX_UNQUOTE_SPLICING;
pic_sym *sDEFINE_LIBRARY, *sIMPORT, *sEXPORT, *sCOND_EXPAND;
pic_sym *uDEFINE, *uLAMBDA, *uIF, *uBEGIN, *uQUOTE, *uSETBANG, *uDEFINE_MACRO;
pic_sym *uDEFINE_LIBRARY, *uIMPORT, *uEXPORT, *uCOND_EXPAND;
pic_sym *uCONS, *uCAR, *uCDR, *uNILP, *uSYMBOLP, *uPAIRP;
pic_sym *uADD, *uSUB, *uMUL, *uDIV, *uEQ, *uLT, *uLE, *uGT, *uGE, *uNOT;
pic_value pCONS, pCAR, pCDR, pNILP, pPAIRP, pSYMBOLP, pNOT;
pic_value pADD, pSUB, pMUL, pDIV, pEQ, pLT, pLE, pGT, pGE;
struct pic_box *cCONS, *cCAR, *cCDR, *cNILP, *cPAIRP, *cSYMBOLP, *cNOT;
struct pic_box *cADD, *cSUB, *cMUL, *cDIV, *cEQ, *cLT, *cLE, *cGT, *cGE;
pic_sym *sCONS, *sCAR, *sCDR, *sNILP, *sSYMBOLP, *sPAIRP;
pic_sym *sADD, *sSUB, *sMUL, *sDIV, *sEQ, *sLT, *sLE, *sGT, *sGE, *sNOT;
struct pic_lib *PICRIN_BASE;
struct pic_lib *PICRIN_USER;
@ -122,7 +112,7 @@ struct pic_state {
struct pic_reg *globals;
struct pic_reg *macros;
pic_value libs;
struct pic_reg *attrs;
struct pic_list ireps; /* chain */
pic_reader reader;
xFILE files[XOPEN_MAX];
@ -165,17 +155,12 @@ void pic_set_argv(pic_state *, int argc, char *argv[], char **envp);
void pic_add_feature(pic_state *, const char *);
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 *);
pic_sym *pic_intern_str(pic_state *, pic_str *);
const char *pic_symbol_name(pic_state *, pic_sym *);
pic_value pic_read(pic_state *, struct pic_port *);
pic_value pic_read_cstr(pic_state *, const char *);
@ -208,7 +193,7 @@ pic_value pic_apply5(pic_state *, struct pic_proc *, pic_value, pic_value, pic_v
pic_value pic_apply_list(pic_state *, struct pic_proc *, pic_value);
pic_value pic_apply_trampoline(pic_state *, struct pic_proc *, int, pic_value *);
pic_value pic_apply_trampoline_list(pic_state *, struct pic_proc *, pic_value);
pic_value pic_eval(pic_state *, pic_value, struct pic_env *);
pic_value pic_eval(pic_state *, pic_value, struct pic_lib *);
struct pic_proc *pic_make_var(pic_state *, pic_value, struct pic_proc *);
@ -235,10 +220,6 @@ void pic_warnf(pic_state *, const char *, ...);
pic_str *pic_get_backtrace(pic_state *);
void pic_print_backtrace(pic_state *, xFILE *);
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 *);
@ -270,7 +251,6 @@ pic_value pic_fdisplay(pic_state *, pic_value, xFILE *);
#include "picrin/symbol.h"
#include "picrin/vector.h"
#include "picrin/reg.h"
#include "picrin/box.h"
#if defined(__cplusplus)
}

34
extlib/benz/include/picrin/box.h
View File

@ -1,34 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#ifndef PICRIN_BOX_H
#define PICRIN_BOX_H
#if defined(__cplusplus)
extern "C" {
#endif
struct pic_box {
PIC_OBJECT_HEADER
pic_value value;
};
#define pic_box_p(v) (pic_type(v) == PIC_TT_BOX)
#define pic_box_ptr(v) ((struct pic_box *)pic_ptr(v))
PIC_INLINE struct pic_box *
pic_box(pic_state *pic, pic_value value)
{
struct pic_box *box;
box = (struct pic_box *)pic_obj_alloc(pic, sizeof(struct pic_box), PIC_TT_BOX);
box->value = value;
return box;
}
#if defined(__cplusplus)
}
#endif
#endif

46
extlib/benz/include/picrin/irep.h
View File

@ -11,31 +11,35 @@ extern "C" {
typedef struct {
int insn;
union {
int i;
char c;
struct {
int depth;
int idx;
} r;
} u;
int a;
int b;
} pic_code;
struct pic_irep {
PIC_OBJECT_HEADER
pic_code *code;
int argc, localc, capturec;
bool varg;
struct pic_irep **irep;
pic_value *pool;
size_t ilen, plen;
struct pic_list {
struct pic_list *prev, *next;
};
pic_sym *pic_resolve(pic_state *, pic_value, struct pic_env *);
pic_value pic_expand(pic_state *, pic_value, struct pic_env *);
pic_value pic_analyze(pic_state *, pic_value);
struct pic_irep *pic_codegen(pic_state *, pic_value);
struct pic_proc *pic_compile(pic_state *, pic_value, struct pic_env *);
struct pic_irep {
struct pic_list list;
unsigned refc;
int argc, localc, capturec;
bool varg;
union {
struct {
pic_code *code;
int *ints;
double *nums;
union irep_node {
struct pic_irep *i;
} *irep;
} s;
} u;
struct pic_object **pool; /* pool of heap objects */
size_t ncode, nirep, nints, nnums, npool;
};
void pic_irep_incref(pic_state *, struct pic_irep *);
void pic_irep_decref(pic_state *, struct pic_irep *);
#if defined(__cplusplus)
}

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

@ -27,6 +27,8 @@
#ifndef AC_KHASH_H
#define AC_KHASH_H
#include <stddef.h>
typedef int khint_t;
typedef khint_t khiter_t;
@ -41,23 +43,6 @@ typedef khint_t khiter_t;
#define ac_roundup32(x) \
(--(x), (x)|=(x)>>1, (x)|=(x)>>2, (x)|=(x)>>4, (x)|=(x)>>8, (x)|=(x)>>16, ++(x))
PIC_INLINE khint_t ac_X31_hash_string(const char *s)
{
khint_t h = (khint_t)*s;
if (h) for (++s ; *s; ++s) h = (h << 5) - h + (khint_t)*s;
return h;
}
PIC_INLINE khint_t ac_Wang_hash(khint_t key)
{
key += ~(key << 15);
key ^= (key >> 10);
key += (key << 3);
key ^= (key >> 6);
key += ~(key << 11);
key ^= (key >> 16);
return key;
}
#define ac_fsize(m) ((m) < 16? 1 : (m)>>4)
#define ac_hash_upper(x) ((((x) * 2) * 77 / 100 + 1) / 2)
@ -71,7 +56,7 @@ PIC_INLINE khint_t ac_Wang_hash(khint_t key)
void kh_init_##name(kh_##name##_t *h); \
void kh_destroy_##name(pic_state *, kh_##name##_t *h); \
void kh_clear_##name(kh_##name##_t *h); \
khint_t kh_get_##name(const kh_##name##_t *h, khkey_t key); \
khint_t kh_get_##name(pic_state *, const kh_##name##_t *h, khkey_t key); \
void kh_resize_##name(pic_state *, kh_##name##_t *h, khint_t new_n_buckets); \
khint_t kh_put_##name(pic_state *, kh_##name##_t *h, khkey_t key, int *ret); \
void kh_del_##name(kh_##name##_t *h, khint_t x);
@ -95,8 +80,9 @@ PIC_INLINE khint_t ac_Wang_hash(khint_t key)
h->size = h->n_occupied = 0; \
} \
} \
khint_t kh_get_##name(const kh_##name##_t *h, khkey_t key) \
khint_t kh_get_##name(pic_state *pic, const kh_##name##_t *h, khkey_t key) \
{ \
(void)pic; \
if (h->n_buckets) { \
khint_t k, i, last, mask, step = 0; \
mask = h->n_buckets - 1; \
@ -220,9 +206,6 @@ PIC_INLINE khint_t ac_Wang_hash(khint_t key)
#define kh_ptr_hash_equal(a, b) ((a) == (b))
#define kh_int_hash_func(key) (int)(key)
#define kh_int_hash_equal(a, b) ((a) == (b))
#define kh_str_hash_func(key) ac_X31_hash_string(key)
#define kh_str_hash_equal(a, b) (strcmp(a, b) == 0)
#define kh_int_hash_func2(k) ac_Wang_hash((khint_t)key)
/* --- END OF HASH FUNCTIONS --- */
@ -232,7 +215,7 @@ PIC_INLINE khint_t ac_Wang_hash(khint_t key)
#define kh_clear(name, h) kh_clear_##name(h)
#define kh_resize(name, h, s) kh_resize_##name(pic, h, s)
#define kh_put(name, h, k, r) kh_put_##name(pic, h, k, r)
#define kh_get(name, h, k) kh_get_##name(h, k)
#define kh_get(name, h, k) kh_get_##name(pic, h, k)
#define kh_del(name, h, k) kh_del_##name(h, k)
#define kh_exist(h, x) (!ac_iseither((h)->flags, (x)))

67
extlib/benz/include/picrin/kvec.h
View File

@ -1,67 +0,0 @@
/* The MIT License
Copyright (c) 2015, by Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Copyright (c) 2008, by Attractive Chaos <attractor@live.co.uk>
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 AC_KVEC_H
#define AC_KVEC_H
#define kv_roundup32(x) (--(x), (x)|=(x)>>1, (x)|=(x)>>2, (x)|=(x)>>4, (x)|=(x)>>8, (x)|=(x)>>16, ++(x))
#define kvec_t(type) struct { size_t n, m; type *a; }
#define kv_init(v) ((v).n = (v).m = 0, (v).a = 0)
#define kv_destroy(v) pic_free((pic), (v).a)
#define kv_A(v, i) ((v).a[(i)])
#define kv_pop(v) ((v).a[--(v).n])
#define kv_size(v) ((v).n)
#define kv_max(v) ((v).m)
#define kv_resize(type, v, s) ((v).m = (s), (v).a = (type*)pic_realloc((pic), (v).a, sizeof(type) * (v).m))
#define kv_copy(type, v1, v0) do { \
if ((v1).m < (v0).n) kv_resize((pic), type, v1, (v0).n); \
(v1).n = (v0).n; \
memcpy((v1).a, (v0).a, sizeof(type) * (v0).n); \
} while (0) \
#define kv_push(type, v, x) do { \
if ((v).n == (v).m) { \
(v).m = (v).m? (v).m<<1 : 2; \
(v).a = (type*)pic_realloc((pic), (v).a, sizeof(type) * (v).m); \
} \
(v).a[(v).n++] = (x); \
} while (0)
#define kv_pushp(type, v) \
(((v).n == (v).m)? \
((v).m = ((v).m? (v).m<<1 : 2), \
(v).a = (type*)pic_realloc((pic), (v).a, sizeof(type) * (v).m), 0) \
: 0), ((v).a + ((v).n++))
#define kv_a(type, v, i) \
(((v).m <= (size_t)(i)? \
((v).m = (v).n = (i) + 1, kv_roundup32((v).m), \
(v).a = (type*)pic_realloc((pic), (v).a, sizeof(type) * (v).m), 0) \
: (v).n <= (size_t)(i)? (v).n = (i) + 1 \
: 0), (v).a[(i)])
#endif

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

@ -9,37 +9,27 @@
extern "C" {
#endif
KHASH_DECLARE(env, void *, pic_sym *)
struct pic_id {
PIC_OBJECT_HEADER
pic_value var;
struct pic_env *env;
};
KHASH_DECLARE(env, pic_id *, pic_sym *)
struct pic_env {
PIC_OBJECT_HEADER
khash_t(env) map;
struct pic_env *up;
pic_str *prefix;
};
#define pic_id_p(v) (pic_type(v) == PIC_TT_ID)
#define pic_id_ptr(v) ((struct pic_id *)pic_ptr(v))
#define pic_env_p(v) (pic_type(v) == PIC_TT_ENV)
#define pic_env_ptr(v) ((struct pic_env *)pic_ptr(v))
struct pic_id *pic_make_id(pic_state *, pic_value, struct pic_env *);
struct pic_env *pic_make_topenv(pic_state *, pic_str *);
struct pic_env *pic_make_env(pic_state *, struct pic_env *);
pic_sym *pic_uniq(pic_state *, pic_value);
pic_sym *pic_add_identifier(pic_state *, pic_id *, struct pic_env *);
pic_sym *pic_put_identifier(pic_state *, pic_id *, pic_sym *, struct pic_env *);
pic_sym *pic_find_identifier(pic_state *, pic_id *, struct pic_env *);
pic_sym *pic_lookup_identifier(pic_state *, pic_id *, struct pic_env *);
pic_sym *pic_add_variable(pic_state *, struct pic_env *, pic_value);
void pic_put_variable(pic_state *, struct pic_env *, pic_value, pic_sym *);
pic_sym *pic_find_variable(pic_state *, struct pic_env *, pic_value);
bool pic_var_p(pic_value);
pic_sym *pic_var_name(pic_state *, pic_value);
pic_value pic_expand(pic_state *, pic_value, struct pic_env *);
#if defined(__cplusplus)
}

53
extlib/benz/include/picrin/opcode.h
View File

@ -17,7 +17,9 @@ enum pic_opcode {
OP_PUSHTRUE,
OP_PUSHFALSE,
OP_PUSHINT,
OP_PUSHFLOAT,
OP_PUSHCHAR,
OP_PUSHEOF,
OP_PUSHCONST,
OP_GREF,
OP_GSET,
@ -52,7 +54,7 @@ enum pic_opcode {
#define PIC_INIT_CODE_I(code, op, ival) do { \
code.insn = op; \
code.u.i = ival; \
code.a = ival; \
} while (0)
#if DEBUG
@ -80,52 +82,58 @@ pic_dump_code(pic_code c)
puts("OP_PUSHFALSE");
break;
case OP_PUSHINT:
printf("OP_PUSHINT\t%d\n", c.u.i);
printf("OP_PUSHINT\t%d\n", c.a);
break;
case OP_PUSHFLOAT:
printf("OP_PUSHFLAOT\t%d\n", c.a);
break;
case OP_PUSHCHAR:
printf("OP_PUSHCHAR\t%c\n", c.u.c);
printf("OP_PUSHCHAR\t%c\n", c.a);
break;
case OP_PUSHEOF:
puts("OP_PUSHEOF");
break;
case OP_PUSHCONST:
printf("OP_PUSHCONST\t%d\n", c.u.i);
printf("OP_PUSHCONST\t%d\n", c.a);
break;
case OP_GREF:
printf("OP_GREF\t%i\n", c.u.i);
printf("OP_GREF\t%i\n", c.a);
break;
case OP_GSET:
printf("OP_GSET\t%i\n", c.u.i);
printf("OP_GSET\t%i\n", c.a);
break;
case OP_LREF:
printf("OP_LREF\t%d\n", c.u.i);
printf("OP_LREF\t%d\n", c.a);
break;
case OP_LSET:
printf("OP_LSET\t%d\n", c.u.i);
printf("OP_LSET\t%d\n", c.a);
break;
case OP_CREF:
printf("OP_CREF\t%d\t%d\n", c.u.r.depth, c.u.r.idx);
printf("OP_CREF\t%d\t%d\n", c.a, c.b);
break;
case OP_CSET:
printf("OP_CSET\t%d\t%d\n", c.u.r.depth, c.u.r.idx);
printf("OP_CSET\t%d\t%d\n", c.a, c.b);
break;
case OP_JMP:
printf("OP_JMP\t%x\n", c.u.i);
printf("OP_JMP\t%x\n", c.a);
break;
case OP_JMPIF:
printf("OP_JMPIF\t%x\n", c.u.i);
printf("OP_JMPIF\t%x\n", c.a);
break;
case OP_NOT:
puts("OP_NOT");
break;
case OP_CALL:
printf("OP_CALL\t%d\n", c.u.i);
printf("OP_CALL\t%d\n", c.a);
break;
case OP_TAILCALL:
printf("OP_TAILCALL\t%d\n", c.u.i);
printf("OP_TAILCALL\t%d\n", c.a);
break;
case OP_RET:
puts("OP_RET");
break;
case OP_LAMBDA:
printf("OP_LAMBDA\t%d\n", c.u.i);
printf("OP_LAMBDA\t%d\n", c.a);
break;
case OP_CONS:
puts("OP_CONS");
@ -181,17 +189,20 @@ pic_dump_code(pic_code c)
PIC_INLINE void
pic_dump_irep(struct pic_irep *irep)
{
unsigned i;
size_t 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("# argc = %d\n", irep->argc);
printf("# localc = %d\n", irep->localc);
printf("# capturec = %d\n", irep->capturec);
for (i = 0; i < irep->ncode; ++i) {
printf("%02x: ", i);
pic_dump_code(irep->code[i]);
pic_dump_code(irep->u.s.code[i]);
}
for (i = 0; i < irep->ilen; ++i) {
pic_dump_irep(irep->irep[i]);
for (i = 0; i < irep->nirep; ++i) {
pic_dump_irep(irep->u.s.irep[i].i);
}
}

15
extlib/benz/include/picrin/record.h
View File

@ -11,18 +11,17 @@ extern "C" {
struct pic_record {
PIC_OBJECT_HEADER
struct pic_record *type;
struct pic_vector *data;
pic_value type;
pic_value datum;
};
#define pic_record_p(v) (pic_type(v) == PIC_TT_RECORD)
#define pic_record_ptr(v) ((struct pic_record *)pic_ptr(v))
#define pic_rec_p(v) (pic_type(v) == PIC_TT_RECORD)
#define pic_rec_ptr(v) ((struct pic_record *)pic_ptr(v))
struct pic_record *pic_make_record(pic_state *, struct pic_record *, int);
struct pic_record *pic_make_rec(pic_state *, pic_value, pic_value);
struct pic_record *pic_record_type(pic_state *, struct pic_record *);
pic_value pic_record_ref(pic_state *, struct pic_record *, int);
void pic_record_set(pic_state *, struct pic_record *, int, pic_value);
pic_value pic_rec_type(pic_state *, struct pic_record *);
pic_value pic_rec_datum(pic_state *, struct pic_record *);
#if defined(__cplusplus)
}

1
extlib/benz/include/picrin/reg.h
View File

@ -26,7 +26,6 @@ pic_value pic_reg_ref(pic_state *, struct pic_reg *, void *);
void pic_reg_set(pic_state *, struct pic_reg *, void *, pic_value);
void pic_reg_del(pic_state *, struct pic_reg *, void *);
bool pic_reg_has(pic_state *, struct pic_reg *, void *);
void *pic_reg_rev_ref(pic_state *, struct pic_reg *, pic_value);
#if defined(__cplusplus)
}

11
extlib/benz/include/picrin/string.h
View File

@ -20,23 +20,20 @@ void pic_rope_decref(pic_state *, struct pic_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 */, int);
pic_str *pic_make_str_cstr(pic_state *, const char *);
pic_str *pic_make_str(pic_state *, const char *, int);
#define pic_make_cstr(pic, cstr) pic_make_str(pic, (cstr), strlen(cstr))
#define pic_make_lit(pic, lit) pic_make_str(pic, "" lit, -((int)sizeof lit - 1))
char pic_str_ref(pic_state *, pic_str *, int);
int pic_str_len(pic_str *);
pic_str *pic_str_cat(pic_state *, pic_str *, pic_str *);
pic_str *pic_str_sub(pic_state *, pic_str *, int, int);
int pic_str_cmp(pic_state *, pic_str *, pic_str *);
int pic_str_hash(pic_state *, pic_str *);
const char *pic_str_cstr(pic_state *, 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)
}

30
extlib/benz/include/picrin/symbol.h
View File

@ -9,13 +9,35 @@
extern "C" {
#endif
struct pic_symbol {
PIC_OBJECT_HEADER
const char *cstr;
struct pic_id {
union {
struct pic_symbol {
PIC_OBJECT_HEADER
pic_str *str;
} sym;
struct {
PIC_OBJECT_HEADER
struct pic_id *id;
struct pic_env *env;
} id;
} u;
};
#define pic_sym_p(v) (pic_type(v) == PIC_TT_SYMBOL)
#define pic_sym_ptr(v) ((struct pic_symbol *)pic_ptr(v))
#define pic_sym_ptr(v) ((pic_sym *)pic_ptr(v))
#define pic_id_p(v) (pic_type(v) == PIC_TT_ID || pic_type(v) == PIC_TT_SYMBOL)
#define pic_id_ptr(v) ((pic_id *)pic_ptr(v))
pic_sym *pic_intern(pic_state *, pic_str *);
#define pic_intern_str(pic,s,i) pic_intern(pic, pic_make_str(pic, (s), (i)))
#define pic_intern_cstr(pic,s) pic_intern(pic, pic_make_cstr(pic, (s)))
#define pic_intern_lit(pic,lit) pic_intern(pic, pic_make_lit(pic, lit))
pic_id *pic_make_identifier(pic_state *, pic_id *, struct pic_env *);
const char *pic_symbol_name(pic_state *, pic_sym *);
const char *pic_identifier_name(pic_state *, pic_id *);
#if defined(__cplusplus)
}

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

@ -156,9 +156,7 @@ enum pic_tt {
PIC_TT_DICT,
PIC_TT_REG,
PIC_TT_RECORD,
PIC_TT_BOX,
PIC_TT_CXT,
PIC_TT_IREP,
PIC_TT_CP
};
@ -184,6 +182,7 @@ struct pic_env;
/* set aliases to basic types */
typedef struct pic_symbol pic_sym;
typedef struct pic_id pic_id;
typedef struct pic_pair pic_pair;
typedef struct pic_string pic_str;
typedef struct pic_vector pic_vec;
@ -305,16 +304,12 @@ pic_type_repr(enum pic_tt tt)
return "env";
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_REG:
return "reg";
case PIC_TT_BOX:
return "box";
case PIC_TT_RECORD:
return "record";
case PIC_TT_CP:

41
extlib/benz/lib.c
View File

@ -4,13 +4,30 @@
#include "picrin.h"
static void
setup_default_env(pic_state *pic, struct pic_env *env)
static struct pic_env *
make_library_env(pic_state *pic, pic_value name)
{
pic_put_variable(pic, env, pic_obj_value(pic->sDEFINE_LIBRARY), pic->uDEFINE_LIBRARY);
pic_put_variable(pic, env, pic_obj_value(pic->sIMPORT), pic->uIMPORT);
pic_put_variable(pic, env, pic_obj_value(pic->sEXPORT), pic->uEXPORT);
pic_put_variable(pic, env, pic_obj_value(pic->sCOND_EXPAND), pic->uCOND_EXPAND);
struct pic_env *env;
pic_value dir, it;
pic_str *prefix = NULL;
pic_for_each (dir, name, it) {
if (prefix == NULL) {
prefix = pic_format(pic, "~a", dir);
} else {
prefix = pic_format(pic, "~a.~a", pic_obj_value(prefix), dir);
}
}
env = pic_make_topenv(pic, prefix);
/* set up default environment */
pic_put_identifier(pic, (pic_id *)pic->sDEFINE_LIBRARY, pic->sDEFINE_LIBRARY, env);
pic_put_identifier(pic, (pic_id *)pic->sIMPORT, pic->sIMPORT, env);
pic_put_identifier(pic, (pic_id *)pic->sEXPORT, pic->sEXPORT, env);
pic_put_identifier(pic, (pic_id *)pic->sCOND_EXPAND, pic->sCOND_EXPAND, env);
return env;
}
struct pic_lib *
@ -24,11 +41,9 @@ pic_make_library(pic_state *pic, pic_value name)
pic_errorf(pic, "library name already in use: ~s", name);
}
env = pic_make_env(pic, NULL);
env = make_library_env(pic, name);
exports = pic_make_dict(pic);
setup_default_env(pic, env);
lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB);
lib->name = name;
lib->env = env;
@ -61,10 +76,10 @@ pic_import(pic_state *pic, struct pic_lib *lib)
pic_dict_for_each (name, lib->exports, it) {
realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name));
if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(realname))) == NULL) {
if ((uid = pic_find_identifier(pic, (pic_id *)realname, lib->env)) == NULL) {
pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname));
}
pic_put_variable(pic, pic->lib->env, pic_obj_value(name), uid);
pic_put_identifier(pic, (pic_id *)name, uid, pic->lib->env);
}
}
@ -141,10 +156,10 @@ pic_lib_library_import(pic_state *pic)
realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name));
}
if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(realname))) == NULL) {
if ((uid = pic_find_identifier(pic, (pic_id *)realname, lib->env)) == NULL) {
pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname));
} else {
pic_put_variable(pic, pic->lib->env, pic_obj_value(alias), uid);
pic_put_identifier(pic, (pic_id *)alias, uid, pic->lib->env);
}
return pic_undef_value();

2
extlib/benz/load.c
View File

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

447
extlib/benz/macro.c
View File

@ -4,185 +4,362 @@
#include "picrin.h"
KHASH_DEFINE(env, void *, pic_sym *, kh_ptr_hash_func, kh_ptr_hash_equal)
bool
pic_var_p(pic_value obj)
{
return pic_sym_p(obj) || pic_id_p(obj);
}
struct pic_id *
pic_make_id(pic_state *pic, pic_value var, struct pic_env *env)
{
struct pic_id *id;
assert(pic_var_p(var));
id = (struct pic_id *)pic_obj_alloc(pic, sizeof(struct pic_id), PIC_TT_ID);
id->var = var;
id->env = env;
return id;
}
KHASH_DEFINE(env, pic_id *, pic_sym *, kh_ptr_hash_func, kh_ptr_hash_equal)
struct pic_env *
pic_make_env(pic_state *pic, struct pic_env *up)
{
struct pic_env *env;
assert(up != NULL);
env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV);
env->up = up;
env->prefix = NULL;
kh_init(env, &env->map);
return env;
}
struct pic_env *
pic_make_topenv(pic_state *pic, pic_str *prefix)
{
struct pic_env *env;
env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV);
env->up = NULL;
env->prefix = prefix;
kh_init(env, &env->map);
return env;
}
pic_sym *
pic_var_name(pic_state PIC_UNUSED(*pic), pic_value var)
{
assert(pic_var_p(var));
while (pic_id_p(var)) {
var = pic_id_ptr(var)->var;
}
return pic_sym_ptr(var);
}
pic_sym *
pic_uniq(pic_state *pic, pic_value var)
pic_add_identifier(pic_state *pic, pic_id *id, struct pic_env *env)
{
const char *name;
pic_sym *uid;
pic_str *str;
assert(pic_var_p(var));
name = pic_identifier_name(pic, id);
str = pic_format(pic, "%s.%d", pic_symbol_name(pic, pic_var_name(pic, var)), pic->ucnt++);
if (env->up == NULL && pic_sym_p(pic_obj_value(id))) { /* toplevel & public */
str = pic_format(pic, "%s/%s", pic_str_cstr(pic, env->prefix), name);
} else {
str = pic_format(pic, ".%s.%d", name, pic->ucnt++);
}
uid = pic_intern(pic, str);
return pic_intern_str(pic, str);
return pic_put_identifier(pic, id, uid, env);
}
pic_sym *
pic_add_variable(pic_state *pic, struct pic_env *env, pic_value var)
{
pic_sym *uid;
assert(pic_var_p(var));
uid = pic_uniq(pic, var);
pic_put_variable(pic, env, var, uid);
return uid;
}
void
pic_put_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var, pic_sym *uid)
pic_put_identifier(pic_state *pic, pic_id *id, pic_sym *uid, struct pic_env *env)
{
khiter_t it;
int ret;
assert(pic_var_p(var));
it = kh_put(env, &env->map, pic_ptr(var), &ret);
it = kh_put(env, &env->map, id, &ret);
kh_val(&env->map, it) = uid;
return uid;
}
pic_sym *
pic_find_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var)
pic_find_identifier(pic_state PIC_UNUSED(*pic), pic_id *id, struct pic_env *env)
{
khiter_t it;
assert(pic_var_p(var));
it = kh_get(env, &env->map, pic_ptr(var));
it = kh_get(env, &env->map, id);
if (it == kh_end(&env->map)) {
return NULL;
}
return kh_val(&env->map, it);
}
static pic_value
pic_macro_identifier_p(pic_state *pic)
static pic_sym *
lookup(pic_state *pic, pic_id *id, struct pic_env *env)
{
pic_value obj;
pic_sym *uid = NULL;
pic_get_args(pic, "o", &obj);
return pic_bool_value(pic_id_p(obj));
}
static pic_value
pic_macro_make_identifier(pic_state *pic)
{
pic_value var, env;
pic_get_args(pic, "oo", &var, &env);
pic_assert_type(pic, var, var);
pic_assert_type(pic, env, env);
return pic_obj_value(pic_make_id(pic, var, pic_env_ptr(env)));
}
static pic_value
pic_macro_identifier_variable(pic_state *pic)
{
pic_value id;
pic_get_args(pic, "o", &id);
pic_assert_type(pic, id, id);
return pic_id_ptr(id)->var;
}
static pic_value
pic_macro_identifier_environment(pic_state *pic)
{
pic_value id;
pic_get_args(pic, "o", &id);
pic_assert_type(pic, id, id);
return pic_obj_value(pic_id_ptr(id)->env);
}
static pic_value
pic_macro_variable_p(pic_state *pic)
{
pic_value obj;
pic_get_args(pic, "o", &obj);
return pic_bool_value(pic_var_p(obj));
}
static pic_value
pic_macro_variable_eq_p(pic_state *pic)
{
int argc, i;
pic_value *argv;
pic_get_args(pic, "*", &argc, &argv);
for (i = 0; i < argc; ++i) {
if (! pic_var_p(argv[i])) {
return pic_false_value();
}
if (! pic_equal_p(pic, argv[i], argv[0])) {
return pic_false_value();
while (env != NULL) {
uid = pic_find_identifier(pic, id, env);
if (uid != NULL) {
break;
}
env = env->up;
}
return pic_true_value();
return uid;
}
void
pic_init_macro(pic_state *pic)
pic_sym *
pic_lookup_identifier(pic_state *pic, pic_id *id, struct pic_env *env)
{
pic_defun(pic, "make-identifier", pic_macro_make_identifier);
pic_defun(pic, "identifier?", pic_macro_identifier_p);
pic_defun(pic, "identifier-variable", pic_macro_identifier_variable);
pic_defun(pic, "identifier-environment", pic_macro_identifier_environment);
pic_sym *uid;
pic_defun(pic, "variable?", pic_macro_variable_p);
pic_defun(pic, "variable=?", pic_macro_variable_eq_p);
while ((uid = lookup(pic, id, env)) == NULL) {
if (pic_sym_p(pic_obj_value(id))) {
break;
}
env = id->u.id.env; /* do not overwrite id first */
id = id->u.id.id;
}
if (uid == NULL) {
while (env->up != NULL) {
env = env->up;
}
uid = pic_add_identifier(pic, id, env);
}
return uid;
}
/**
* macro expander
*/
static void
define_macro(pic_state *pic, pic_sym *uid, struct pic_proc *mac)
{
if (pic_reg_has(pic, pic->macros, uid)) {
pic_warnf(pic, "redefining syntax variable: ~s", pic_obj_value(uid));
}
pic_reg_set(pic, pic->macros, uid, pic_obj_value(mac));
}
static struct pic_proc *
find_macro(pic_state *pic, pic_sym *uid)
{
if (! pic_reg_has(pic, pic->macros, uid)) {
return NULL;
}
return pic_proc_ptr(pic_reg_ref(pic, pic->macros, uid));
}
static void
shadow_macro(pic_state *pic, pic_sym *uid)
{
if (pic_reg_has(pic, pic->macros, uid)) {
pic_reg_del(pic, pic->macros, uid);
}
}
static pic_value expand(pic_state *, pic_value, struct pic_env *, pic_value);
static pic_value expand_lambda(pic_state *, pic_value, struct pic_env *);
static pic_value
expand_var(pic_state *pic, pic_id *id, struct pic_env *env, pic_value deferred)
{
struct pic_proc *mac;
pic_sym *functor;
functor = pic_lookup_identifier(pic, id, env);
if ((mac = find_macro(pic, functor)) != NULL) {
return expand(pic, pic_apply2(pic, mac, pic_obj_value(id), pic_obj_value(env)), env, deferred);
}
return pic_obj_value(functor);
}
static pic_value
expand_quote(pic_state *pic, pic_value expr)
{
return pic_cons(pic, pic_obj_value(pic->sQUOTE), pic_cdr(pic, expr));
}
static pic_value
expand_list(pic_state *pic, pic_value obj, struct pic_env *env, pic_value deferred)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value x, head, tail;
if (pic_pair_p(obj)) {
head = expand(pic, pic_car(pic, obj), env, deferred);
tail = expand_list(pic, pic_cdr(pic, obj), env, deferred);
x = pic_cons(pic, head, tail);
} else {
x = expand(pic, obj, env, deferred);
}
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, x);
return x;
}
static pic_value
expand_defer(pic_state *pic, pic_value expr, pic_value deferred)
{
pic_value skel = pic_cons(pic, pic_invalid_value(), pic_invalid_value());
pic_set_car(pic, deferred, pic_acons(pic, expr, skel, pic_car(pic, deferred)));
return skel;
}
static void
expand_deferred(pic_state *pic, pic_value deferred, struct pic_env *env)
{
pic_value defer, val, src, dst, it;
deferred = pic_car(pic, deferred);
pic_for_each (defer, pic_reverse(pic, deferred), it) {
src = pic_car(pic, defer);
dst = pic_cdr(pic, defer);
val = expand_lambda(pic, src, env);
/* copy */
pic_set_car(pic, dst, pic_car(pic, val));
pic_set_cdr(pic, dst, pic_cdr(pic, val));
}
}
static pic_value
expand_lambda(pic_state *pic, pic_value expr, struct pic_env *env)
{
pic_value formal, body;
struct pic_env *in;
pic_value a, deferred;
in = pic_make_env(pic, env);
for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
pic_add_identifier(pic, pic_id_ptr(pic_car(pic, a)), in);
}
if (pic_id_p(a)) {
pic_add_identifier(pic, pic_id_ptr(a), in);
}
deferred = pic_list1(pic, pic_nil_value());
formal = expand_list(pic, pic_list_ref(pic, expr, 1), in, deferred);
body = expand(pic, pic_list_ref(pic, expr, 2), in, deferred);
expand_deferred(pic, deferred, in);
return pic_list3(pic, pic_obj_value(pic->sLAMBDA), formal, body);
}
static pic_value
expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred)
{
pic_sym *uid;
pic_id *id;
pic_value val;
id = pic_id_ptr(pic_cadr(pic, expr));
if ((uid = pic_find_identifier(pic, id, env)) == NULL) {
uid = pic_add_identifier(pic, id, env);
} else {
shadow_macro(pic, uid);
}
val = expand(pic, pic_list_ref(pic, expr, 2), env, deferred);
return pic_list3(pic, pic_obj_value(pic->sDEFINE), pic_obj_value(uid), val);
}
static pic_value
expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env)
{
struct pic_proc *pic_compile(pic_state *, pic_value);
pic_id *id;
pic_value val;
pic_sym *uid;
id = pic_id_ptr(pic_cadr(pic, expr));
if ((uid = pic_find_identifier(pic, id, env)) == NULL) {
uid = pic_add_identifier(pic, id, env);
}
val = pic_apply0(pic, pic_compile(pic, pic_expand(pic, pic_list_ref(pic, expr, 2), env)));
if (! pic_proc_p(val)) {
pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", pic_identifier_name(pic, id));
}
define_macro(pic, uid, pic_proc_ptr(val));
return pic_undef_value();
}
static pic_value
expand_node(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred)
{
switch (pic_type(expr)) {
case PIC_TT_ID:
case PIC_TT_SYMBOL: {
return expand_var(pic, pic_id_ptr(expr), env, deferred);
}
case PIC_TT_PAIR: {
struct pic_proc *mac;
if (! pic_list_p(expr)) {
pic_errorf(pic, "cannot expand improper list: ~s", expr);
}
if (pic_id_p(pic_car(pic, expr))) {
pic_sym *functor;
functor = pic_lookup_identifier(pic, pic_id_ptr(pic_car(pic, expr)), env);
if (functor == pic->sDEFINE_MACRO) {
return expand_defmacro(pic, expr, env);
}
else if (functor == pic->sLAMBDA) {
return expand_defer(pic, expr, deferred);
}
else if (functor == pic->sDEFINE) {
return expand_define(pic, expr, env, deferred);
}
else if (functor == pic->sQUOTE) {
return expand_quote(pic, expr);
}
if ((mac = find_macro(pic, functor)) != NULL) {
return expand(pic, pic_apply2(pic, mac, expr, pic_obj_value(env)), env, deferred);
}
}
return expand_list(pic, expr, env, deferred);
}
default:
return expr;
}
}
static pic_value
expand(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value v;
v = expand_node(pic, expr, env, deferred);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, v);
return v;
}
pic_value
pic_expand(pic_state *pic, pic_value expr, struct pic_env *env)
{
pic_value v, deferred;
#if DEBUG
puts("before expand:");
pic_debug(pic, expr);
puts("");
#endif
deferred = pic_list1(pic, pic_nil_value());
v = expand(pic, expr, env, deferred);
expand_deferred(pic, deferred, env);
#if DEBUG
puts("after expand:");
pic_debug(pic, v);
puts("");
#endif
return v;
}

2
extlib/benz/port.c
View File

@ -103,7 +103,7 @@ file_error(pic_state *pic, const char *msg)
{
struct pic_error *e;
e = pic_make_error(pic, pic_intern(pic, "file"), msg, pic_nil_value());
e = pic_make_error(pic, pic_intern_lit(pic, "file"), msg, pic_nil_value());
pic_raise(pic, pic_obj_value(e));
}

1052
extlib/benz/proc.c
View File

File diff suppressed because it is too large Load Diff

6
extlib/benz/read.c
View File

@ -14,7 +14,7 @@ read_error(pic_state *pic, const char *msg, pic_value irritant)
{
struct pic_error *e;
e = pic_make_error(pic, pic_intern(pic, "read"), msg, irritant);
e = pic_make_error(pic, pic_intern_lit(pic, "read"), msg, irritant);
pic_raise(pic, pic_obj_value(e));
}
@ -214,7 +214,7 @@ read_symbol(pic_state *pic, struct pic_port *port, int c)
buf[len] = 0;
}
sym = pic_intern(pic, buf);
sym = pic_intern_cstr(pic, buf);
pic_free(pic, buf);
return pic_obj_value(sym);
@ -487,7 +487,7 @@ read_pipe(pic_state *pic, struct pic_port *port, int c)
}
buf[cnt] = '\0';
sym = pic_intern(pic, buf);
sym = pic_intern_cstr(pic, buf);
pic_free(pic, buf);
return pic_obj_value(sym);

76
extlib/benz/record.c
View File

@ -5,108 +5,74 @@
#include "picrin.h"
struct pic_record *
pic_make_record(pic_state *pic, struct pic_record *type, int len)
pic_make_rec(pic_state *pic, pic_value type, pic_value datum)
{
struct pic_record *rec;
struct pic_vector *data = pic_make_vec(pic, len);
rec = (struct pic_record *)pic_obj_alloc(pic, sizeof(struct pic_record), PIC_TT_RECORD);
rec->data = data;
rec->type = type;
if (rec->type == NULL) {
rec->type = rec;
}
rec->datum = datum;
return rec;
}
struct pic_record *
pic_record_type(pic_state PIC_UNUSED(*pic), struct pic_record *rec)
pic_value
pic_rec_type(pic_state PIC_UNUSED(*pic), struct pic_record *rec)
{
return rec->type;
}
pic_value
pic_record_ref(pic_state PIC_UNUSED(*pic), struct pic_record *rec, int slot)
pic_rec_datum(pic_state PIC_UNUSED(*pic), struct pic_record *rec)
{
return rec->data->data[slot];
}
void
pic_record_set(pic_state PIC_UNUSED(*pic), struct pic_record *rec, int slot, pic_value val)
{
rec->data->data[slot] = val;
return rec->datum;
}
static pic_value
pic_record_make_record(pic_state *pic)
pic_rec_make_record(pic_state *pic)
{
struct pic_record * rec;
pic_value rectype;
int len;
pic_value type, datum;
pic_get_args(pic, "oi", &rectype, &len);
pic_get_args(pic, "oo", &type, &datum);
pic_assert_type(pic, rectype, record);
rec = pic_make_record(pic, pic_record_ptr(rectype), len);
return pic_obj_value(rec);
return pic_obj_value(pic_make_rec(pic, type, datum));
}
static pic_value
pic_record_record_p(pic_state *pic)
pic_rec_record_p(pic_state *pic)
{
pic_value rec;
pic_get_args(pic, "o", &rec);
return pic_bool_value(pic_record_p(rec));
return pic_bool_value(pic_rec_p(rec));
}
static pic_value
pic_record_record_type(pic_state *pic)
pic_rec_record_type(pic_state *pic)
{
struct pic_record *rec;
pic_get_args(pic, "r", &rec);
return pic_obj_value(pic_record_type(pic, rec));
return pic_rec_type(pic, rec);
}
static pic_value
pic_record_record_ref(pic_state *pic)
pic_rec_record_datum(pic_state *pic)
{
struct pic_record *rec;
int slot;
pic_get_args(pic, "ri", &rec, &slot);
pic_get_args(pic, "r", &rec);
return pic_record_ref(pic, rec, slot);
}
static pic_value
pic_record_record_set(pic_state *pic)
{
struct pic_record *rec;
int slot;
pic_value val;
pic_get_args(pic, "rio", &rec, &slot, &val);
pic_record_set(pic, rec, slot, val);
return pic_undef_value();
return pic_rec_datum(pic, rec);
}
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);
pic_define(pic, "<record-type>", pic_obj_value(pic_make_record(pic, NULL, 0)));
pic_defun(pic, "make-record", pic_rec_make_record);
pic_defun(pic, "record?", pic_rec_record_p);
pic_defun(pic, "record-type", pic_rec_record_type);
pic_defun(pic, "record-datum", pic_rec_record_datum);
}

225
extlib/benz/state.c
View File

@ -15,7 +15,7 @@ pic_set_argv(pic_state *pic, int argc, char *argv[], char **envp)
void
pic_add_feature(pic_state *pic, const char *feature)
{
pic_push(pic, pic_obj_value(pic_intern(pic, feature)), pic->features);
pic_push(pic, pic_obj_value(pic_intern_cstr(pic, feature)), pic->features);
}
void pic_init_bool(pic_state *);
@ -30,7 +30,6 @@ 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_write(pic_state *);
void pic_init_read(pic_state *);
@ -38,7 +37,6 @@ 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 *);
void pic_init_reg(pic_state *);
extern const char pic_boot[][80];
@ -109,19 +107,18 @@ pic_features(pic_state *pic)
return pic->features;
}
#define DONE pic_gc_arena_restore(pic, ai);
#define import_builtin_syntax(name) do { \
pic_sym *nick, *real; \
nick = pic_intern_lit(pic, "builtin:" name); \
real = pic_intern_lit(pic, name); \
pic_put_identifier(pic, (pic_id *)nick, real, pic->lib->env); \
} while (0)
#define define_builtin_syntax(uid, name) \
pic_put_variable(pic, pic->lib->env, pic_obj_value(pic_intern(pic, name)), uid)
#define VM(uid, name) \
pic_put_variable(pic, pic->lib->env, pic_obj_value(pic_intern(pic, name)), uid)
#define VM3(name) \
pic->c##name = pic_vm_gref_slot(pic, pic->u##name);
#define VM2(proc, name) \
proc = pic_ref(pic, pic->lib, name)
#define declare_vm_procedure(name) do { \
pic_sym *sym; \
sym = pic_intern_lit(pic, name); \
pic_put_identifier(pic, (pic_id *)sym, sym, pic->lib->env); \
} while (0)
static void
pic_init_core(pic_state *pic)
@ -133,32 +130,34 @@ pic_init_core(pic_state *pic)
pic_deflibrary (pic, "(picrin base)") {
size_t ai = pic_gc_arena_preserve(pic);
define_builtin_syntax(pic->uDEFINE, "builtin:define");
define_builtin_syntax(pic->uSETBANG, "builtin:set!");
define_builtin_syntax(pic->uQUOTE, "builtin:quote");
define_builtin_syntax(pic->uLAMBDA, "builtin:lambda");
define_builtin_syntax(pic->uIF, "builtin:if");
define_builtin_syntax(pic->uBEGIN, "builtin:begin");
define_builtin_syntax(pic->uDEFINE_MACRO, "builtin:define-macro");
#define DONE pic_gc_arena_restore(pic, ai);
pic_defun(pic, "features", pic_features);
import_builtin_syntax("define");
import_builtin_syntax("set!");
import_builtin_syntax("quote");
import_builtin_syntax("lambda");
import_builtin_syntax("if");
import_builtin_syntax("begin");
import_builtin_syntax("define-macro");
VM(pic->uCONS, "cons");
VM(pic->uCAR, "car");
VM(pic->uCDR, "cdr");
VM(pic->uNILP, "null?");
VM(pic->uSYMBOLP, "symbol?");
VM(pic->uPAIRP, "pair?");
VM(pic->uNOT, "not");
VM(pic->uADD, "+");
VM(pic->uSUB, "-");
VM(pic->uMUL, "*");
VM(pic->uDIV, "/");
VM(pic->uEQ, "=");
VM(pic->uLT, "<");
VM(pic->uLE, "<=");
VM(pic->uGT, ">");
VM(pic->uGE, ">=");
declare_vm_procedure("cons");
declare_vm_procedure("car");
declare_vm_procedure("cdr");
declare_vm_procedure("null?");
declare_vm_procedure("symbol?");
declare_vm_procedure("pair?");
declare_vm_procedure("+");
declare_vm_procedure("-");
declare_vm_procedure("*");
declare_vm_procedure("/");
declare_vm_procedure("=");
declare_vm_procedure("<");
declare_vm_procedure(">");
declare_vm_procedure("<=");
declare_vm_procedure(">=");
declare_vm_procedure("not");
DONE;
pic_init_bool(pic); DONE;
pic_init_pair(pic); DONE;
@ -172,7 +171,6 @@ pic_init_core(pic_state *pic)
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_write(pic); DONE;
pic_init_read(pic); DONE;
@ -180,42 +178,9 @@ pic_init_core(pic_state *pic)
pic_init_record(pic); DONE;
pic_init_eval(pic); DONE;
pic_init_lib(pic); DONE;
pic_init_attr(pic); DONE;
pic_init_reg(pic); DONE;
VM3(CONS);
VM3(CAR);
VM3(CDR);
VM3(NILP);
VM3(SYMBOLP);
VM3(PAIRP);
VM3(NOT);
VM3(ADD);
VM3(SUB);
VM3(MUL);
VM3(DIV);
VM3(EQ);
VM3(LT);
VM3(LE);
VM3(GT);
VM3(GE);
VM2(pic->pCONS, "cons");
VM2(pic->pCAR, "car");
VM2(pic->pCDR, "cdr");
VM2(pic->pNILP, "null?");
VM2(pic->pSYMBOLP, "symbol?");
VM2(pic->pPAIRP, "pair?");
VM2(pic->pNOT, "not");
VM2(pic->pADD, "+");
VM2(pic->pSUB, "-");
VM2(pic->pMUL, "*");
VM2(pic->pDIV, "/");
VM2(pic->pEQ, "=");
VM2(pic->pLT, "<");
VM2(pic->pLE, "<=");
VM2(pic->pGT, ">");
VM2(pic->pGE, ">=");
pic_defun(pic, "features", pic_features);
pic_try {
pic_load_cstr(pic, &pic_boot[0][0]);
@ -311,9 +276,6 @@ pic_open(pic_allocf allocf, void *userdata)
/* macros */
pic->macros = NULL;
/* attributes */
pic->attrs = NULL;
/* features */
pic->features = pic_nil_value();
@ -321,6 +283,10 @@ pic_open(pic_allocf allocf, void *userdata)
pic->libs = pic_nil_value();
pic->lib = NULL;
/* ireps */
pic->ireps.next = &pic->ireps;
pic->ireps.prev = &pic->ireps;
/* raised error object */
pic->err = pic_invalid_value();
@ -335,8 +301,14 @@ pic_open(pic_allocf allocf, void *userdata)
ai = pic_gc_arena_preserve(pic);
#define S(slot,name) pic->slot = pic_intern(pic, name)
#define S(slot,name) pic->slot = pic_intern_lit(pic, name)
S(sDEFINE, "define");
S(sDEFINE_MACRO, "define-macro");
S(sLAMBDA, "lambda");
S(sIF, "if");
S(sBEGIN, "begin");
S(sSETBANG, "set!");
S(sQUOTE, "quote");
S(sQUASIQUOTE, "quasiquote");
S(sUNQUOTE, "unquote");
@ -350,61 +322,28 @@ pic_open(pic_allocf allocf, void *userdata)
S(sDEFINE_LIBRARY, "define-library");
S(sCOND_EXPAND, "cond-expand");
S(sCONS, "cons");
S(sCAR, "car");
S(sCDR, "cdr");
S(sNILP, "null?");
S(sSYMBOLP, "symbol?");
S(sPAIRP, "pair?");
S(sADD, "+");
S(sSUB, "-");
S(sMUL, "*");
S(sDIV, "/");
S(sEQ, "=");
S(sLT, "<");
S(sLE, "<=");
S(sGT, ">");
S(sGE, ">=");
S(sNOT, "not");
pic_gc_arena_restore(pic, ai);
#define U(slot,name) pic->slot = pic_uniq(pic, pic_obj_value(pic_intern(pic, name)))
U(uDEFINE, "define");
U(uLAMBDA, "lambda");
U(uIF, "if");
U(uBEGIN, "begin");
U(uSETBANG, "set!");
U(uQUOTE, "quote");
U(uDEFINE_MACRO, "define-macro");
U(uIMPORT, "import");
U(uEXPORT, "export");
U(uDEFINE_LIBRARY, "define-library");
U(uCOND_EXPAND, "cond-expand");
U(uCONS, "cons");
U(uCAR, "car");
U(uCDR, "cdr");
U(uNILP, "null?");
U(uSYMBOLP, "symbol?");
U(uPAIRP, "pair?");
U(uADD, "+");
U(uSUB, "-");
U(uMUL, "*");
U(uDIV, "/");
U(uEQ, "=");
U(uLT, "<");
U(uLE, "<=");
U(uGT, ">");
U(uGE, ">=");
U(uNOT, "not");
pic_gc_arena_restore(pic, ai);
/* system procedures */
pic->pCONS = pic_invalid_value();
pic->pCAR = pic_invalid_value();
pic->pCDR = pic_invalid_value();
pic->pNILP = pic_invalid_value();
pic->pSYMBOLP = pic_invalid_value();
pic->pPAIRP = pic_invalid_value();
pic->pNOT = pic_invalid_value();
pic->pADD = pic_invalid_value();
pic->pSUB = pic_invalid_value();
pic->pMUL = pic_invalid_value();
pic->pDIV = pic_invalid_value();
pic->pEQ = pic_invalid_value();
pic->pLT = pic_invalid_value();
pic->pLE = pic_invalid_value();
pic->pGT = pic_invalid_value();
pic->pGE = pic_invalid_value();
/* root tables */
pic->globals = pic_make_reg(pic);
pic->macros = pic_make_reg(pic);
pic->attrs = pic_make_reg(pic);
/* root block */
pic->cp = (pic_checkpoint *)pic_obj_alloc(pic, sizeof(pic_checkpoint), PIC_TT_CP);
@ -429,23 +368,6 @@ pic_open(pic_allocf allocf, void *userdata)
/* turn on GC */
pic->gc_enable = true;
pic->cCONS = pic_box(pic, pic_invalid_value());
pic->cCAR = pic_box(pic, pic_invalid_value());
pic->cCDR = pic_box(pic, pic_invalid_value());
pic->cNILP = pic_box(pic, pic_invalid_value());
pic->cSYMBOLP = pic_box(pic, pic_invalid_value());
pic->cPAIRP = pic_box(pic, pic_invalid_value());
pic->cNOT = pic_box(pic, pic_invalid_value());
pic->cADD = pic_box(pic, pic_invalid_value());
pic->cSUB = pic_box(pic, pic_invalid_value());
pic->cMUL = pic_box(pic, pic_invalid_value());
pic->cDIV = pic_box(pic, pic_invalid_value());
pic->cEQ = pic_box(pic, pic_invalid_value());
pic->cLT = pic_box(pic, pic_invalid_value());
pic->cLE = pic_box(pic, pic_invalid_value());
pic->cGT = pic_box(pic, pic_invalid_value());
pic->cGE = pic_box(pic, pic_invalid_value());
pic_init_core(pic);
pic_gc_arena_restore(pic, ai);
@ -478,13 +400,24 @@ pic_close(pic_state *pic)
pic->err = pic_invalid_value();
pic->globals = NULL;
pic->macros = NULL;
pic->attrs = NULL;
pic->features = pic_nil_value();
pic->libs = pic_nil_value();
/* free all heap objects */
pic_gc_run(pic);
#if 0
{
/* FIXME */
int i = 0;
struct pic_list *list;
for (list = pic->ireps.next; list != &pic->ireps; list = list->next) {
i++;
}
printf("%d\n", i);
}
#endif
/* flush all xfiles */
xfflush(pic, NULL);

103
extlib/benz/string.c
View File

@ -26,8 +26,6 @@ struct pic_rope {
#define CHUNK_DECREF(c) do { \
struct pic_chunk *c_ = (c); \
if (! --c_->refcnt) { \
if (c_->str != c_->buf) \
pic_free(pic, c_->str); \
pic_free(pic, c_); \
} \
} while (0)
@ -56,7 +54,7 @@ pic_make_chunk(pic_state *pic, const char *str, size_t len)
{
struct pic_chunk *c;
c = pic_malloc(pic, sizeof(struct pic_chunk) + len);
c = pic_malloc(pic, offsetof(struct pic_chunk, buf) + len + 1);
c->refcnt = 1;
c->str = c->buf;
c->len = len;
@ -66,6 +64,19 @@ pic_make_chunk(pic_state *pic, const char *str, size_t len)
return c;
}
static struct pic_chunk *
pic_make_chunk_lit(pic_state *pic, const char *str, size_t len)
{
struct pic_chunk *c;
c = pic_malloc(pic, sizeof(struct pic_chunk));
c->refcnt = 1;
c->str = (char *)str;
c->len = len;
return c;
}
static struct pic_rope *
pic_make_rope(pic_state *pic, struct pic_chunk *c)
{
@ -213,7 +224,7 @@ rope_cstr(pic_state *pic, struct pic_rope *x)
return x->chunk->str; /* reuse cached chunk */
}
c = pic_malloc(pic, sizeof(struct pic_chunk) + x->weight);
c = pic_malloc(pic, offsetof(struct pic_chunk, buf) + x->weight + 1);
c->refcnt = 1;
c->len = x->weight;
c->str = c->buf;
@ -228,16 +239,17 @@ rope_cstr(pic_state *pic, struct pic_rope *x)
pic_str *
pic_make_str(pic_state *pic, const char *str, int len)
{
if (str == NULL && len > 0) {
pic_errorf(pic, "zero length specified against NULL ptr");
}
return pic_make_string(pic, pic_make_rope(pic, pic_make_chunk(pic, str, len)));
}
struct pic_chunk *c;
pic_str *
pic_make_str_cstr(pic_state *pic, const char *cstr)
{
return pic_make_str(pic, cstr, strlen(cstr));
if (len > 0) {
c = pic_make_chunk(pic, str, len);
} else {
if (len == 0) {
str = "";
}
c = pic_make_chunk_lit(pic, str, -len);
}
return pic_make_string(pic, pic_make_rope(pic, c));
}
int
@ -276,19 +288,31 @@ pic_str_cmp(pic_state *pic, pic_str *str1, pic_str *str2)
return strcmp(pic_str_cstr(pic, str1), pic_str_cstr(pic, str2));
}
int
pic_str_hash(pic_state *pic, pic_str *str)
{
const char *s;
int h = 0;
s = pic_str_cstr(pic, str);
while (*s) {
h = (h << 5) - h + *s++;
}
return h;
}
const char *
pic_str_cstr(pic_state *pic, pic_str *str)
{
return rope_cstr(pic, str->rope);
}
pic_value
pic_xvfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap)
static void
pic_vfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap)
{
char c;
pic_value irrs = pic_nil_value();
while ((c = *fmt++)) {
while ((c = *fmt++) != '\0') {
switch (c) {
default:
xfputc(pic, c, file);
@ -336,52 +360,17 @@ pic_xvfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap)
xfputc(pic, '\n', file);
break;
case 'a':
irrs = pic_cons(pic, pic_fdisplay(pic, va_arg(ap, pic_value), file), irrs);
pic_fdisplay(pic, va_arg(ap, pic_value), file);
break;
case 's':
irrs = pic_cons(pic, pic_fwrite(pic, va_arg(ap, pic_value), file), irrs);
pic_fwrite(pic, va_arg(ap, pic_value), file);
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);
return;
}
pic_str *
@ -547,7 +536,7 @@ pic_str_string_append(pic_state *pic)
pic_get_args(pic, "*", &argc, &argv);
str = pic_make_str(pic, NULL, 0);
str = pic_make_lit(pic, "");
for (i = 0; i < argc; ++i) {
if (! pic_str_p(argv[i])) {
pic_errorf(pic, "type error");
@ -651,7 +640,7 @@ pic_str_list_to_string(pic_state *pic)
pic_get_args(pic, "o", &list);
if (pic_length(pic, list) == 0) {
return pic_obj_value(pic_make_str(pic, NULL, 0));
return pic_obj_value(pic_make_lit(pic, ""));
}
buf = pic_malloc(pic, pic_length(pic, list));

137
extlib/benz/symbol.c
View File

@ -4,47 +4,58 @@
#include "picrin.h"
KHASH_DEFINE(s, const char *, pic_sym *, kh_str_hash_func, kh_str_hash_equal)
#define kh_pic_str_hash(a) (pic_str_hash(pic, (a)))
#define kh_pic_str_cmp(a, b) (pic_str_cmp(pic, (a), (b)) == 0)
KHASH_DEFINE(s, pic_str *, pic_sym *, kh_pic_str_hash, kh_pic_str_cmp)
pic_sym *
pic_intern_str(pic_state *pic, pic_str *str)
{
return pic_intern(pic, pic_str_cstr(pic, str));
}
pic_sym *
pic_intern(pic_state *pic, const char *cstr)
pic_intern(pic_state *pic, pic_str *str)
{
khash_t(s) *h = &pic->syms;
pic_sym *sym;
khiter_t it;
int ret;
char *copy;
it = kh_put(s, h, cstr, &ret);
it = kh_put(s, h, str, &ret);
if (ret == 0) { /* if exists */
sym = kh_val(h, it);
pic_gc_protect(pic, pic_obj_value(sym));
return sym;
}
copy = pic_malloc(pic, strlen(cstr) + 1);
strcpy(copy, cstr);
kh_key(h, it) = copy;
kh_val(h, it) = pic->sQUOTE; /* insert dummy */
sym = (pic_sym *)pic_obj_alloc(pic, sizeof(pic_sym), PIC_TT_SYMBOL);
sym->cstr = copy;
sym->str = str;
kh_val(h, it) = sym;
return sym;
}
const char *
pic_symbol_name(pic_state PIC_UNUSED(*pic), pic_sym *sym)
pic_id *
pic_make_identifier(pic_state *pic, pic_id *id, struct pic_env *env)
{
return sym->cstr;
pic_id *nid;
nid = (pic_id *)pic_obj_alloc(pic, sizeof(pic_id), PIC_TT_ID);
nid->u.id.id = id;
nid->u.id.env = env;
return nid;
}
const char *
pic_symbol_name(pic_state *pic, pic_sym *sym)
{
return pic_str_cstr(pic, sym->str);
}
const char *
pic_identifier_name(pic_state *pic, pic_id *id)
{
while (! pic_sym_p(pic_obj_value(id))) {
id = id->u.id.id;
}
return pic_symbol_name(pic, (pic_sym *)id);
}
static pic_value
@ -83,7 +94,7 @@ pic_symbol_symbol_to_string(pic_state *pic)
pic_get_args(pic, "m", &sym);
return pic_obj_value(pic_make_str_cstr(pic, sym->cstr));
return pic_obj_value(sym->str);
}
static pic_value
@ -93,16 +104,94 @@ pic_symbol_string_to_symbol(pic_state *pic)
pic_get_args(pic, "s", &str);
return pic_obj_value(pic_intern_str(pic, str));
return pic_obj_value(pic_intern(pic, str));
}
static pic_value
pic_symbol_identifier_p(pic_state *pic)
{
pic_value obj;
pic_get_args(pic, "o", &obj);
return pic_bool_value(pic_id_p(obj));
}
static pic_value
pic_symbol_make_identifier(pic_state *pic)
{
pic_value id, env;
pic_get_args(pic, "oo", &id, &env);
pic_assert_type(pic, id, id);
pic_assert_type(pic, env, env);
return pic_obj_value(pic_make_identifier(pic, pic_id_ptr(id), pic_env_ptr(env)));
}
static pic_value
pic_symbol_identifier_variable(pic_state *pic)
{
pic_value id;
pic_get_args(pic, "o", &id);
pic_assert_type(pic, id, id);
if (pic_sym_p(id)) {
pic_errorf(pic, "expected non-symbol identifier, but got symbol ~s", id);
}
return pic_obj_value(pic_id_ptr(id)->u.id.id);
}
static pic_value
pic_symbol_identifier_environment(pic_state *pic)
{
pic_value id;
pic_get_args(pic, "o", &id);
pic_assert_type(pic, id, id);
if (pic_sym_p(id)) {
pic_errorf(pic, "expected non-symbol identifier, but got symbol ~s", id);
}
return pic_obj_value(pic_id_ptr(id)->u.id.env);
}
static pic_value
pic_symbol_identifier_eq_p(pic_state *pic)
{
int argc, i;
pic_value *argv;
pic_get_args(pic, "*", &argc, &argv);
for (i = 0; i < argc; ++i) {
if (! pic_id_p(argv[i])) {
return pic_false_value();
}
if (! pic_equal_p(pic, argv[i], argv[0])) {
return pic_false_value();
}
}
return pic_true_value();
}
void
pic_init_symbol(pic_state *pic)
{
pic_defun(pic, "symbol?", pic_symbol_symbol_p);
pic_defun(pic, "symbol=?", pic_symbol_symbol_eq_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);
pic_defun(pic, "make-identifier", pic_symbol_make_identifier);
pic_defun(pic, "identifier?", pic_symbol_identifier_p);
pic_defun(pic, "identifier=?", pic_symbol_identifier_eq_p);
pic_defun(pic, "identifier-variable", pic_symbol_identifier_variable);
pic_defun(pic, "identifier-environment", pic_symbol_identifier_environment);
}

4
extlib/benz/var.c
View File

@ -43,11 +43,11 @@ var_set(pic_state *pic, struct pic_proc *var, pic_value val)
static pic_value
var_call(pic_state *pic)
{
struct pic_proc *self = pic_get_proc(pic);
struct pic_proc *self;
pic_value val;
int n;
n = pic_get_args(pic, "|o", &val);
n = pic_get_args(pic, "&|o", &self, &val);
if (n == 0) {
return var_get(pic, self);

1030
extlib/benz/vm.c
View File

File diff suppressed because it is too large Load Diff

4
extlib/benz/reg.c → extlib/benz/weak.c
View File

@ -104,12 +104,12 @@ reg_set(pic_state *pic, struct pic_reg *reg, void *key, pic_value val)
static pic_value
reg_call(pic_state *pic)
{
struct pic_proc *self = pic_get_proc(pic);
struct pic_proc *self;
struct pic_reg *reg;
pic_value key, val;
int n;
n = pic_get_args(pic, "o|o", &key, &val);
n = pic_get_args(pic, "&o|o", &self, &key, &val);
if (! pic_obj_p(key)) {
pic_errorf(pic, "attempted to set a non-object key '~s' in a register", key);

4
extlib/benz/write.c
View File

@ -283,7 +283,7 @@ write_core(struct writer_control *p, pic_value obj)
xfprintf(pic, file, pic_true_p(obj) ? "#t" : "#f");
break;
case PIC_TT_ID:
xfprintf(pic, file, "#<identifier %s>", pic_symbol_name(pic, pic_var_name(pic, obj)));
xfprintf(pic, file, "#<identifier %s>", pic_identifier_name(pic, pic_id_ptr(obj)));
break;
case PIC_TT_EOF:
xfprintf(pic, file, "#.(eof-object)");
@ -437,7 +437,7 @@ pic_printf(pic_state *pic, const char *fmt, ...)
va_start(ap, fmt);
str = pic_str_ptr(pic_car(pic, pic_xvformat(pic, fmt, ap)));
str = pic_vformat(pic, fmt, ap);
va_end(ap);