Merge branch 'master' into bench
This commit is contained in:
Sunrim KIM (keen)
commit
0d5258054a
16
Makefile
16
Makefile
|
|
@ -12,6 +12,7 @@ PICRIN_LIBS = \
|
|||
piclib/picrin/macro.scm\
|
||||
piclib/picrin/record.scm\
|
||||
piclib/picrin/array.scm\
|
||||
piclib/picrin/control.scm\
|
||||
piclib/picrin/experimental/lambda.scm\
|
||||
piclib/picrin/syntax-rules.scm\
|
||||
piclib/picrin/test.scm
|
||||
|
|
@ -33,7 +34,7 @@ all: bin/picrin
|
|||
|
||||
include $(sort $(wildcard contrib/*/nitro.mk))
|
||||
|
||||
debug: CFLAGS += -O0 -g -DDEBUG=1
|
||||
debug: CFLAGS += -O0 -g
|
||||
debug: bin/picrin
|
||||
|
||||
bin/picrin: $(PICRIN_OBJS) $(CONTRIB_OBJS) lib/libbenz.a
|
||||
|
|
@ -48,6 +49,10 @@ src/init_contrib.c:
|
|||
lib/libbenz.a: $(BENZ_OBJS)
|
||||
$(AR) $(ARFLAGS) $@ $(BENZ_OBJS)
|
||||
|
||||
extlib/benz/boot.o: extlib/benz/boot.c
|
||||
cd extlib/benz; perl boot.c
|
||||
$(CC) $(CFLAGS) -c -o $@ $<
|
||||
|
||||
$(BENZ_OBJS) $(PICRIN_OBJS) $(CONTRIB_OBJS): extlib/benz/include/picrin.h extlib/benz/include/picrin/*.h
|
||||
|
||||
doc: docs/*.rst docs/contrib.rst
|
||||
|
|
@ -64,15 +69,12 @@ docs/contrib.rst: $(CONTRIB_DOCS)
|
|||
run: bin/picrin
|
||||
bin/picrin
|
||||
|
||||
test: test-r7rs test-contribs test-nostdlib
|
||||
|
||||
test-r7rs: bin/picrin t/r7rs-tests.scm
|
||||
bin/picrin t/r7rs-tests.scm
|
||||
test: test-contribs test-nostdlib
|
||||
|
||||
test-contribs: bin/picrin $(CONTRIB_TESTS)
|
||||
|
||||
test-nostdlib:
|
||||
$(CC) -I extlib/benz/include -D'PIC_ENABLE_LIBC=0' -D'PIC_ENABLE_FLOAT=0'-nostdlib -fPIC -shared -std=c89 -ansi -pedantic -Wall -Wextra -o lib/libbenz.so $(BENZ_SRCS)
|
||||
$(CC) -I extlib/benz/include -D'PIC_ENABLE_LIBC=0' -D'PIC_ENABLE_FLOAT=0' -D'PIC_ENABLE_STDIO=0' -nostdlib -fPIC -shared -std=c89 -ansi -pedantic -Wall -Wextra -o lib/libbenz.so $(BENZ_SRCS) etc/libc_polyfill.c -fno-stack-protector
|
||||
rm -f lib/libbenz.so
|
||||
|
||||
install: all
|
||||
|
|
@ -85,4 +87,4 @@ clean:
|
|||
rm -f $(PICRIN_OBJS)
|
||||
rm -f $(CONTRIB_OBJS)
|
||||
|
||||
.PHONY: all insall clean run test test-r7rs test-contribs doc $(CONTRIB_TESTS)
|
||||
.PHONY: all install clean run test test-r7rs test-contribs doc $(CONTRIB_TESTS)
|
||||
|
|
|
|||
|
|
@ -1,2 +0,0 @@
|
|||
CONTRIB_INITS += callcc
|
||||
CONTRIB_SRCS += $(wildcard contrib/03.callcc/*.c)
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
CONTRIB_INITS += r7rs
|
||||
|
||||
CONTRIB_SRCS += \
|
||||
contrib/05.r7rs/src/r7rs.c\
|
||||
contrib/05.r7rs/src/file.c\
|
||||
contrib/05.r7rs/src/load.c\
|
||||
contrib/05.r7rs/src/mutable-string.c\
|
||||
contrib/05.r7rs/src/system.c\
|
||||
contrib/05.r7rs/src/time.c
|
||||
|
||||
CONTRIB_LIBS += \
|
||||
contrib/05.r7rs/scheme/base.scm\
|
||||
contrib/05.r7rs/scheme/cxr.scm\
|
||||
contrib/05.r7rs/scheme/read.scm\
|
||||
contrib/05.r7rs/scheme/write.scm\
|
||||
contrib/05.r7rs/scheme/file.scm\
|
||||
contrib/05.r7rs/scheme/case-lambda.scm\
|
||||
contrib/05.r7rs/scheme/lazy.scm\
|
||||
contrib/05.r7rs/scheme/eval.scm\
|
||||
contrib/05.r7rs/scheme/inexact.scm\
|
||||
contrib/05.r7rs/scheme/load.scm\
|
||||
contrib/05.r7rs/scheme/process-context.scm\
|
||||
contrib/05.r7rs/scheme/time.scm\
|
||||
contrib/05.r7rs/scheme/r5rs.scm
|
||||
|
|
@ -1,29 +0,0 @@
|
|||
(define-library (scheme case-lambda)
|
||||
(import (scheme base))
|
||||
|
||||
(define-syntax case-lambda
|
||||
(syntax-rules ()
|
||||
((case-lambda (params body0 ...) ...)
|
||||
(lambda args
|
||||
(let ((len (length args)))
|
||||
(letrec-syntax
|
||||
((cl (syntax-rules ::: ()
|
||||
((cl)
|
||||
(error "no matching clause"))
|
||||
((cl ((p :::) . body) . rest)
|
||||
(if (= len (length '(p :::)))
|
||||
(apply (lambda (p :::)
|
||||
. body)
|
||||
args)
|
||||
(cl . rest)))
|
||||
((cl ((p ::: . tail) . body)
|
||||
. rest)
|
||||
(if (>= len (length '(p :::)))
|
||||
(apply
|
||||
(lambda (p ::: . tail)
|
||||
. body)
|
||||
args)
|
||||
(cl . rest))))))
|
||||
(cl (params body0 ...) ...)))))))
|
||||
|
||||
(export case-lambda))
|
||||
|
|
@ -1,17 +0,0 @@
|
|||
(define-library (scheme eval)
|
||||
(import (picrin base))
|
||||
|
||||
(define environment
|
||||
(let ((counter 0))
|
||||
(lambda specs
|
||||
(let ((library-name `(picrin @@my-environment ,counter)))
|
||||
(set! counter (+ counter 1))
|
||||
(eval
|
||||
`(define-library ,library-name
|
||||
,@(map (lambda (spec)
|
||||
`(import ,spec))
|
||||
specs))
|
||||
'(scheme base))
|
||||
library-name))))
|
||||
|
||||
(export environment eval))
|
||||
|
|
@ -1,42 +0,0 @@
|
|||
;;; Appendix A. Standard Libraries Lazy
|
||||
|
||||
(define-library (scheme lazy)
|
||||
(import (scheme base)
|
||||
(picrin macro))
|
||||
|
||||
(define-record-type <promise>
|
||||
(make-promise% done obj)
|
||||
promise?
|
||||
(done promise-done? promise-done!)
|
||||
(obj promise-value promise-value!))
|
||||
|
||||
(define-syntax delay-force
|
||||
(ir-macro-transformer
|
||||
(lambda (form rename compare?)
|
||||
(let ((expr (cadr form)))
|
||||
`(make-promise% #f (lambda () ,expr))))))
|
||||
|
||||
(define-syntax delay
|
||||
(ir-macro-transformer
|
||||
(lambda (form rename compare?)
|
||||
(let ((expr (cadr form)))
|
||||
`(delay-force (make-promise% #t ,expr))))))
|
||||
|
||||
(define (promise-update! new old)
|
||||
(promise-done! old (promise-done? new))
|
||||
(promise-value! old (promise-value new)))
|
||||
|
||||
(define (force promise)
|
||||
(if (promise-done? promise)
|
||||
(promise-value promise)
|
||||
(let ((promise* ((promise-value promise))))
|
||||
(unless (promise-done? promise)
|
||||
(promise-update! promise* promise))
|
||||
(force promise))))
|
||||
|
||||
(define (make-promise obj)
|
||||
(if (promise? obj)
|
||||
obj
|
||||
(make-promise% #t obj)))
|
||||
|
||||
(export delay-force delay force make-promise promise?))
|
||||
|
|
@ -3,7 +3,7 @@
|
|||
struct pic_fullcont {
|
||||
jmp_buf jmp;
|
||||
|
||||
pic_jmpbuf *prev_jmp;
|
||||
struct pic_cont *prev_jmp;
|
||||
|
||||
pic_checkpoint *cp;
|
||||
|
||||
|
|
@ -122,7 +122,7 @@ save_cont(pic_state *pic, struct pic_fullcont **c)
|
|||
|
||||
cont = *c = pic_malloc(pic, sizeof(struct pic_fullcont));
|
||||
|
||||
cont->prev_jmp = pic->jmp;
|
||||
cont->prev_jmp = pic->cc;
|
||||
|
||||
cont->cp = pic->cp;
|
||||
|
||||
|
|
@ -178,11 +178,10 @@ restore_cont(pic_state *pic, struct pic_fullcont *cont)
|
|||
if (&v > cont->stk_pos) native_stack_extend(pic, cont);
|
||||
}
|
||||
else {
|
||||
if (&v > cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont);
|
||||
if (&v < cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont);
|
||||
}
|
||||
|
||||
pic->jmp = cont->prev_jmp;
|
||||
|
||||
pic->cc = cont->prev_jmp;
|
||||
pic->cp = cont->cp;
|
||||
|
||||
pic->stbase = pic_realloc(pic, pic->stbase, sizeof(pic_value) * cont->st_len);
|
||||
|
|
@ -247,7 +246,7 @@ pic_callcc_full(pic_state *pic, struct pic_proc *proc)
|
|||
struct pic_proc *c;
|
||||
struct pic_data *dat;
|
||||
|
||||
c = pic_make_proc(pic, cont_call, "<continuation-procedure>");
|
||||
c = pic_make_proc(pic, cont_call);
|
||||
|
||||
dat = pic_data_alloc(pic, &cont_type, cont);
|
||||
|
||||
|
|
@ -271,7 +270,7 @@ pic_callcc_full_trampoline(pic_state *pic, struct pic_proc *proc)
|
|||
struct pic_proc *c;
|
||||
struct pic_data *dat;
|
||||
|
||||
c = pic_make_proc(pic, cont_call, "<continuation-procedure>");
|
||||
c = pic_make_proc(pic, cont_call);
|
||||
|
||||
dat = pic_data_alloc(pic, &cont_type, cont);
|
||||
|
||||
|
|
@ -293,15 +292,11 @@ pic_callcc_callcc(pic_state *pic)
|
|||
}
|
||||
|
||||
#define pic_redefun(pic, lib, name, func) \
|
||||
pic_set(pic, lib, name, pic_obj_value(pic_make_proc(pic, func, name)))
|
||||
pic_set(pic, lib, name, pic_obj_value(pic_make_proc(pic, func)))
|
||||
|
||||
void
|
||||
pic_init_callcc(pic_state *pic)
|
||||
{
|
||||
pic_deflibrary (pic, "(picrin control)") {
|
||||
pic_define(pic, "escape", pic_ref(pic, pic->PICRIN_BASE, "call-with-current-continuation"));
|
||||
}
|
||||
|
||||
pic_deflibrary (pic, "(scheme base)") {
|
||||
pic_redefun(pic, pic->PICRIN_BASE, "call-with-current-continuation", pic_callcc_callcc);
|
||||
pic_redefun(pic, pic->PICRIN_BASE, "call/cc", pic_callcc_callcc);
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
CONTRIB_INITS += callcc
|
||||
CONTRIB_SRCS += $(wildcard contrib/10.callcc/*.c)
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
CONTRIB_LIBS += $(wildcard contrib/10.optional/piclib/*.scm)
|
||||
CONTRIB_TESTS += test-optional
|
||||
|
||||
test-optional: bin/picrin
|
||||
for test in `ls contrib/10.optional/t/*.scm`; do \
|
||||
bin/picrin $$test; \
|
||||
done
|
||||
|
|
@ -1 +0,0 @@
|
|||
CONTRIB_LIBS += $(wildcard contrib/10.partcont/piclib/*.scm)
|
||||
|
|
@ -1 +0,0 @@
|
|||
CONTRIB_LIBS += contrib/10.pretty-print/pretty-print.scm
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
CONTRIB_LIBS += \
|
||||
contrib/10.srfi/srfi/1.scm\
|
||||
contrib/10.srfi/srfi/8.scm\
|
||||
contrib/10.srfi/srfi/17.scm\
|
||||
contrib/10.srfi/srfi/26.scm\
|
||||
contrib/10.srfi/srfi/43.scm\
|
||||
contrib/10.srfi/srfi/60.scm\
|
||||
contrib/10.srfi/srfi/95.scm\
|
||||
contrib/10.srfi/srfi/111.scm
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
CONTRIB_LIBS += $(wildcard contrib/20.for/piclib/*.scm)
|
||||
CONTRIB_TESTS += test-for
|
||||
|
||||
test-for: bin/picrin
|
||||
for test in `ls contrib/20.for/t/*.scm`; do \
|
||||
bin/picrin "$$test"; \
|
||||
done
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
CONTRIB_INITS += r7rs
|
||||
|
||||
CONTRIB_SRCS += \
|
||||
contrib/20.r7rs/src/r7rs.c\
|
||||
contrib/20.r7rs/src/file.c\
|
||||
contrib/20.r7rs/src/load.c\
|
||||
contrib/20.r7rs/src/mutable-string.c\
|
||||
contrib/20.r7rs/src/system.c\
|
||||
contrib/20.r7rs/src/time.c
|
||||
|
||||
CONTRIB_LIBS += \
|
||||
contrib/20.r7rs/scheme/base.scm\
|
||||
contrib/20.r7rs/scheme/cxr.scm\
|
||||
contrib/20.r7rs/scheme/read.scm\
|
||||
contrib/20.r7rs/scheme/write.scm\
|
||||
contrib/20.r7rs/scheme/file.scm\
|
||||
contrib/20.r7rs/scheme/case-lambda.scm\
|
||||
contrib/20.r7rs/scheme/lazy.scm\
|
||||
contrib/20.r7rs/scheme/eval.scm\
|
||||
contrib/20.r7rs/scheme/inexact.scm\
|
||||
contrib/20.r7rs/scheme/load.scm\
|
||||
contrib/20.r7rs/scheme/process-context.scm\
|
||||
contrib/20.r7rs/scheme/time.scm\
|
||||
contrib/20.r7rs/scheme/r5rs.scm
|
||||
|
||||
CONTRIB_TESTS += test-r7rs
|
||||
|
||||
test-r7rs: bin/picrin
|
||||
for test in `ls contrib/20.r7rs/t/*.scm`; do \
|
||||
bin/picrin "$$test"; \
|
||||
done
|
||||
|
|
@ -518,4 +518,6 @@
|
|||
write-string
|
||||
write-u8
|
||||
write-bytevector
|
||||
flush-output-port))
|
||||
flush-output-port)
|
||||
|
||||
(export features))
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
(define-library (scheme case-lambda)
|
||||
(import (scheme base))
|
||||
|
||||
(define (length+ list)
|
||||
(if (pair? list)
|
||||
(+ 1 (length+ (cdr list)))
|
||||
0))
|
||||
|
||||
(define-syntax case-lambda
|
||||
(syntax-rules ()
|
||||
((case-lambda (params body0 ...) ...)
|
||||
(lambda args
|
||||
(let ((len (length args)))
|
||||
(letrec-syntax
|
||||
((cl (syntax-rules ()
|
||||
((cl)
|
||||
(error "no matching clause"))
|
||||
((cl (formal . body) . rest)
|
||||
(if (if (list? 'formal)
|
||||
(= len (length 'formal))
|
||||
(>= len (length+ 'formal)))
|
||||
(apply (lambda formal . body) args)
|
||||
(cl . rest))))))
|
||||
(cl (params body0 ...) ...)))))))
|
||||
|
||||
(export case-lambda))
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
(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))))))
|
||||
|
||||
(export environment eval))
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
;;; Appendix A. Standard Libraries Lazy
|
||||
|
||||
(define-library (scheme lazy)
|
||||
(import (scheme base)
|
||||
(picrin macro))
|
||||
|
||||
(define-record-type <promise>
|
||||
(make-promise% done value)
|
||||
promise?
|
||||
(done promise-done? set-promise-done!)
|
||||
(value promise-value set-promise-value!))
|
||||
|
||||
(define-syntax delay-force
|
||||
(syntax-rules ()
|
||||
((_ expr)
|
||||
(make-promise% #f (lambda () expr)))))
|
||||
|
||||
(define-syntax delay
|
||||
(syntax-rules ()
|
||||
((_ expr)
|
||||
(delay-force (make-promise% #t expr)))))
|
||||
|
||||
(define (force promise)
|
||||
(if (promise-done? promise)
|
||||
(promise-value promise)
|
||||
(let ((new-promise ((promise-value promise))))
|
||||
(set-promise-done! promise (promise-done? new-promise))
|
||||
(set-promise-value! promise (promise-value new-promise))
|
||||
(force promise))))
|
||||
|
||||
(define (make-promise obj)
|
||||
(if (promise? obj)
|
||||
obj
|
||||
(make-promise% #t obj)))
|
||||
|
||||
(export delay-force
|
||||
delay
|
||||
force
|
||||
make-promise
|
||||
promise?))
|
||||
|
|
@ -7,7 +7,8 @@
|
|||
(scheme cxr)
|
||||
(scheme lazy)
|
||||
(scheme eval)
|
||||
(scheme load))
|
||||
(scheme load)
|
||||
(picrin base))
|
||||
|
||||
(define-library (scheme null)
|
||||
(import (scheme base))
|
||||
|
|
@ -25,12 +26,12 @@
|
|||
(define (null-environment n)
|
||||
(if (not (= n 5))
|
||||
(error "unsupported environment version" n)
|
||||
'(scheme null)))
|
||||
(library-environment (find-library '(scheme null)))))
|
||||
|
||||
(define (scheme-report-environment n)
|
||||
(if (not (= n 5))
|
||||
(error "unsupported environment version" n)
|
||||
'(scheme r5rs)))
|
||||
(library-environment (find-library '(scheme r5rs)))))
|
||||
|
||||
(export * + - / < <= = > >=
|
||||
abs acos and
|
||||
|
|
@ -4,6 +4,8 @@
|
|||
|
||||
#include "picrin.h"
|
||||
|
||||
#include <stdio.h>
|
||||
|
||||
PIC_NORETURN static void
|
||||
file_error(pic_state *pic, const char *msg)
|
||||
{
|
||||
|
|
@ -14,25 +16,6 @@ file_error(pic_state *pic, const char *msg)
|
|||
pic_raise(pic, pic_obj_value(e));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
generic_open_file(pic_state *pic, const char *fname, char *mode, short flags)
|
||||
{
|
||||
struct pic_port *port;
|
||||
xFILE *file;
|
||||
|
||||
file = xfopen(fname, mode);
|
||||
if (! file) {
|
||||
file_error(pic, "could not open file");
|
||||
}
|
||||
|
||||
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
|
||||
port->file = file;
|
||||
port->flags = flags;
|
||||
port->status = PIC_PORT_OPEN;
|
||||
|
||||
return pic_obj_value(port);
|
||||
}
|
||||
|
||||
pic_value
|
||||
pic_file_open_input_file(pic_state *pic)
|
||||
{
|
||||
|
|
@ -41,7 +24,7 @@ pic_file_open_input_file(pic_state *pic)
|
|||
|
||||
pic_get_args(pic, "z", &fname);
|
||||
|
||||
return generic_open_file(pic, fname, "r", flags);
|
||||
return pic_obj_value(pic_open_file(pic, fname, flags));
|
||||
}
|
||||
|
||||
pic_value
|
||||
|
|
@ -52,7 +35,7 @@ pic_file_open_binary_input_file(pic_state *pic)
|
|||
|
||||
pic_get_args(pic, "z", &fname);
|
||||
|
||||
return generic_open_file(pic, fname, "rb", flags);
|
||||
return pic_obj_value(pic_open_file(pic, fname, flags));
|
||||
}
|
||||
|
||||
pic_value
|
||||
|
|
@ -63,7 +46,7 @@ pic_file_open_output_file(pic_state *pic)
|
|||
|
||||
pic_get_args(pic, "z", &fname);
|
||||
|
||||
return generic_open_file(pic, fname, "w", flags);
|
||||
return pic_obj_value(pic_open_file(pic, fname, flags));
|
||||
}
|
||||
|
||||
pic_value
|
||||
|
|
@ -74,7 +57,7 @@ pic_file_open_binary_output_file(pic_state *pic)
|
|||
|
||||
pic_get_args(pic, "z", &fname);
|
||||
|
||||
return generic_open_file(pic, fname, "wb", flags);
|
||||
return pic_obj_value(pic_open_file(pic, fname, flags));
|
||||
}
|
||||
|
||||
pic_value
|
||||
|
|
@ -8,17 +8,8 @@ void
|
|||
pic_load(pic_state *pic, const char *filename)
|
||||
{
|
||||
struct pic_port *port;
|
||||
xFILE *file;
|
||||
|
||||
file = xfopen(filename, "r");
|
||||
if (file == NULL) {
|
||||
pic_errorf(pic, "could not open file: %s", filename);
|
||||
}
|
||||
|
||||
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
|
||||
port->file = file;
|
||||
port->flags = PIC_PORT_IN | PIC_PORT_TEXT;
|
||||
port->status = PIC_PORT_OPEN;
|
||||
port = pic_open_file(pic, filename, PIC_PORT_IN | PIC_PORT_TEXT);
|
||||
|
||||
pic_load_port(pic, port);
|
||||
|
||||
|
|
@ -460,9 +460,9 @@
|
|||
(syntax-rules ()
|
||||
((be-like-begin name)
|
||||
(define-syntax name
|
||||
(syntax-rules ()
|
||||
((name expr (... ...))
|
||||
(begin expr (... ...))))))))
|
||||
(syntax-rules ::: ()
|
||||
((name expr :::)
|
||||
(begin expr :::)))))))
|
||||
(be-like-begin sequence)
|
||||
(test 4 (sequence 1 2 3 4))
|
||||
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
CONTRIB_LIBS += contrib/20.repl/repl.scm
|
||||
CONTRIB_SRCS += contrib/20.repl/repl.c
|
||||
CONTRIB_INITS += repl
|
||||
|
|
@ -1 +0,0 @@
|
|||
CONTRIB_LIBS += contrib/30.main/main.scm
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
CONTRIB_LIBS += $(wildcard contrib/30.optional/piclib/*.scm)
|
||||
CONTRIB_TESTS += test-optional
|
||||
|
||||
test-optional: bin/picrin
|
||||
for test in `ls contrib/30.optional/t/*.scm`; do \
|
||||
bin/picrin $$test; \
|
||||
done
|
||||
|
|
@ -0,0 +1 @@
|
|||
CONTRIB_LIBS += $(wildcard contrib/30.partcont/piclib/*.scm)
|
||||
|
|
@ -0,0 +1 @@
|
|||
CONTRIB_LIBS += contrib/30.pretty-print/pretty-print.scm
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
CONTRIB_INITS += random
|
||||
CONTRIB_SRCS += $(wildcard contrib/10.random/src/*.c)
|
||||
CONTRIB_SRCS += $(wildcard contrib/30.random/src/*.c)
|
||||
CONTRIB_TESTS += test-random
|
||||
|
||||
test-random: bin/picrin
|
||||
for test in `ls contrib/10.random/t/*.scm`; do \
|
||||
for test in `ls contrib/30.random/t/*.scm`; do \
|
||||
bin/picrin $$test; \
|
||||
done
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
libedit_exists := $(shell pkg-config libedit --exists; echo $$?)
|
||||
|
||||
ifeq ($(libedit_exists),0)
|
||||
CONTRIB_SRCS += contrib/10.readline/src/readline.c
|
||||
CONTRIB_SRCS += contrib/30.readline/src/readline.c
|
||||
CONTRIB_INITS += readline
|
||||
CONTRIB_TESTS += test-readline
|
||||
LDFLAGS += `pkg-config libedit --libs`
|
||||
|
|
@ -11,6 +11,6 @@ contrib/src/readline.o: contrib/src/readline.c
|
|||
$(CC) $(CFLAGS) -o $@ $< `pkg-config libedit --cflags`
|
||||
|
||||
test-readline: bin/picrin
|
||||
for test in `ls contrib/10.readline/t/*.scm`; do \
|
||||
for test in `ls contrib/30.readline/t/*.scm`; do \
|
||||
bin/picrin $$test; \
|
||||
done
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
CONTRIB_SRCS += contrib/10.regexp/src/regexp.c
|
||||
CONTRIB_SRCS += contrib/30.regexp/src/regexp.c
|
||||
CONTRIB_INITS += regexp
|
||||
CONTRIB_TESTS += test-regexp
|
||||
|
||||
test-regexp: bin/picrin
|
||||
for test in `ls contrib/10.regexp/t/*.scm`; do \
|
||||
for test in `ls contrib/30.regexp/t/*.scm`; do \
|
||||
bin/picrin $$test; \
|
||||
done
|
||||
|
|
@ -1 +0,0 @@
|
|||
CONTRIB_LIBS += $(wildcard contrib/40.class/piclib/picrin/*.scm)
|
||||
|
|
@ -36,6 +36,11 @@ SRFI libraries
|
|||
|
||||
Sorting and Marging.
|
||||
|
||||
- `(srfi 106)
|
||||
<http://srfi.schemers.org/srfi-106/>`_
|
||||
|
||||
Basic socket interface
|
||||
|
||||
- `(srfi 111)
|
||||
<http://srfi.schemers.org/srfi-111/>`_
|
||||
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
; A R7RS port of "simple echo client" example in SRFI 106
|
||||
;
|
||||
; Copyright (C) Takashi Kato (2012). All Rights Reserved.
|
||||
;
|
||||
; 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.
|
||||
|
||||
(import (scheme base)
|
||||
(srfi 106))
|
||||
|
||||
(define echo-client-socket (make-client-socket "localhost" "5000"))
|
||||
|
||||
(socket-send echo-client-socket (string->utf8 "hello\r\n"))
|
||||
(socket-recv echo-client-socket (string-length "hello\r\n"))
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
; A R7RS port of "simple echo server" example in SRFI 106
|
||||
;
|
||||
; Copyright (C) Takashi Kato (2012). All Rights Reserved.
|
||||
;
|
||||
; 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.
|
||||
|
||||
(import (scheme base)
|
||||
(srfi 106))
|
||||
|
||||
(define echo-server-socket (make-server-socket "5000"))
|
||||
|
||||
(define (server-run)
|
||||
(define (get-line-from-binary-port bin)
|
||||
(utf8->string
|
||||
(call-with-port (open-output-bytevector)
|
||||
(lambda (out)
|
||||
(let loop ((b (read-u8 bin)))
|
||||
(case b
|
||||
((10) (get-output-bytevector out))
|
||||
((13) (loop (read-u8 bin)))
|
||||
(else (write-u8 b out) (loop (read-u8 bin)))))))))
|
||||
|
||||
(call-with-socket (socket-accept echo-server-socket)
|
||||
(lambda (sock)
|
||||
(let ((in (socket-input-port sock))
|
||||
(out (socket-output-port sock)))
|
||||
(let loop ((r (get-line-from-binary-port in)))
|
||||
(write-bytevector (string->utf8 (string-append r "\r\n")) out)
|
||||
(loop (get-line-from-binary-port in)))))))
|
||||
|
||||
(server-run)
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
CONTRIB_INITS += socket
|
||||
CONTRIB_LIBS += \
|
||||
contrib/40.srfi/srfi/1.scm\
|
||||
contrib/40.srfi/srfi/8.scm\
|
||||
contrib/40.srfi/srfi/17.scm\
|
||||
contrib/40.srfi/srfi/26.scm\
|
||||
contrib/40.srfi/srfi/43.scm\
|
||||
contrib/40.srfi/srfi/60.scm\
|
||||
contrib/40.srfi/srfi/95.scm\
|
||||
contrib/40.srfi/srfi/106.scm\
|
||||
contrib/40.srfi/srfi/111.scm
|
||||
CONTRIB_SRCS += contrib/40.srfi/src/106.c
|
||||
CONTRIB_TESTS += test-srfi
|
||||
|
||||
test-srfi: bin/picrin
|
||||
for test in `ls contrib/40.srfi/t/*.scm`; do \
|
||||
bin/picrin "$$test"; \
|
||||
done
|
||||
|
|
@ -0,0 +1,521 @@
|
|||
#include "picrin.h"
|
||||
|
||||
#include <errno.h>
|
||||
#include <netdb.h>
|
||||
#include <netinet/in.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <sys/param.h>
|
||||
#include <sys/socket.h>
|
||||
#include <unistd.h>
|
||||
|
||||
#ifndef EWOULDBLOCK
|
||||
#define EWOULDBLOCK EAGAIN
|
||||
#endif
|
||||
|
||||
struct pic_socket_t {
|
||||
int fd;
|
||||
};
|
||||
|
||||
PIC_INLINE void
|
||||
socket_close(struct pic_socket_t *sock)
|
||||
{
|
||||
if (sock != NULL && sock->fd != -1) {
|
||||
close(sock->fd);
|
||||
sock->fd = -1;
|
||||
}
|
||||
}
|
||||
|
||||
PIC_INLINE void
|
||||
ensure_socket_is_open(pic_state *pic, struct pic_socket_t *sock)
|
||||
{
|
||||
if (sock != NULL && sock->fd == -1) {
|
||||
pic_errorf(pic, "the socket is already closed");
|
||||
}
|
||||
}
|
||||
|
||||
static void
|
||||
socket_dtor(pic_state *pic, void *data)
|
||||
{
|
||||
struct pic_socket_t *sock;
|
||||
|
||||
sock = data;
|
||||
socket_close(sock);
|
||||
pic_free(pic, data);
|
||||
}
|
||||
|
||||
static const pic_data_type socket_type = { "socket", socket_dtor, NULL };
|
||||
|
||||
#define pic_socket_p(o) (pic_data_type_p((o), &socket_type))
|
||||
#define pic_socket_data_ptr(o) ((struct pic_socket_t *)pic_data_ptr(o)->data)
|
||||
|
||||
PIC_INLINE void
|
||||
validate_socket_object(pic_state *pic, pic_value v)
|
||||
{
|
||||
if (! pic_socket_p(v)) {
|
||||
pic_errorf(pic, "~s is not a socket object", v);
|
||||
}
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_socket_socket_p(pic_state *pic)
|
||||
{
|
||||
pic_value obj;
|
||||
|
||||
pic_get_args(pic, "o", &obj);
|
||||
return pic_bool_value(pic_socket_p(obj));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_socket_make_socket(pic_state *pic)
|
||||
{
|
||||
pic_value n, s;
|
||||
const char *node, *service;
|
||||
int family, socktype, flags, protocol;
|
||||
int result;
|
||||
struct addrinfo hints, *ai, *it;
|
||||
struct pic_socket_t *sock;
|
||||
|
||||
pic_get_args(pic, "ooiiii", &n, &s, &family, &socktype, &flags, &protocol);
|
||||
|
||||
node = service = NULL;
|
||||
if (pic_str_p(n)) {
|
||||
node = pic_str_cstr(pic, pic_str_ptr(n));
|
||||
}
|
||||
if (pic_str_p(s)) {
|
||||
service = pic_str_cstr(pic, pic_str_ptr(s));
|
||||
}
|
||||
|
||||
sock = pic_malloc(pic, sizeof(struct pic_socket_t));
|
||||
sock->fd = -1;
|
||||
|
||||
memset(&hints, 0, sizeof(struct addrinfo));
|
||||
hints.ai_family = family;
|
||||
hints.ai_socktype = socktype;
|
||||
hints.ai_flags = flags;
|
||||
hints.ai_protocol = protocol;
|
||||
|
||||
errno = 0;
|
||||
|
||||
do {
|
||||
result = getaddrinfo(node, service, &hints, &ai);
|
||||
} while (result == EAI_AGAIN);
|
||||
if (result) {
|
||||
if (result == EAI_SYSTEM) {
|
||||
pic_errorf(pic, "%s", strerror(errno));
|
||||
}
|
||||
pic_errorf(pic, "%s", gai_strerror(result));
|
||||
}
|
||||
|
||||
for (it = ai; it != NULL; it = it->ai_next) {
|
||||
int fd;
|
||||
|
||||
fd = socket(it->ai_family, it->ai_socktype, it->ai_protocol);
|
||||
if (fd == -1) {
|
||||
continue;
|
||||
}
|
||||
|
||||
if (it->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) {
|
||||
if (it->ai_socktype == SOCK_STREAM ||
|
||||
it->ai_socktype == SOCK_SEQPACKET) {
|
||||
/* TODO: Backlog should be configurable. */
|
||||
if (listen(fd, 8) == 0) {
|
||||
sock->fd = fd;
|
||||
break;
|
||||
}
|
||||
} else {
|
||||
sock->fd = fd;
|
||||
break;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (connect(fd, it->ai_addr, it->ai_addrlen) == 0) {
|
||||
sock->fd = fd;
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
close(fd);
|
||||
}
|
||||
|
||||
freeaddrinfo(ai);
|
||||
|
||||
if (sock->fd == -1) {
|
||||
pic_errorf(pic, "%s", strerror(errno));
|
||||
}
|
||||
|
||||
return pic_obj_value(pic_data_alloc(pic, &socket_type, sock));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_socket_socket_accept(pic_state *pic)
|
||||
{
|
||||
pic_value obj;
|
||||
int fd = -1;
|
||||
struct pic_socket_t *sock, *new_sock;
|
||||
|
||||
pic_get_args(pic, "o", &obj);
|
||||
validate_socket_object(pic, obj);
|
||||
|
||||
sock = pic_socket_data_ptr(obj);
|
||||
ensure_socket_is_open(pic, sock);
|
||||
|
||||
errno = 0;
|
||||
while (1) {
|
||||
struct sockaddr_storage addr;
|
||||
socklen_t addrlen = sizeof(struct sockaddr_storage);
|
||||
|
||||
fd = accept(sock->fd, (struct sockaddr *)&addr, &addrlen);
|
||||
|
||||
if (fd < 0) {
|
||||
if (errno == EINTR) {
|
||||
continue;
|
||||
} else if (errno == EAGAIN || errno == EWOULDBLOCK) {
|
||||
continue;
|
||||
} else {
|
||||
pic_errorf(pic, "%s", strerror(errno));
|
||||
}
|
||||
} else {
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
new_sock = pic_malloc(pic, sizeof(struct pic_socket_t));
|
||||
new_sock->fd = fd;
|
||||
return pic_obj_value(pic_data_alloc(pic, &socket_type, new_sock));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_socket_socket_send(pic_state *pic)
|
||||
{
|
||||
pic_value obj;
|
||||
struct pic_blob *bv;
|
||||
const unsigned char *cursor;
|
||||
int flags = 0;
|
||||
size_t remain, written;
|
||||
struct pic_socket_t *sock;
|
||||
|
||||
pic_get_args(pic, "ob|i", &obj, &bv, &flags);
|
||||
validate_socket_object(pic, obj);
|
||||
|
||||
sock = pic_socket_data_ptr(obj);
|
||||
ensure_socket_is_open(pic, sock);
|
||||
|
||||
cursor = bv->data;
|
||||
remain = bv->len;
|
||||
written = 0;
|
||||
errno = 0;
|
||||
while (remain > 0) {
|
||||
ssize_t len = send(sock->fd, cursor, remain, flags);
|
||||
if (len < 0) {
|
||||
if (errno == EINTR) {
|
||||
continue;
|
||||
} else if (errno == EAGAIN || errno == EWOULDBLOCK) {
|
||||
break;
|
||||
} else {
|
||||
pic_errorf(pic, "%s", strerror(errno));
|
||||
}
|
||||
}
|
||||
cursor += len;
|
||||
remain -= len;
|
||||
written += len;
|
||||
}
|
||||
|
||||
return pic_int_value(written);
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_socket_socket_recv(pic_state *pic)
|
||||
{
|
||||
pic_value obj;
|
||||
struct pic_blob *bv;
|
||||
void *buf;
|
||||
int size;
|
||||
int flags = 0;
|
||||
ssize_t len;
|
||||
struct pic_socket_t *sock;
|
||||
|
||||
pic_get_args(pic, "oi|i", &obj, &size, &flags);
|
||||
validate_socket_object(pic, obj);
|
||||
if (size < 0) {
|
||||
pic_errorf(pic, "size must not be negative");
|
||||
}
|
||||
|
||||
sock = pic_socket_data_ptr(obj);
|
||||
ensure_socket_is_open(pic, sock);
|
||||
|
||||
buf = malloc(size);
|
||||
if (buf == NULL && size > 0) {
|
||||
/* XXX: Is it really OK? */
|
||||
pic_panic(pic, "memory exhausted");
|
||||
}
|
||||
|
||||
errno = 0;
|
||||
do {
|
||||
len = recv(sock->fd, buf, size, flags);
|
||||
} while (len < 0 && (errno == EINTR || errno == EAGAIN || errno == EWOULDBLOCK));
|
||||
|
||||
if (len < 0) {
|
||||
free(buf);
|
||||
pic_errorf(pic, "%s", strerror(errno));
|
||||
}
|
||||
|
||||
bv = pic_make_blob(pic, len);
|
||||
memcpy(bv->data, buf, len);
|
||||
free(buf);
|
||||
|
||||
return pic_obj_value(bv);
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_socket_socket_shutdown(pic_state *pic)
|
||||
{
|
||||
pic_value obj;
|
||||
int how;
|
||||
struct pic_socket_t *sock;
|
||||
|
||||
pic_get_args(pic, "oi", &obj, &how);
|
||||
validate_socket_object(pic, obj);
|
||||
|
||||
sock = pic_socket_data_ptr(obj);
|
||||
if (sock->fd != -1) {
|
||||
shutdown(sock->fd, how);
|
||||
sock->fd = -1;
|
||||
}
|
||||
|
||||
return pic_undef_value();
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_socket_socket_close(pic_state *pic)
|
||||
{
|
||||
pic_value obj;
|
||||
|
||||
pic_get_args(pic, "o", &obj);
|
||||
validate_socket_object(pic, obj);
|
||||
|
||||
socket_close(pic_socket_data_ptr(obj));
|
||||
|
||||
return pic_undef_value();
|
||||
}
|
||||
|
||||
static int
|
||||
xf_socket_read(pic_state PIC_UNUSED(*pic), void *cookie, char *ptr, int size)
|
||||
{
|
||||
struct pic_socket_t *sock;
|
||||
|
||||
sock = (struct pic_socket_t *)cookie;
|
||||
|
||||
return recv(sock->fd, ptr, size, 0);
|
||||
}
|
||||
|
||||
static int
|
||||
xf_socket_write(pic_state PIC_UNUSED(*pic), void *cookie, const char *ptr, int size)
|
||||
{
|
||||
struct pic_socket_t *sock;
|
||||
|
||||
sock = (struct pic_socket_t *)cookie;
|
||||
|
||||
return send(sock->fd, ptr, size, 0);
|
||||
}
|
||||
|
||||
static long
|
||||
xf_socket_seek(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie), long PIC_UNUSED(pos), int PIC_UNUSED(whence))
|
||||
{
|
||||
errno = EBADF;
|
||||
return -1;
|
||||
}
|
||||
|
||||
static int
|
||||
xf_socket_close(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie))
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
|
||||
static struct pic_port *
|
||||
make_socket_port(pic_state *pic, struct pic_socket_t *sock, short dir)
|
||||
{
|
||||
struct pic_port *port;
|
||||
|
||||
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
|
||||
port->file = xfunopen(pic, sock, xf_socket_read, xf_socket_write, xf_socket_seek, xf_socket_close);
|
||||
port->flags = dir | PIC_PORT_BINARY | PIC_PORT_OPEN;
|
||||
return port;
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_socket_socket_input_port(pic_state *pic)
|
||||
{
|
||||
pic_value obj;
|
||||
struct pic_socket_t *sock;
|
||||
|
||||
pic_get_args(pic, "o", &obj);
|
||||
validate_socket_object(pic, obj);
|
||||
|
||||
sock = pic_socket_data_ptr(obj);
|
||||
ensure_socket_is_open(pic, sock);
|
||||
|
||||
return pic_obj_value(make_socket_port(pic, sock, PIC_PORT_IN));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_socket_socket_output_port(pic_state *pic)
|
||||
{
|
||||
pic_value obj;
|
||||
struct pic_socket_t *sock;
|
||||
|
||||
pic_get_args(pic, "o", &obj);
|
||||
validate_socket_object(pic, obj);
|
||||
|
||||
sock = pic_socket_data_ptr(obj);
|
||||
ensure_socket_is_open(pic, sock);
|
||||
|
||||
return pic_obj_value(make_socket_port(pic, sock, PIC_PORT_OUT));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_socket_call_with_socket(pic_state *pic)
|
||||
{
|
||||
pic_value obj, result;
|
||||
struct pic_proc *proc;
|
||||
struct pic_socket_t *sock;
|
||||
|
||||
pic_get_args(pic, "ol", &obj, &proc);
|
||||
validate_socket_object(pic, obj);
|
||||
|
||||
sock = pic_socket_data_ptr(obj);
|
||||
ensure_socket_is_open(pic, sock);
|
||||
|
||||
result = pic_apply1(pic, proc, obj);
|
||||
|
||||
socket_close(sock);
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
void
|
||||
pic_init_socket(pic_state *pic)
|
||||
{
|
||||
pic_deflibrary (pic, "(srfi 106)") {
|
||||
pic_defun_(pic, "socket?", pic_socket_socket_p);
|
||||
pic_defun_(pic, "make-socket", pic_socket_make_socket);
|
||||
pic_defun_(pic, "socket-accept", pic_socket_socket_accept);
|
||||
pic_defun_(pic, "socket-send", pic_socket_socket_send);
|
||||
pic_defun_(pic, "socket-recv", pic_socket_socket_recv);
|
||||
pic_defun_(pic, "socket-shutdown", pic_socket_socket_shutdown);
|
||||
pic_defun_(pic, "socket-close", pic_socket_socket_close);
|
||||
pic_defun_(pic, "socket-input-port", pic_socket_socket_input_port);
|
||||
pic_defun_(pic, "socket-output-port", pic_socket_socket_output_port);
|
||||
pic_defun_(pic, "call-with-socket", pic_socket_call_with_socket);
|
||||
|
||||
#ifdef AF_INET
|
||||
pic_define_(pic, "*af-inet*", pic_int_value(AF_INET));
|
||||
#else
|
||||
pic_define_(pic, "*af-inet*", pic_false_value());
|
||||
#endif
|
||||
#ifdef AF_INET6
|
||||
pic_define_(pic, "*af-inet6*", pic_int_value(AF_INET6));
|
||||
#else
|
||||
pic_define_(pic, "*af-inet6*", pic_false_value());
|
||||
#endif
|
||||
#ifdef AF_UNSPEC
|
||||
pic_define_(pic, "*af-unspec*", pic_int_value(AF_UNSPEC));
|
||||
#else
|
||||
pic_define_(pic, "*af-unspec*", pic_false_value());
|
||||
#endif
|
||||
|
||||
#ifdef SOCK_STREAM
|
||||
pic_define_(pic, "*sock-stream*", pic_int_value(SOCK_STREAM));
|
||||
#else
|
||||
pic_define_(pic, "*sock-stream*", pic_false_value());
|
||||
#endif
|
||||
#ifdef SOCK_DGRAM
|
||||
pic_define_(pic, "*sock-dgram*", pic_int_value(SOCK_DGRAM));
|
||||
#else
|
||||
pic_define_(pic, "*sock-dgram*", pic_false_value());
|
||||
#endif
|
||||
|
||||
#ifdef AI_CANONNAME
|
||||
pic_define_(pic, "*ai-canonname*", pic_int_value(AI_CANONNAME));
|
||||
#else
|
||||
pic_define_(pic, "*ai-canonname*", pic_false_value());
|
||||
#endif
|
||||
#ifdef AI_NUMERICHOST
|
||||
pic_define_(pic, "*ai-numerichost*", pic_int_value(AI_NUMERICHOST));
|
||||
#else
|
||||
pic_define_(pic, "*ai-numerichost*", pic_false_value());
|
||||
#endif
|
||||
/* AI_V4MAPPED and AI_ALL are not supported by *BSDs, even though they are defined in netdb.h. */
|
||||
#if defined(AI_V4MAPPED) && !defined(BSD)
|
||||
pic_define_(pic, "*ai-v4mapped*", pic_int_value(AI_V4MAPPED));
|
||||
#else
|
||||
pic_define_(pic, "*ai-v4mapped*", pic_false_value());
|
||||
#endif
|
||||
#if defined(AI_ALL) && !defined(BSD)
|
||||
pic_define_(pic, "*ai-all*", pic_int_value(AI_ALL));
|
||||
#else
|
||||
pic_define_(pic, "*ai-all*", pic_false_value());
|
||||
#endif
|
||||
#ifdef AI_ADDRCONFIG
|
||||
pic_define_(pic, "*ai-addrconfig*", pic_int_value(AI_ADDRCONFIG));
|
||||
#else
|
||||
pic_define_(pic, "*ai-addrconfig*", pic_false_value());
|
||||
#endif
|
||||
#ifdef AI_PASSIVE
|
||||
pic_define_(pic, "*ai-passive*", pic_int_value(AI_PASSIVE));
|
||||
#else
|
||||
pic_define_(pic, "*ai-passive*", pic_false_value());
|
||||
#endif
|
||||
|
||||
#ifdef IPPROTO_IP
|
||||
pic_define_(pic, "*ipproto-ip*", pic_int_value(IPPROTO_IP));
|
||||
#else
|
||||
pic_define_(pic, "*ipproto-ip*", pic_false_value());
|
||||
#endif
|
||||
#ifdef IPPROTO_TCP
|
||||
pic_define_(pic, "*ipproto-tcp*", pic_int_value(IPPROTO_TCP));
|
||||
#else
|
||||
pic_define_(pic, "*ipproto-tcp*", pic_false_value());
|
||||
#endif
|
||||
#ifdef IPPROTO_UDP
|
||||
pic_define_(pic, "*ipproto-udp*", pic_int_value(IPPROTO_UDP));
|
||||
#else
|
||||
pic_define_(pic, "*ipproto-udp*", pic_false_value());
|
||||
#endif
|
||||
|
||||
#ifdef MSG_PEEK
|
||||
pic_define_(pic, "*msg-peek*", pic_int_value(MSG_PEEK));
|
||||
#else
|
||||
pic_define_(pic, "*msg-peek*", pic_false_value());
|
||||
#endif
|
||||
#ifdef MSG_OOB
|
||||
pic_define_(pic, "*msg-oob*", pic_int_value(MSG_OOB));
|
||||
#else
|
||||
pic_define_(pic, "*msg-oob*", pic_false_value());
|
||||
#endif
|
||||
#ifdef MSG_WAITALL
|
||||
pic_define_(pic, "*msg-waitall*", pic_int_value(MSG_WAITALL));
|
||||
#else
|
||||
pic_define_(pic, "*msg-waitall*", pic_false_value());
|
||||
#endif
|
||||
|
||||
#ifdef SHUT_RD
|
||||
pic_define_(pic, "*shut-rd*", pic_int_value(SHUT_RD));
|
||||
#else
|
||||
pic_define_(pic, "*shut-rd*", pic_false_value());
|
||||
#endif
|
||||
#ifdef SHUT_WR
|
||||
pic_define_(pic, "*shut-wr*", pic_int_value(SHUT_WR));
|
||||
#else
|
||||
pic_define_(pic, "*shut-wr*", pic_false_value());
|
||||
#endif
|
||||
#ifdef SHUT_RDWR
|
||||
pic_define_(pic, "*shut-rdwr*", pic_int_value(SHUT_RDWR));
|
||||
#else
|
||||
pic_define_(pic, "*shut-rdwr*", pic_false_value());
|
||||
#endif
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,168 @@
|
|||
(define-library (srfi 106)
|
||||
(import (scheme base)
|
||||
(srfi 60)
|
||||
(picrin optional))
|
||||
|
||||
; TODO: Define assq-ref anywhere else.
|
||||
(define (assq-ref alist key . opt)
|
||||
(cond
|
||||
((assq key alist) => cdr)
|
||||
(else (if (null? opt) #f (car opt)))))
|
||||
|
||||
(define (socket-merge-flags flag . flags)
|
||||
(if (null? flags)
|
||||
flag
|
||||
(apply socket-merge-flags (logior (or flag 0) (or (car flags) 0))
|
||||
(cdr flags))))
|
||||
|
||||
(define (socket-purge-flags base-flag . flags)
|
||||
(if (null? flags)
|
||||
base-flag
|
||||
(apply socket-purge-flags (logxor (or base-flag 0) (or (car flags) 0))
|
||||
(cdr flags))))
|
||||
|
||||
(define (make-client-socket node service . args)
|
||||
(let-optionals* args ((family *af-inet*)
|
||||
(type *sock-stream*)
|
||||
(flags (socket-merge-flags *ai-v4mapped*
|
||||
*ai-addrconfig*))
|
||||
(protocol *ipproto-ip*))
|
||||
(make-socket node service family type flags protocol)))
|
||||
|
||||
(define (make-server-socket service . args)
|
||||
(let-optionals* args ((family *af-inet*)
|
||||
(type *sock-stream*)
|
||||
(flags *ai-passive*)
|
||||
(protocol *ipproto-ip*))
|
||||
(make-socket #f service family type flags protocol)))
|
||||
|
||||
(define %address-family `((inet . ,*af-inet*)
|
||||
(inet6 . ,*af-inet6*)
|
||||
(unspec . ,*af-unspec*)))
|
||||
|
||||
(define %socket-domain `((stream . ,*sock-stream*)
|
||||
(datagram . ,*sock-dgram*)))
|
||||
|
||||
(define %address-info `((canoname . ,*ai-canonname*)
|
||||
(numerichost . ,*ai-numerichost*)
|
||||
(v4mapped . ,*ai-v4mapped*)
|
||||
(all . ,*ai-all*)
|
||||
(addrconfig . ,*ai-addrconfig*)))
|
||||
|
||||
(define %ip-protocol `((ip . ,*ipproto-ip*)
|
||||
(tcp . ,*ipproto-tcp*)
|
||||
(udp . ,*ipproto-udp*)))
|
||||
|
||||
(define %message-types `((none . 0)
|
||||
(peek . ,*msg-peek*)
|
||||
(oob . ,*msg-oob*)
|
||||
(wait-all . ,*msg-waitall*)))
|
||||
|
||||
(define-syntax address-family
|
||||
(syntax-rules ()
|
||||
((_ name)
|
||||
(assq-ref %address-family 'name))))
|
||||
|
||||
(define-syntax socket-domain
|
||||
(syntax-rules ()
|
||||
((_ name)
|
||||
(assq-ref %socket-domain 'name))))
|
||||
|
||||
(define-syntax address-info
|
||||
(syntax-rules ()
|
||||
((_ names ...)
|
||||
(apply socket-merge-flags
|
||||
(map (lambda (name) (assq-ref %address-info name))
|
||||
'(names ...))))))
|
||||
|
||||
(define-syntax ip-protocol
|
||||
(syntax-rules ()
|
||||
((_ name)
|
||||
(assq-ref %ip-protocol 'name))))
|
||||
|
||||
(define-syntax message-type
|
||||
(syntax-rules ()
|
||||
((_ names ...)
|
||||
(apply socket-merge-flags
|
||||
(map (lambda (name) (assq-ref %message-types name))
|
||||
'(names ...))))))
|
||||
|
||||
(define (%shutdown-method names)
|
||||
(define (state->method state)
|
||||
(case state
|
||||
((read) *shut-rd*)
|
||||
((write) *shut-wr*)
|
||||
((read-write) *shut-rdwr*)
|
||||
(else #f)))
|
||||
(let loop ((names names)
|
||||
(state 'none))
|
||||
(cond
|
||||
((null? names) (state->method state))
|
||||
((eq? (car names) 'read)
|
||||
(loop (cdr names)
|
||||
(cond
|
||||
((eq? state 'none) 'read)
|
||||
((eq? state 'write) 'read-write)
|
||||
(else state))))
|
||||
((eq? (car names) 'write)
|
||||
(loop (cdr names)
|
||||
(cond
|
||||
((eq? state 'none) 'write)
|
||||
((eq? state 'read) 'read-write)
|
||||
(else state))))
|
||||
(else (loop (cdr names) 'other)))))
|
||||
|
||||
(define-syntax shutdown-method
|
||||
(syntax-rules ()
|
||||
((_ names ...)
|
||||
(%shutdown-method '(names ...)))))
|
||||
|
||||
;; Constructors and predicate
|
||||
(export make-client-socket
|
||||
make-server-socket
|
||||
socket?)
|
||||
|
||||
;; Socket operations
|
||||
(export socket-accept
|
||||
socket-send
|
||||
socket-recv
|
||||
socket-shutdown
|
||||
socket-close)
|
||||
|
||||
;; Port conversion
|
||||
(export socket-input-port
|
||||
socket-output-port)
|
||||
|
||||
;; Control feature
|
||||
(export call-with-socket)
|
||||
|
||||
;; Flag operations
|
||||
(export address-family
|
||||
socket-domain
|
||||
address-info
|
||||
ip-protocol
|
||||
message-type
|
||||
shutdown-method
|
||||
socket-merge-flags
|
||||
socket-purge-flags)
|
||||
|
||||
;; Constant values
|
||||
(export *af-inet*
|
||||
*af-inet6*
|
||||
*af-unspec*)
|
||||
(export *sock-stream*
|
||||
*sock-dgram*)
|
||||
(export *ai-canonname*
|
||||
*ai-numerichost*
|
||||
*ai-v4mapped*
|
||||
*ai-all*
|
||||
*ai-addrconfig*)
|
||||
(export *ipproto-ip*
|
||||
*ipproto-tcp*
|
||||
*ipproto-udp*)
|
||||
(export *msg-peek*
|
||||
*msg-oob*
|
||||
*msg-waitall*)
|
||||
(export *shut-rd*
|
||||
*shut-wr*
|
||||
*shut-rdwr*))
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
(import (scheme base)
|
||||
(srfi 106)
|
||||
(picrin test))
|
||||
|
||||
; The number 9600 has no meaning. I just borrowed from Rust.
|
||||
(define *test-port* 9600)
|
||||
(define (next-test-port)
|
||||
(set! *test-port* (+ *test-port* 1))
|
||||
(number->string *test-port*))
|
||||
|
||||
(test #f (socket? '()))
|
||||
(let* ((port (next-test-port))
|
||||
(server (make-server-socket port))
|
||||
(client (make-client-socket "127.0.0.1" port)))
|
||||
(test #t (socket? server))
|
||||
(test #t (socket? client)))
|
||||
|
||||
(let* ((port (next-test-port))
|
||||
(server (make-server-socket port))
|
||||
(client (make-client-socket "127.0.0.1" port)))
|
||||
(test #t (socket? (socket-accept server))))
|
||||
|
||||
(let* ((port (next-test-port))
|
||||
(server (make-server-socket port))
|
||||
(client (make-client-socket "127.0.0.1" port))
|
||||
(conn (socket-accept server)))
|
||||
(test 5 (socket-send conn (string->utf8 "hello")))
|
||||
(test "hello" (utf8->string (socket-recv client 5))))
|
||||
|
||||
(let* ((port (next-test-port))
|
||||
(sock (make-server-socket port)))
|
||||
(test #t (port? (socket-input-port sock)))
|
||||
(test #t (port? (socket-output-port sock))))
|
||||
|
||||
(test *ai-canonname* (socket-merge-flags *ai-canonname*))
|
||||
(test *ai-canonname* (socket-merge-flags *ai-canonname* *ai-canonname*))
|
||||
(test *ai-canonname* (socket-purge-flags *ai-canonname*))
|
||||
(test *ai-canonname* (socket-purge-flags (socket-merge-flags *ai-canonname* *ai-all*)
|
||||
*ai-all*))
|
||||
(test *ai-canonname* (socket-purge-flags (socket-merge-flags *ai-all* *ai-canonname*)
|
||||
*ai-all*))
|
||||
|
||||
(test *af-inet* (address-family inet))
|
||||
(test *af-inet6* (address-family inet6))
|
||||
(test *af-unspec* (address-family unspec))
|
||||
|
||||
(test *sock-stream* (socket-domain stream))
|
||||
(test *sock-dgram* (socket-domain datagram))
|
||||
|
||||
(test *ai-canonname* (address-info canoname))
|
||||
(test *ai-numerichost* (address-info numerichost))
|
||||
(test *ai-v4mapped* (address-info v4mapped))
|
||||
(test *ai-all* (address-info all))
|
||||
(test *ai-addrconfig* (address-info addrconfig))
|
||||
(test (socket-merge-flags *ai-v4mapped* *ai-addrconfig*)
|
||||
(address-info v4mapped addrconfig))
|
||||
|
||||
(test *ipproto-ip* (ip-protocol ip))
|
||||
(test *ipproto-tcp* (ip-protocol tcp))
|
||||
(test *ipproto-udp* (ip-protocol udp))
|
||||
|
||||
(test 0 (message-type none))
|
||||
(test *msg-peek* (message-type peek))
|
||||
(test *msg-oob* (message-type oob))
|
||||
(test *msg-waitall* (message-type wait-all))
|
||||
(test (socket-merge-flags *msg-oob* *msg-waitall*)
|
||||
(message-type oob wait-all))
|
||||
|
||||
(test *shut-rd* (shutdown-method read))
|
||||
(test *shut-wr* (shutdown-method write))
|
||||
(test *shut-rdwr* (shutdown-method read write))
|
||||
(test *shut-rdwr* (shutdown-method write read))
|
||||
|
|
@ -0,0 +1 @@
|
|||
CONTRIB_LIBS += $(wildcard contrib/50.class/piclib/picrin/*.scm)
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
CONTRIB_LIBS += $(wildcard contrib/50.for/piclib/*.scm)
|
||||
CONTRIB_TESTS += test-for
|
||||
|
||||
test-for: bin/picrin
|
||||
for test in `ls contrib/50.for/t/*.scm`; do \
|
||||
bin/picrin "$$test"; \
|
||||
done
|
||||
|
|
@ -1 +0,0 @@
|
|||
CONTRIB_LIBS += $(wildcard contrib/50.protocol/piclib/picrin/*.scm)
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
CONTRIB_LIBS += contrib/60.repl/repl.scm
|
||||
CONTRIB_SRCS += contrib/60.repl/repl.c
|
||||
CONTRIB_INITS += repl
|
||||
|
|
@ -2,7 +2,8 @@
|
|||
(import (scheme base)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme eval))
|
||||
(scheme eval)
|
||||
(picrin base))
|
||||
|
||||
(cond-expand
|
||||
((library (picrin readline))
|
||||
|
|
@ -18,21 +19,24 @@
|
|||
(define (add-history str)
|
||||
#f))))
|
||||
|
||||
(eval
|
||||
'(import (scheme base)
|
||||
(scheme load)
|
||||
(scheme process-context)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme cxr)
|
||||
(scheme lazy)
|
||||
(scheme time)
|
||||
(picrin macro)
|
||||
(picrin array)
|
||||
(picrin library))
|
||||
'(picrin user))
|
||||
(define user-env (library-environment (find-library '(picrin user))))
|
||||
|
||||
(begin
|
||||
(current-library (find-library '(picrin user)))
|
||||
(eval
|
||||
'(import (scheme base)
|
||||
(scheme load)
|
||||
(scheme process-context)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme inexact)
|
||||
(scheme cxr)
|
||||
(scheme lazy)
|
||||
(scheme time)
|
||||
(picrin macro))
|
||||
user-env)
|
||||
(current-library (find-library '(picrin repl))))
|
||||
|
||||
(define (repl)
|
||||
(let loop ((buf ""))
|
||||
|
|
@ -62,7 +66,7 @@
|
|||
(lambda (port)
|
||||
(let next ((expr (read port)))
|
||||
(unless (eof-object? expr)
|
||||
(write (eval expr '(picrin user)))
|
||||
(write (eval expr user-env))
|
||||
(newline)
|
||||
(set! str "")
|
||||
(next (read port))))))))))
|
||||
|
|
@ -5,6 +5,7 @@
|
|||
(scheme process-context)
|
||||
(scheme load)
|
||||
(scheme eval)
|
||||
(picrin base)
|
||||
(picrin repl))
|
||||
|
||||
(define (print-help)
|
||||
|
|
@ -40,7 +41,7 @@
|
|||
(lambda (in)
|
||||
(let loop ((expr (read in)))
|
||||
(unless (eof-object? expr)
|
||||
(eval expr '(picrin user))
|
||||
(eval expr (library-environment (find-library '(picrin user))))
|
||||
(loop (read in)))))))
|
||||
|
||||
(define (main)
|
||||
|
|
@ -0,0 +1 @@
|
|||
CONTRIB_LIBS += contrib/70.main/main.scm
|
||||
|
|
@ -0,0 +1 @@
|
|||
CONTRIB_LIBS += $(wildcard contrib/80.protocol/piclib/picrin/*.scm)
|
||||
|
|
@ -8,12 +8,12 @@ Extension Library
|
|||
|
||||
If you want to create a contribution library with C, the only thing you need to do is make a directory under contrib/. Below is a sample code of extension library.
|
||||
|
||||
* contrib/add/CMakeLists.txt
|
||||
* contrib/add/nitro.mk
|
||||
|
||||
.. sourcecode:: cmake
|
||||
|
||||
list(APPEND PICRIN_CONTRIB_INITS add)
|
||||
list(APPEND PICRIN_CONTRIB_SOURCES ${PROJECT_SOURCE_DIR}/contrib/add/add.c)
|
||||
CONTRIB_INITS += add
|
||||
CONTRIB_SRCS += contrib/add/add.c
|
||||
|
||||
* contrib/add/add.c
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,20 @@
|
|||
void abort()
|
||||
{
|
||||
while (1);
|
||||
}
|
||||
|
||||
typedef char jmp_buf[1];
|
||||
|
||||
int setjmp(jmp_buf buf)
|
||||
{
|
||||
(void)buf;
|
||||
return 0;
|
||||
}
|
||||
|
||||
void longjmp(jmp_buf buf, int r)
|
||||
{
|
||||
(void)buf;
|
||||
(void)r;
|
||||
while (1);
|
||||
}
|
||||
|
||||
|
|
@ -41,7 +41,9 @@ pic_load_piclib(pic_state *pic)
|
|||
EOL
|
||||
|
||||
foreach my $file (@ARGV) {
|
||||
print " pic_try {\n";
|
||||
print <<EOL;
|
||||
pic_try {
|
||||
EOL
|
||||
my $var = &escape_v($file);
|
||||
my $basename = basename($file);
|
||||
my $dirname = basename(dirname($file));
|
||||
|
|
@ -50,9 +52,8 @@ foreach my $file (@ARGV) {
|
|||
}
|
||||
pic_catch {
|
||||
/* error! */
|
||||
fputs("fatal error: failure in loading $dirname/$basename\\n", stderr);
|
||||
fputs(pic_errmsg(pic), stderr);
|
||||
abort();
|
||||
xfputs(pic, "fatal error: failure in loading $dirname/$basename\\n", xstderr);
|
||||
pic_raise(pic, pic->err);
|
||||
}
|
||||
EOL
|
||||
}
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ main(int argc, char *argv[])
|
|||
pic_state *pic;
|
||||
pic_value expr;
|
||||
|
||||
pic = pic_open(argc, argv, NULL);
|
||||
pic = pic_open(pic_default_allocf, NULL);
|
||||
|
||||
while (1) {
|
||||
printf("> ");
|
||||
|
|
@ -61,7 +61,7 @@ pic_value factorial(pic_state *pic) {
|
|||
int
|
||||
main(int argc, char *argv[])
|
||||
{
|
||||
pic_state *pic = pic_open(argc, argv, NULL);
|
||||
pic_state *pic = pic_open(pic_default_allocf, NULL);
|
||||
|
||||
pic_defun(pic, "fact", factorial); /* define fact procedure */
|
||||
|
||||
|
|
|
|||
|
|
@ -4,89 +4,84 @@
|
|||
|
||||
#include "picrin.h"
|
||||
|
||||
static bool
|
||||
str_equal_p(pic_state *pic, struct pic_string *str1, struct pic_string *str2)
|
||||
{
|
||||
return pic_str_cmp(pic, str1, str2) == 0;
|
||||
}
|
||||
KHASH_DECLARE(m, void *, int)
|
||||
KHASH_DEFINE2(m, void *, int, 0, kh_ptr_hash_func, kh_ptr_hash_equal)
|
||||
|
||||
static bool
|
||||
blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2)
|
||||
{
|
||||
size_t i;
|
||||
|
||||
if (blob1->len != blob2->len) {
|
||||
return false;
|
||||
}
|
||||
for (i = 0; i < blob1->len; ++i) {
|
||||
if (blob1->data[i] != blob2->data[i])
|
||||
return false;
|
||||
}
|
||||
return true;
|
||||
}
|
||||
|
||||
static bool
|
||||
internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *xh, bool xh_initted_p)
|
||||
internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, khash_t(m) *h)
|
||||
{
|
||||
pic_value local = pic_nil_value();
|
||||
size_t c;
|
||||
size_t c = 0;
|
||||
|
||||
if (depth > 10) {
|
||||
if (depth > 200) {
|
||||
pic_errorf(pic, "Stack overflow in equal\n");
|
||||
}
|
||||
if (pic_pair_p(x) || pic_vec_p(x)) {
|
||||
if (! xh_initted_p) {
|
||||
xh_init_ptr(xh, 0);
|
||||
xh_initted_p = true;
|
||||
}
|
||||
|
||||
if (xh_get_ptr(xh, pic_obj_ptr(x)) != NULL) {
|
||||
int ret;
|
||||
kh_put(m, h, pic_obj_ptr(x), &ret);
|
||||
if (ret != 0) {
|
||||
return true; /* `x' was seen already. */
|
||||
} else {
|
||||
xh_put_ptr(xh, pic_obj_ptr(x), NULL);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
c = 0;
|
||||
|
||||
LOOP:
|
||||
|
||||
if (pic_eqv_p(x, y))
|
||||
if (pic_eqv_p(x, y)) {
|
||||
return true;
|
||||
|
||||
if (pic_type(x) != pic_type(y))
|
||||
}
|
||||
if (pic_type(x) != pic_type(y)) {
|
||||
return false;
|
||||
}
|
||||
|
||||
switch (pic_type(x)) {
|
||||
case PIC_TT_STRING:
|
||||
return str_equal_p(pic, pic_str_ptr(x), pic_str_ptr(y));
|
||||
case PIC_TT_ID: {
|
||||
struct pic_id *id1, *id2;
|
||||
|
||||
case PIC_TT_BLOB:
|
||||
return blob_equal_p(pic_blob_ptr(x), pic_blob_ptr(y));
|
||||
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);
|
||||
}
|
||||
case PIC_TT_STRING: {
|
||||
return pic_str_cmp(pic, pic_str_ptr(x), pic_str_ptr(y)) == 0;
|
||||
}
|
||||
case PIC_TT_BLOB: {
|
||||
pic_blob *blob1, *blob2;
|
||||
size_t i;
|
||||
|
||||
blob1 = pic_blob_ptr(x);
|
||||
blob2 = pic_blob_ptr(y);
|
||||
|
||||
if (blob1->len != blob2->len) {
|
||||
return false;
|
||||
}
|
||||
for (i = 0; i < blob1->len; ++i) {
|
||||
if (blob1->data[i] != blob2->data[i])
|
||||
return false;
|
||||
}
|
||||
return true;
|
||||
}
|
||||
case PIC_TT_PAIR: {
|
||||
if (! internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, h))
|
||||
return false;
|
||||
|
||||
/* Floyd's cycle-finding algorithm */
|
||||
if (pic_nil_p(local)) {
|
||||
local = x;
|
||||
}
|
||||
if (internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, xh, xh_initted_p)) {
|
||||
x = pic_cdr(pic, x);
|
||||
y = pic_cdr(pic, y);
|
||||
|
||||
c++;
|
||||
|
||||
if (c == 2) {
|
||||
c = 0;
|
||||
local = pic_cdr(pic, local);
|
||||
if (pic_eq_p(local, x)) {
|
||||
return true;
|
||||
}
|
||||
x = pic_cdr(pic, x);
|
||||
y = pic_cdr(pic, y);
|
||||
c++;
|
||||
if (c == 2) {
|
||||
c = 0;
|
||||
local = pic_cdr(pic, local);
|
||||
if (pic_eq_p(local, x)) {
|
||||
return true;
|
||||
}
|
||||
goto LOOP;
|
||||
} else {
|
||||
return false;
|
||||
}
|
||||
goto LOOP; /* tail-call optimization */
|
||||
}
|
||||
case PIC_TT_VECTOR: {
|
||||
size_t i;
|
||||
|
|
@ -99,7 +94,7 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *
|
|||
return false;
|
||||
}
|
||||
for (i = 0; i < u->len; ++i) {
|
||||
if (! internal_equal_p(pic, u->data[i], v->data[i], depth + 1, xh, xh_initted_p))
|
||||
if (! internal_equal_p(pic, u->data[i], v->data[i], depth + 1, h))
|
||||
return false;
|
||||
}
|
||||
return true;
|
||||
|
|
@ -112,9 +107,11 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *
|
|||
bool
|
||||
pic_equal_p(pic_state *pic, pic_value x, pic_value y)
|
||||
{
|
||||
xhash ht;
|
||||
khash_t(m) h;
|
||||
|
||||
return internal_equal_p(pic, x, y, 0, &ht, false);
|
||||
kh_init(m, &h);
|
||||
|
||||
return internal_equal_p(pic, x, y, 0, &h);
|
||||
}
|
||||
|
||||
static pic_value
|
||||
|
|
@ -195,7 +192,7 @@ pic_init_bool(pic_state *pic)
|
|||
pic_defun(pic, "eqv?", pic_bool_eqv_p);
|
||||
pic_defun(pic, "equal?", pic_bool_equal_p);
|
||||
|
||||
pic_defun_vm(pic, "not", pic->rNOT, pic_bool_not);
|
||||
pic_defun_vm(pic, "not", pic->uNOT, pic_bool_not);
|
||||
|
||||
pic_defun(pic, "boolean?", pic_bool_boolean_p);
|
||||
pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p);
|
||||
|
|
|
|||
1350
extlib/benz/boot.c
1350
extlib/benz/boot.c
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
|
@ -31,7 +31,7 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st
|
|||
}
|
||||
|
||||
here = pic->cp;
|
||||
pic->cp = pic_malloc(pic, sizeof(pic_checkpoint));
|
||||
pic->cp = (pic_checkpoint *)pic_obj_alloc(pic, sizeof(pic_checkpoint), PIC_TT_CP);
|
||||
pic->cp->prev = here;
|
||||
pic->cp->depth = here->depth + 1;
|
||||
pic->cp->in = in;
|
||||
|
|
@ -51,9 +51,6 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st
|
|||
void
|
||||
pic_save_point(pic_state *pic, struct pic_cont *cont)
|
||||
{
|
||||
cont->jmp.prev = pic->jmp;
|
||||
pic->jmp = &cont->jmp;
|
||||
|
||||
/* save runtime context */
|
||||
cont->cp = pic->cp;
|
||||
cont->sp_offset = pic->sp - pic->stbase;
|
||||
|
|
@ -62,24 +59,16 @@ pic_save_point(pic_state *pic, struct pic_cont *cont)
|
|||
cont->arena_idx = pic->arena_idx;
|
||||
cont->ip = pic->ip;
|
||||
cont->ptable = pic->ptable;
|
||||
|
||||
cont->prev = pic->cc;
|
||||
cont->results = pic_undef_value();
|
||||
cont->id = pic->ccnt++;
|
||||
|
||||
pic->cc = cont;
|
||||
}
|
||||
|
||||
void
|
||||
pic_load_point(pic_state *pic, struct pic_cont *cont)
|
||||
{
|
||||
pic_jmpbuf *jmp;
|
||||
|
||||
for (jmp = pic->jmp; jmp != NULL; jmp = jmp->prev) {
|
||||
if (jmp == &cont->jmp) {
|
||||
break;
|
||||
}
|
||||
}
|
||||
if (jmp == NULL) {
|
||||
pic_errorf(pic, "calling dead escape continuation");
|
||||
}
|
||||
|
||||
pic_wind(pic, pic->cp, cont->cp);
|
||||
|
||||
/* load runtime context */
|
||||
|
|
@ -95,18 +84,32 @@ 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);
|
||||
size_t argc;
|
||||
pic_value *argv;
|
||||
struct pic_data *e;
|
||||
int id;
|
||||
struct pic_cont *cc, *cont;
|
||||
|
||||
pic_get_args(pic, "*", &argc, &argv);
|
||||
|
||||
e = pic_data_ptr(pic_proc_env_ref(pic, pic_get_proc(pic), "escape"));
|
||||
((struct pic_cont *)e->data)->results = pic_list_by_array(pic, argc, argv);
|
||||
id = pic_int(pic_proc_env_ref(pic, self, "id"));
|
||||
|
||||
pic_load_point(pic, e->data);
|
||||
/* check if continuation is alive */
|
||||
for (cc = pic->cc; cc != NULL; cc = cc->prev) {
|
||||
if (cc->id == id) {
|
||||
break;
|
||||
}
|
||||
}
|
||||
if (cc == NULL) {
|
||||
pic_errorf(pic, "calling dead escape continuation");
|
||||
}
|
||||
|
||||
PIC_LONGJMP(pic, ((struct pic_cont *)e->data)->jmp.buf, 1);
|
||||
cont = pic_data_ptr(pic_proc_env_ref(pic, self, "escape"))->data;
|
||||
cont->results = pic_list_by_array(pic, argc, argv);
|
||||
|
||||
pic_load_point(pic, cont);
|
||||
|
||||
PIC_LONGJMP(pic, cont->jmp, 1);
|
||||
|
||||
PIC_UNREACHABLE();
|
||||
}
|
||||
|
|
@ -114,16 +117,17 @@ cont_call(pic_state *pic)
|
|||
struct pic_proc *
|
||||
pic_make_cont(pic_state *pic, struct pic_cont *cont)
|
||||
{
|
||||
static const pic_data_type cont_type = { "cont", pic_free, NULL };
|
||||
static const pic_data_type cont_type = { "cont", NULL, NULL };
|
||||
struct pic_proc *c;
|
||||
struct pic_data *e;
|
||||
|
||||
c = pic_make_proc(pic, cont_call, "<cont-procedure>");
|
||||
c = pic_make_proc(pic, cont_call);
|
||||
|
||||
e = pic_data_alloc(pic, &cont_type, cont);
|
||||
|
||||
/* save the escape continuation in proc */
|
||||
pic_proc_env_set(pic, c, "escape", pic_obj_value(e));
|
||||
pic_proc_env_set(pic, c, "id", pic_int_value(cont->id));
|
||||
|
||||
return c;
|
||||
}
|
||||
|
|
@ -131,21 +135,21 @@ pic_make_cont(pic_state *pic, struct pic_cont *cont)
|
|||
pic_value
|
||||
pic_callcc(pic_state *pic, struct pic_proc *proc)
|
||||
{
|
||||
struct pic_cont *cont = pic_malloc(pic, sizeof(struct pic_cont));
|
||||
struct pic_cont cont;
|
||||
|
||||
pic_save_point(pic, cont);
|
||||
pic_save_point(pic, &cont);
|
||||
|
||||
if (PIC_SETJMP(pic, cont->jmp.buf)) {
|
||||
pic->jmp = pic->jmp->prev;
|
||||
if (PIC_SETJMP(pic, cont.jmp)) {
|
||||
pic->cc = pic->cc->prev;
|
||||
|
||||
return pic_values_by_list(pic, cont->results);
|
||||
return pic_values_by_list(pic, cont.results);
|
||||
}
|
||||
else {
|
||||
pic_value val;
|
||||
|
||||
val = pic_apply1(pic, proc, pic_obj_value(pic_make_cont(pic, cont)));
|
||||
val = pic_apply1(pic, proc, pic_obj_value(pic_make_cont(pic, &cont)));
|
||||
|
||||
pic->jmp = pic->jmp->prev;
|
||||
pic->cc = pic->cc->prev;
|
||||
|
||||
return val;
|
||||
}
|
||||
|
|
@ -288,6 +292,6 @@ pic_init_cont(pic_state *pic)
|
|||
pic_defun(pic, "call/cc", pic_cont_callcc);
|
||||
pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind);
|
||||
|
||||
pic_defun_vm(pic, "values", pic->rVALUES, pic_cont_values);
|
||||
pic_defun_vm(pic, "call-with-values", pic->rCALL_WITH_VALUES, pic_cont_call_with_values);
|
||||
pic_defun_vm(pic, "values", pic->uVALUES, pic_cont_values);
|
||||
pic_defun_vm(pic, "call-with-values", pic->uCALL_WITH_VALUES, pic_cont_call_with_values);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -4,11 +4,12 @@ struct pic_data *
|
|||
pic_data_alloc(pic_state *pic, const pic_data_type *type, void *userdata)
|
||||
{
|
||||
struct pic_data *data;
|
||||
struct pic_dict *storage = pic_make_dict(pic);
|
||||
|
||||
data = (struct pic_data *)pic_obj_alloc(pic, sizeof(struct pic_data), PIC_TT_DATA);
|
||||
data->type = type;
|
||||
data->data = userdata;
|
||||
xh_init_str(&data->storage, sizeof(pic_value));
|
||||
data->storage = storage;
|
||||
|
||||
return data;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ pic_get_backtrace(pic_state *pic)
|
|||
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, pic_symbol_name(pic, pic_proc_name(proc))));
|
||||
trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, "(anonymous lambda)"));
|
||||
|
||||
if (pic_proc_func_p(proc)) {
|
||||
trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (native function)\n"));
|
||||
|
|
@ -38,22 +38,26 @@ pic_print_backtrace(pic_state *pic, xFILE *file)
|
|||
assert(! pic_invalid_p(pic->err));
|
||||
|
||||
if (! pic_error_p(pic->err)) {
|
||||
xfprintf(file, "raise: ");
|
||||
xfprintf(pic, file, "raise: ");
|
||||
pic_fwrite(pic, pic->err, file);
|
||||
} else {
|
||||
struct pic_error *e;
|
||||
pic_value elem, it;
|
||||
|
||||
e = pic_error_ptr(pic->err);
|
||||
if (e->type != pic_intern_cstr(pic, "")) {
|
||||
pic_fwrite(pic, pic_obj_value(e->type), file);
|
||||
xfprintf(file, " ");
|
||||
xfprintf(pic, file, " ");
|
||||
}
|
||||
xfprintf(file, "error: ");
|
||||
xfprintf(pic, file, "error: ");
|
||||
pic_fwrite(pic, pic_obj_value(e->msg), file);
|
||||
xfprintf(file, "\n");
|
||||
|
||||
/* TODO: print error irritants */
|
||||
pic_for_each (elem, e->irrs, it) { /* print error irritants */
|
||||
xfprintf(pic, file, " ");
|
||||
pic_fwrite(pic, elem, file);
|
||||
}
|
||||
xfprintf(pic, file, "\n");
|
||||
|
||||
xfputs(pic_str_cstr(pic, e->stack), file);
|
||||
xfputs(pic, pic_str_cstr(pic, e->stack), file);
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -4,13 +4,15 @@
|
|||
|
||||
#include "picrin.h"
|
||||
|
||||
KHASH_DEFINE(dict, pic_sym *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal)
|
||||
|
||||
struct pic_dict *
|
||||
pic_make_dict(pic_state *pic)
|
||||
{
|
||||
struct pic_dict *dict;
|
||||
|
||||
dict = (struct pic_dict *)pic_obj_alloc(pic, sizeof(struct pic_dict), PIC_TT_DICT);
|
||||
xh_init_ptr(&dict->hash, sizeof(pic_value));
|
||||
kh_init(dict, &dict->hash);
|
||||
|
||||
return dict;
|
||||
}
|
||||
|
|
@ -18,41 +20,50 @@ pic_make_dict(pic_state *pic)
|
|||
pic_value
|
||||
pic_dict_ref(pic_state *pic, struct pic_dict *dict, pic_sym *key)
|
||||
{
|
||||
xh_entry *e;
|
||||
khash_t(dict) *h = &dict->hash;
|
||||
khiter_t it;
|
||||
|
||||
e = xh_get_ptr(&dict->hash, key);
|
||||
if (! e) {
|
||||
it = kh_get(dict, h, key);
|
||||
if (it == kh_end(h)) {
|
||||
pic_errorf(pic, "element not found for a key: ~s", pic_obj_value(key));
|
||||
}
|
||||
return xh_val(e, pic_value);
|
||||
return kh_val(h, it);
|
||||
}
|
||||
|
||||
void
|
||||
pic_dict_set(pic_state PIC_UNUSED(*pic), struct pic_dict *dict, pic_sym *key, pic_value val)
|
||||
{
|
||||
xh_put_ptr(&dict->hash, key, &val);
|
||||
khash_t(dict) *h = &dict->hash;
|
||||
int ret;
|
||||
khiter_t it;
|
||||
|
||||
it = kh_put(dict, h, key, &ret);
|
||||
kh_val(h, it) = val;
|
||||
}
|
||||
|
||||
size_t
|
||||
pic_dict_size(pic_state PIC_UNUSED(*pic), struct pic_dict *dict)
|
||||
{
|
||||
return dict->hash.count;
|
||||
return kh_size(&dict->hash);
|
||||
}
|
||||
|
||||
bool
|
||||
pic_dict_has(pic_state PIC_UNUSED(*pic), struct pic_dict *dict, pic_sym *key)
|
||||
{
|
||||
return xh_get_ptr(&dict->hash, key) != NULL;
|
||||
return kh_get(dict, &dict->hash, key) != kh_end(&dict->hash);
|
||||
}
|
||||
|
||||
void
|
||||
pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_sym *key)
|
||||
{
|
||||
if (xh_get_ptr(&dict->hash, key) == NULL) {
|
||||
khash_t(dict) *h = &dict->hash;
|
||||
khiter_t it;
|
||||
|
||||
it = kh_get(dict, h, key);
|
||||
if (it == kh_end(h)) {
|
||||
pic_errorf(pic, "no slot named ~s found in dictionary", pic_obj_value(key));
|
||||
}
|
||||
|
||||
xh_del_ptr(&dict->hash, key);
|
||||
kh_del(dict, h, it);
|
||||
}
|
||||
|
||||
static pic_value
|
||||
|
|
@ -146,43 +157,41 @@ pic_dict_dictionary_map(pic_state *pic)
|
|||
struct pic_proc *proc;
|
||||
size_t argc, i;
|
||||
pic_value *args;
|
||||
pic_value arg, ret;
|
||||
xh_entry **it;
|
||||
pic_value arg_list, ret = pic_nil_value();
|
||||
|
||||
pic_get_args(pic, "l*", &proc, &argc, &args);
|
||||
|
||||
it = pic_malloc(pic, argc * sizeof(xh_entry));
|
||||
for (i = 0; i < argc; ++i) {
|
||||
if (! pic_dict_p(args[i])) {
|
||||
pic_free(pic, it);
|
||||
pic_errorf(pic, "expected dict, but got %s", pic_type_repr(pic_type(args[i])));
|
||||
}
|
||||
it[i] = xh_begin(&pic_dict_ptr(args[i])->hash);
|
||||
}
|
||||
if (argc != 0) {
|
||||
khiter_t it[argc];
|
||||
khash_t(dict) *kh[argc];
|
||||
|
||||
for (i = 0; i < argc; ++i) {
|
||||
if (! pic_dict_p(args[i])) {
|
||||
pic_errorf(pic, "expected dict, but got %s", pic_type_repr(pic_type(args[i])));
|
||||
}
|
||||
kh[i] = &pic_dict_ptr(args[i])->hash;
|
||||
it[i] = kh_begin(kh[i]);
|
||||
}
|
||||
|
||||
pic_try {
|
||||
ret = pic_nil_value();
|
||||
do {
|
||||
arg = pic_nil_value();
|
||||
arg_list = pic_nil_value();
|
||||
for (i = 0; i < argc; ++i) {
|
||||
if (it[i] == NULL) {
|
||||
while (it[i] != kh_end(kh[i])) { /* find next available */
|
||||
if (kh_exist(kh[i], it[i]))
|
||||
break;
|
||||
it[i]++;
|
||||
}
|
||||
if (it[i] == kh_end(kh[i])) {
|
||||
break;
|
||||
}
|
||||
pic_push(pic, pic_obj_value(xh_key(it[i], pic_sym *)), arg);
|
||||
it[i] = xh_next(it[i]);
|
||||
pic_push(pic, pic_obj_value(kh_key(kh[i], it[i]++)), arg_list);
|
||||
}
|
||||
if (i != argc) {
|
||||
break;
|
||||
}
|
||||
pic_push(pic, pic_apply(pic, proc, pic_reverse(pic, arg)), ret);
|
||||
pic_push(pic, pic_apply(pic, proc, pic_reverse(pic, arg_list)), ret);
|
||||
} while (1);
|
||||
}
|
||||
pic_catch {
|
||||
pic_free(pic, it);
|
||||
pic_raise(pic, pic->err);
|
||||
}
|
||||
|
||||
pic_free(pic, it);
|
||||
|
||||
return pic_reverse(pic, ret);
|
||||
}
|
||||
|
|
@ -193,42 +202,41 @@ pic_dict_dictionary_for_each(pic_state *pic)
|
|||
struct pic_proc *proc;
|
||||
size_t argc, i;
|
||||
pic_value *args;
|
||||
pic_value arg;
|
||||
xh_entry **it;
|
||||
pic_value arg_list;
|
||||
|
||||
pic_get_args(pic, "l*", &proc, &argc, &args);
|
||||
|
||||
it = pic_malloc(pic, argc * sizeof(xh_entry));
|
||||
for (i = 0; i < argc; ++i) {
|
||||
if (! pic_dict_p(args[i])) {
|
||||
pic_free(pic, it);
|
||||
pic_errorf(pic, "expected dict, but got %s", pic_type_repr(pic_type(args[i])));
|
||||
}
|
||||
it[i] = xh_begin(&pic_dict_ptr(args[i])->hash);
|
||||
}
|
||||
if (argc != 0) {
|
||||
khiter_t it[argc];
|
||||
khash_t(dict) *kh[argc];
|
||||
|
||||
for (i = 0; i < argc; ++i) {
|
||||
if (! pic_dict_p(args[i])) {
|
||||
pic_errorf(pic, "expected dict, but got %s", pic_type_repr(pic_type(args[i])));
|
||||
}
|
||||
kh[i] = &pic_dict_ptr(args[i])->hash;
|
||||
it[i] = kh_begin(kh[i]);
|
||||
}
|
||||
|
||||
pic_try {
|
||||
do {
|
||||
arg = pic_nil_value();
|
||||
arg_list = pic_nil_value();
|
||||
for (i = 0; i < argc; ++i) {
|
||||
if (it[i] == NULL) {
|
||||
while (it[i] != kh_end(kh[i])) { /* find next available */
|
||||
if (kh_exist(kh[i], it[i]))
|
||||
break;
|
||||
it[i]++;
|
||||
}
|
||||
if (it[i] == kh_end(kh[i])) {
|
||||
break;
|
||||
}
|
||||
pic_push(pic, pic_obj_value(xh_key(it[i], pic_sym *)), arg);
|
||||
it[i] = xh_next(it[i]);
|
||||
pic_push(pic, pic_obj_value(kh_key(kh[i], it[i]++)), arg_list);
|
||||
}
|
||||
if (i != argc) {
|
||||
break;
|
||||
}
|
||||
pic_void(pic_apply(pic, proc, pic_reverse(pic, arg)));
|
||||
pic_void(pic_apply(pic, proc, pic_reverse(pic, arg_list)));
|
||||
} while (1);
|
||||
}
|
||||
pic_catch {
|
||||
pic_free(pic, it);
|
||||
pic_raise(pic, pic->err);
|
||||
}
|
||||
|
||||
pic_free(pic, it);
|
||||
|
||||
return pic_undef_value();
|
||||
}
|
||||
|
|
@ -238,16 +246,17 @@ pic_dict_dictionary_to_alist(pic_state *pic)
|
|||
{
|
||||
struct pic_dict *dict;
|
||||
pic_value item, alist = pic_nil_value();
|
||||
xh_entry *it;
|
||||
pic_sym *sym;
|
||||
khiter_t it;
|
||||
|
||||
pic_get_args(pic, "d", &dict);
|
||||
|
||||
for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) {
|
||||
item = pic_cons(pic, pic_obj_value(xh_key(it, pic_sym *)), xh_val(it, pic_value));
|
||||
pic_dict_for_each (sym, dict, it) {
|
||||
item = pic_cons(pic, pic_obj_value(sym), pic_dict_ref(pic, dict, sym));
|
||||
pic_push(pic, item, alist);
|
||||
}
|
||||
|
||||
return pic_reverse(pic, alist);
|
||||
return alist;
|
||||
}
|
||||
|
||||
static pic_value
|
||||
|
|
@ -273,16 +282,17 @@ pic_dict_dictionary_to_plist(pic_state *pic)
|
|||
{
|
||||
struct pic_dict *dict;
|
||||
pic_value plist = pic_nil_value();
|
||||
xh_entry *it;
|
||||
pic_sym *sym;
|
||||
khiter_t it;
|
||||
|
||||
pic_get_args(pic, "d", &dict);
|
||||
|
||||
for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) {
|
||||
pic_push(pic, pic_obj_value(xh_key(it, pic_sym *)), plist);
|
||||
pic_push(pic, xh_val(it, pic_value), plist);
|
||||
pic_dict_for_each (sym, dict, it) {
|
||||
pic_push(pic, pic_dict_ref(pic, dict, sym), plist);
|
||||
pic_push(pic, pic_obj_value(sym), plist);
|
||||
}
|
||||
|
||||
return pic_reverse(pic, plist);
|
||||
return plist;
|
||||
}
|
||||
|
||||
static pic_value
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ pic_warnf(pic_state *pic, const char *fmt, ...)
|
|||
err_line = pic_xvformat(pic, fmt, ap);
|
||||
va_end(ap);
|
||||
|
||||
xfprintf(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, pic_str_ptr(pic_car(pic, err_line))));
|
||||
}
|
||||
|
||||
void
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue