Merge branch 'master' of git://github.com/wasabiz/picrin into srfi1

This commit is contained in:
stibear 2014-02-10 23:22:11 +09:00
commit 270f5aa8f0
7 changed files with 310 additions and 116 deletions

View File

@ -57,7 +57,7 @@ Picrin is a lightweight scheme implementation intended to comply with full R7RS
| 5.6.1 Library Syntax | incomplete | In picrin, libraries can be reopend and can be nested. |
| 5.6.2 Library example | N/A | |
| 5.7 The REPL | yes | |
| 6.1 Equivalence predicates | yes | |
| 6.1 Equivalence predicates | yes | TODO: equal? must terminate if circular structure is given |
| 6.2.1 Numerical types | yes | picrin has only two types of internal representation of numbers: fixnum and double float. It still comforms the R7RS spec. |
| 6.2.2 Exactness | yes | |
| 6.2.3 Implementation restrictions | yes | |
@ -75,7 +75,7 @@ Picrin is a lightweight scheme implementation intended to comply with full R7RS
| 6.10 Control features | yes | |
| 6.11 Exceptions | yes | TODO: native error handling |
| 6.12 Environments and evaluation | N/A | |
| 6.13.1 Ports | incomplete | TODO: string I/O, bytevector I/O |
| 6.13.1 Ports | yes | |
| 6.13.2 Input | incomplete | |
| 6.13.3 Output | yes | TODO: `write`, `write-shared` and `display` are unsafe against circular objects |
| 6.14 System interface | yes | |

@ -1 +1 @@
Subproject commit 54889153333c7aa5a228fcf624c730e727abc769
Subproject commit 7c62dd5c264ad1a43bd932b4097445ccc982a557

View File

@ -160,7 +160,7 @@ bool pic_interned_p(pic_state *, pic_sym);
char *pic_strdup(pic_state *, const char *);
char *pic_strndup(pic_state *, const char *, size_t);
struct pic_string *pic_str_new(pic_state *, const char *, size_t);
struct pic_string *pic_str_new(pic_state *, const char *, size_t); /* the 2nd arg may be NULL for empty string */
struct pic_string *pic_str_new_cstr(pic_state *, const char *);
struct pic_vector *pic_vec_new(pic_state *, size_t);

View File

@ -1,3 +1,39 @@
;;; Appendix A. Standard Libraries CxR
(define-library (scheme cxr)
(import (scheme base))
(define (caaar p) (car (caar p)))
(define (caadr p) (car (cadr p)))
(define (cadar p) (car (cdar p)))
(define (caddr p) (car (cddr p)))
(define (cdaar p) (cdr (caar p)))
(define (cdadr p) (cdr (cadr p)))
(define (cddar p) (cdr (cdar p)))
(define (cdddr p) (cdr (cddr p)))
(define (caaaar p) (caar (caar p)))
(define (caaadr p) (caar (cadr p)))
(define (caadar p) (caar (cdar p)))
(define (caaddr p) (caar (cddr p)))
(define (cadaar p) (cadr (caar p)))
(define (cadadr p) (cadr (cadr p)))
(define (caddar p) (cadr (cdar p)))
(define (cadddr p) (cadr (cddr p)))
(define (cdaaar p) (cdar (caar p)))
(define (cdaadr p) (cdar (cadr p)))
(define (cdadar p) (cdar (cdar p)))
(define (cdaddr p) (cdar (cddr p)))
(define (cddaar p) (cddr (caar p)))
(define (cddadr p) (cddr (cadr p)))
(define (cdddar p) (cddr (cdar p)))
(define (cddddr p) (cddr (cddr p)))
(export caaar caadr cadar caddr
cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr
cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr
cddaar cddadr cdddar cddddr))
;;; hygienic macros
(define-library (picrin macro)
(import (scheme base))
@ -13,21 +49,11 @@
(export sc-macro-transformer
rsc-macro-transformer))
;;; bootstrap utilities
(define-library (picrin bootstrap-tools)
(import (scheme base))
(define (cadar p) (car (cdar p)))
(define (caddr p) (car (cddr p)))
(define (cdddr p) (cdr (cddr p)))
(export cadar caddr cdddr))
;;; core syntaces
(define-library (picrin core-syntax)
(import (scheme base)
(picrin macro)
(picrin bootstrap-tools))
(scheme cxr)
(picrin macro))
(define-syntax let
(er-macro-transformer
@ -222,9 +248,9 @@
;;; multiple value
(define-library (picrin multiple-value)
(import (scheme base)
(scheme cxr)
(picrin macro)
(picrin core-syntax)
(picrin bootstrap-tools))
(picrin core-syntax))
(define-syntax let*-values
(er-macro-transformer
@ -268,9 +294,9 @@
;;; parameter
(define-library (picrin parameter)
(import (scheme base)
(scheme cxr)
(picrin macro)
(picrin core-syntax)
(picrin bootstrap-tools))
(picrin core-syntax))
;; reopen (pircin parameter)
;; see src/var.c
@ -280,14 +306,19 @@
(lambda (form r compare)
(let ((bindings (cadr form))
(body (cddr form)))
(let ((vars (map car bindings)))
(let ((vars (map car bindings))
(gensym (lambda (var)
(string->symbol
(string-append
"parameterize-"
(symbol->string var))))))
`(,(r 'let) (,@(map (lambda (var)
`(,(r var) (,var)))
`(,(r (gensym var)) (,var)))
vars))
,@bindings
(,(r 'let) ((,(r 'result) (begin ,@body)))
,@(map (lambda (var)
`(,(r 'parameter-set!) ,var ,(r var)))
`(,(r 'parameter-set!) ,var ,(r (gensym var))))
vars)
,(r 'result))))))))
@ -434,15 +465,6 @@
;;; 6.7 String
(define (string . objs)
(let ((len (length objs)))
(let ((v (make-string len)))
(do ((i 0 (+ i 1))
(l objs (cdr l)))
((= i len)
v)
(string-set! v i (car l))))))
(define (string->list string . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
@ -455,48 +477,18 @@
(set! res (cons (string-ref string i) res)))))
(define (list->string list)
(apply string list))
(let ((len (length list)))
(let ((v (make-string len)))
(do ((i 0 (+ i 1))
(l list (cdr l)))
((= i len)
v)
(string-set! v i (car l))))))
(define (string-copy! to at from . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(string-length from))))
(do ((i at (+ i 1))
(j start (+ j 1)))
((= j end))
(string-set! to i (string-ref from j)))))
(define (string . objs)
(list->string objs))
(define (string-copy v . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(string-length v))))
(let ((res (make-string (string-length v))))
(string-copy! res 0 v start end)
res)))
(define (string-append . vs)
(define (string-append-2-inv w v)
(let ((res (make-string (+ (string-length v) (string-length w)))))
(string-copy! res 0 v)
(string-copy! res (string-length v) w)
res))
(fold string-append-2-inv #() vs))
(define (string-fill! v fill . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(string-length v))))
(do ((i start (+ i 1)))
((= i end)
#f)
(string-set! v i fill))))
(export string string->list list->string
string-copy! string-copy
string-append string-fill!)
(export string string->list list->string)
;;; 6.8. Vector
@ -713,40 +705,3 @@
(write obj port)))))
(export write write-shared display))
;;; Appendix A. Standard Libraries
;; CxR
(define-library (scheme cxr)
(import (scheme base))
(define (caaar p) (car (caar p)))
(define (caadr p) (car (cadr p)))
(define (cadar p) (car (cdar p)))
(define (caddr p) (car (cddr p)))
(define (cdaar p) (cdr (caar p)))
(define (cdadr p) (cdr (cadr p)))
(define (cddar p) (cdr (cdar p)))
(define (cdddr p) (cdr (cddr p)))
(define (caaaar p) (caar (caar p)))
(define (caaadr p) (caar (cadr p)))
(define (caadar p) (caar (cdar p)))
(define (caaddr p) (caar (cddr p)))
(define (cadaar p) (cadr (caar p)))
(define (cadadr p) (cadr (cadr p)))
(define (caddar p) (cadr (cdar p)))
(define (cadddr p) (cadr (cddr p)))
(define (cdaaar p) (cdar (caar p)))
(define (cdaadr p) (cdar (cadr p)))
(define (cdadar p) (cdar (cdar p)))
(define (cdaddr p) (cdar (cddr p)))
(define (cddaar p) (cddr (caar p)))
(define (cddadr p) (cddr (cadr p)))
(define (cdddar p) (cddr (cdar p)))
(define (cddddr p) (cddr (cddr p)))
(export caaar caadr cadar caddr
cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr
cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr
cddaar cddadr cdddar cddddr))

View File

@ -223,6 +223,121 @@ pic_port_close_port(pic_state *pic)
} \
} while (0)
static pic_value
pic_port_open_input_string(pic_state *pic)
{
struct pic_port *port;
char *str;
size_t len;
pic_get_args(pic, "s", &str, &len);
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
port->file = xmopen();
port->flags = PIC_PORT_IN | PIC_PORT_TEXT;
port->status = PIC_PORT_OPEN;
xfputs(str, port->file);
xfflush(port->file);
xrewind(port->file);
return pic_obj_value(port);
}
static pic_value
pic_port_open_output_string(pic_state *pic)
{
struct pic_port *port;
pic_get_args(pic, "");
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
port->file = xmopen();
port->flags = PIC_PORT_OUT | PIC_PORT_TEXT;
port->status = PIC_PORT_OPEN;
return pic_obj_value(port);
}
static pic_value
pic_port_get_output_string(pic_state *pic)
{
struct pic_port *port = pic_stdout(pic);;
long endpos;
char *buf;
pic_get_args(pic, "|p", &port);
assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "get-output-string");
/* get endpos */
xfflush(port->file);
endpos = xftell(port->file);
xrewind(port->file);
/* copy to buf */
buf = (char *)pic_alloc(pic, endpos);
xfread(buf, 1, endpos, port->file);
return pic_obj_value(pic_str_new(pic, buf, endpos));
}
static pic_value
pic_port_open_input_blob(pic_state *pic)
{
struct pic_port *port;
struct pic_blob *blob;
pic_get_args(pic, "b", &blob);
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
port->file = xmopen();
port->flags = PIC_PORT_IN | PIC_PORT_BINARY;
port->status = PIC_PORT_OPEN;
xfwrite(blob->data, 1, blob->len, port->file);
return pic_obj_value(port);
}
static pic_value
pic_port_open_output_bytevector(pic_state *pic)
{
struct pic_port *port;
pic_get_args(pic, "");
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
port->file = xmopen();
port->flags = PIC_PORT_OUT | PIC_PORT_BINARY;
port->status = PIC_PORT_OPEN;
return pic_obj_value(port);
}
static pic_value
pic_port_get_output_bytevector(pic_state *pic)
{
struct pic_port *port = pic_stdout(pic);;
long endpos;
char *buf;
pic_get_args(pic, "|p", &port);
assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "get-output-bytevector");
/* get endpos */
xfflush(port->file);
endpos = xftell(port->file);
xrewind(port->file);
/* copy to buf */
buf = (char *)pic_alloc(pic, endpos);
xfread(buf, 1, endpos, port->file);
return pic_obj_value(pic_blob_new(pic, buf, endpos));
}
static pic_value
pic_port_read_char(pic_state *pic)
{
@ -297,11 +412,11 @@ pic_port_write_string(pic_state *pic)
n = pic_get_args(pic, "s|pii", &str, &len, &port, &start, &end);
switch (n) {
case 2:
case 1:
port = pic_stdout(pic);
case 3:
case 2:
start = 0;
case 4:
case 3:
end = len;
}
@ -336,11 +451,11 @@ pic_port_write_blob(pic_state *pic)
n = pic_get_args(pic, "b|pii", &blob, &port, &start, &end);
switch (n) {
case 2:
case 1:
port = pic_stdout(pic);
case 3:
case 2:
start = 0;
case 4:
case 3:
end = blob->len;
}
@ -385,6 +500,14 @@ pic_init_port(pic_state *pic)
pic_defun(pic, "close-input-port", pic_port_close_port);
pic_defun(pic, "close-output-port", pic_port_close_port);
/* string I/O */
pic_defun(pic, "open-input-string", pic_port_open_input_string);
pic_defun(pic, "open-output-string", pic_port_open_output_string);
pic_defun(pic, "get-output-string", pic_port_get_output_string);
pic_defun(pic, "open-input-bytevector", pic_port_open_input_blob);
pic_defun(pic, "open-output-bytevector", pic_port_open_output_bytevector);
pic_defun(pic, "get-output-bytevector", pic_port_get_output_bytevector);
/* input */
pic_defun(pic, "read-char", pic_port_read_char);
pic_defun(pic, "peek-char", pic_port_peek_char);

View File

@ -10,10 +10,17 @@ struct pic_string *
pic_str_new(pic_state *pic, const char *cstr, size_t len)
{
struct pic_string *str;
char *copy;
if (cstr) {
copy = pic_strdup(pic, cstr);
} else {
copy = (char *)pic_alloc(pic, len);
}
str = (struct pic_string *)pic_obj_alloc(pic, sizeof(struct pic_string), PIC_TT_STRING);
str->len = len;
str->str = pic_strdup(pic, cstr);
str->str = copy;
return str;
}
@ -122,6 +129,97 @@ DEFINE_STRING_CMP(gt, >)
DEFINE_STRING_CMP(le, <=)
DEFINE_STRING_CMP(ge, >=)
static pic_value
pic_str_string_copy(pic_state *pic)
{
size_t len, start, end, i;
char *str;
int n;
struct pic_string *copy;
n = pic_get_args(pic, "s|ii", &str, &len, &start, &end);
switch (n) {
case 1:
start = 0;
case 2:
end = len;
}
copy = pic_str_new(pic, NULL, end - start);
for (i = 0; i < end - start; ++i) {
copy->str[i] = str[start + i];
}
return pic_obj_value(copy);
}
static pic_value
pic_str_string_copy_ip(pic_state *pic)
{
size_t to_len, from_len, at, start, end;
char *to_str, *from_str;
int n;
n = pic_get_args(pic, "sis|ii", &to_str, &to_len, &at, &from_str, &from_len, &start, &end);
switch (n) {
case 3:
start = 0;
case 4:
end = from_len;
}
while (start < end) {
to_str[at++] = from_str[start++];
}
return pic_none_value();
}
static pic_value
pic_str_string_append(pic_state *pic)
{
size_t argc, len, i;
pic_value *argv;
char *buf;
pic_get_args(pic, "*", &argc, &argv);
len = 0;
buf = NULL;
for (i = 0; i < argc; ++i) {
if (! pic_str_p(argv[i])) {
pic_error(pic, "type error");
}
buf = pic_realloc(pic, buf, len + pic_str_ptr(argv[i])->len);
/* copy! */
memcpy(buf + len, pic_str_ptr(argv[i])->str, pic_str_ptr(argv[i])->len);
len += pic_str_ptr(argv[i])->len;
}
return pic_obj_value(pic_str_new(pic, buf, len));
}
static pic_value
pic_str_string_fill_ip(pic_state *pic)
{
size_t len, start, end;
char *str, c;
int n;
n = pic_get_args(pic, "sc|ii", &str, &len, &c, &start, &end);
switch (n) {
case 1:
start = 0;
case 2:
end = len;
}
while (start < end) {
str[start++] = c;
}
return pic_none_value();
}
void
pic_init_str(pic_state *pic)
{
@ -130,9 +228,15 @@ pic_init_str(pic_state *pic)
pic_defun(pic, "string-length", pic_str_string_length);
pic_defun(pic, "string-ref", pic_str_string_ref);
pic_defun(pic, "string-set!", pic_str_string_set);
pic_defun(pic, "string=?", pic_str_string_eq);
pic_defun(pic, "string<?", pic_str_string_lt);
pic_defun(pic, "string>?", pic_str_string_gt);
pic_defun(pic, "string<=?", pic_str_string_le);
pic_defun(pic, "string>=?", pic_str_string_ge);
pic_defun(pic, "string-copy", pic_str_string_copy);
pic_defun(pic, "string-copy!", pic_str_string_copy_ip);
pic_defun(pic, "string-append", pic_str_string_append);
pic_defun(pic, "string-fill!", pic_str_string_fill_ip);
}

12
t/parameterize.scm Normal file
View File

@ -0,0 +1,12 @@
(import (scheme base)
(scheme write))
; expects "piece by piece by piece.\n"
(write
(parameterize
((current-output-port (open-output-string)))
(display "piece")
(display " by piece ")
(display "by piece.")
(newline)
(get-output-string)))