Merge branch 'master' of git://github.com/wasabiz/picrin into srfi1
This commit is contained in:
commit
270f5aa8f0
|
@ -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
|
|
@ -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);
|
||||
|
|
|
@ -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))
|
||||
|
|
135
src/port.c
135
src/port.c
|
@ -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);
|
||||
|
|
106
src/string.c
106
src/string.c
|
@ -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);
|
||||
}
|
||||
|
|
|
@ -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)))
|
Loading…
Reference in New Issue