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

reimplement port functions in c

This commit is contained in:
Yuichi Nishiwaki 2017-05-13 00:33:18 +09:00
parent e938fb57a5
commit e62eaa1628
2 changed files with 676 additions and 515 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -69,6 +69,290 @@
;; 4.2.7. Exception handling ;; 4.2.7. Exception handling
(export guard)
;; 4.2.8. Quasiquotation
(export quasiquote
unquote
unquote-splicing)
;; 4.3.1. Binding constructs for syntactic keywords
(export let-syntax
letrec-syntax)
;; 4.3.2 Pattern language
(export syntax-rules
_
...)
;; 4.3.3. Signaling errors in macro transformers
(export syntax-error)
;; 5.3. Variable definitions
(export define)
;; 5.3.3. Multiple-value definitions
(export define-values)
;; 5.4. Syntax definitions
(export define-syntax)
;; 5.5 Record-type definitions
(export define-record-type)
;; 6.1. Equivalence predicates
(export eq?
eqv?
equal?)
;; 6.2. Numbers
(export number?
complex?
real?
rational?
integer?
exact?
inexact?
exact-integer?
exact
inexact
=
<
>
<=
>=
zero?
positive?
negative?
odd?
even?
min
max
+
-
*
/
abs
floor-quotient
floor-remainder
floor/
truncate-quotient
truncate-remainder
truncate/
(rename truncate-quotient quotient)
(rename truncate-remainder remainder)
(rename floor-remainder modulo)
gcd
lcm
floor
ceiling
truncate
round
exact-integer-sqrt
square
expt
number->string
string->number)
;; 6.3. Booleans
(export boolean?
boolean=?
not)
;; 6.4 Pairs and lists
(export pair?
cons
car
cdr
set-car!
set-cdr!
null?
caar
cadr
cdar
cddr
list?
make-list
list
length
append
reverse
list-tail
list-ref
list-set!
list-copy
memq
memv
member
assq
assv
assoc)
;; 6.5. Symbols
(export symbol?
symbol=?
symbol->string
string->symbol)
;; 6.6. Characters
(export char?
char->integer
integer->char
char=?
char<?
char>?
char<=?
char>=?)
;; 6.7. Strings
(export string?
string
make-string
string-length
string-ref
string-set!
string-copy
string-copy!
string-append
(rename string-copy substring)
string-fill!
string->list
list->string
string=?
string<?
string>?
string<=?
string>=?)
;; 6.8. Vectors
(export vector?
vector
make-vector
vector-length
vector-ref
vector-set!
vector-copy!
vector-copy
vector-append
vector-fill!
list->vector
vector->list
string->vector
vector->string)
;; 6.9. Bytevectors
(export bytevector?
bytevector
make-bytevector
bytevector-length
bytevector-u8-ref
bytevector-u8-set!
bytevector-copy
bytevector-copy!
bytevector-append
bytevector->list
list->bytevector
utf8->string
string->utf8)
;; 6.10. Control features
(export procedure?
apply
map
for-each
string-map
string-for-each
vector-map
vector-for-each
call-with-current-continuation
call/cc
dynamic-wind
values
call-with-values)
;; 6.11. Exceptions
(export with-exception-handler
raise
raise-continuable
error
error-object?
error-object-message
error-object-irritants
read-error?
file-error?)
;; 6.13. Input and output
(export current-input-port
current-output-port
current-error-port
call-with-port
port?
input-port?
output-port?
(rename port? textual-port?)
(rename port? binary-port?)
input-port-open?
output-port-open?
close-port
(rename close-port close-input-port)
(rename close-port close-output-port)
open-input-string
open-output-string
get-output-string
open-input-bytevector
open-output-bytevector
get-output-bytevector
eof-object?
eof-object
read-char
peek-char
char-ready?
read-line
read-string
read-u8
peek-u8
u8-ready?
read-bytevector
read-bytevector!
newline
write-char
write-string
write-u8
write-bytevector
flush-output-port)
(export features)
(begin
(define-syntax (guard-aux reraise . clauses) (define-syntax (guard-aux reraise . clauses)
(letrec (letrec
((else? ((else?
@ -121,21 +405,6 @@
(lambda () (lambda ()
(apply values args)))))))))))) (apply values args))))))))))))
(export guard)
;; 4.2.8. Quasiquotation
(export quasiquote
unquote
unquote-splicing)
;; 4.3.1. Binding constructs for syntactic keywords
(export let-syntax
letrec-syntax)
;; 4.3.2 Pattern language
(define (succ n) (define (succ n)
(+ n 1)) (+ n 1))
@ -371,42 +640,10 @@
(define-auxiliary-syntax _) (define-auxiliary-syntax _)
(define-auxiliary-syntax ...) (define-auxiliary-syntax ...)
(export syntax-rules
_
...)
;; 4.3.3. Signaling errors in macro transformers
(define-macro syntax-error (define-macro syntax-error
(lambda (form _) (lambda (form _)
(apply error (cdr form)))) (apply error (cdr form))))
(export syntax-error)
;; 5.3. Variable definitions
(export define)
;; 5.3.3. Multiple-value definitions
(export define-values)
;; 5.4. Syntax definitions
(export define-syntax)
;; 5.5 Record-type definitions
(export define-record-type)
;; 6.1. Equivalence predicates
(export eq?
eqv?
equal?)
;; 6.2. Numbers
(define complex? number?) (define complex? number?)
(define real? number?) (define real? number?)
(define rational? number?) (define rational? number?)
@ -501,148 +738,6 @@
(let ((s (exact (floor (sqrt k))))) (let ((s (exact (floor (sqrt k)))))
(values s (- k (square s))))) (values s (- k (square s)))))
(export number?
complex?
real?
rational?
integer?
exact?
inexact?
exact-integer?
exact
inexact
=
<
>
<=
>=
zero?
positive?
negative?
odd?
even?
min
max
+
-
*
/
abs
floor-quotient
floor-remainder
floor/
truncate-quotient
truncate-remainder
truncate/
(rename truncate-quotient quotient)
(rename truncate-remainder remainder)
(rename floor-remainder modulo)
gcd
lcm
floor
ceiling
truncate
round
exact-integer-sqrt
square
expt
number->string
string->number)
;; 6.3. Booleans
(export boolean?
boolean=?
not)
;; 6.4 Pairs and lists
(export pair?
cons
car
cdr
set-car!
set-cdr!
null?
caar
cadr
cdar
cddr
list?
make-list
list
length
append
reverse
list-tail
list-ref
list-set!
list-copy
memq
memv
member
assq
assv
assoc)
;; 6.5. Symbols
(export symbol?
symbol=?
symbol->string
string->symbol)
;; 6.6. Characters
(export char?
char->integer
integer->char
char=?
char<?
char>?
char<=?
char>=?)
;; 6.7. Strings
(export string?
string
make-string
string-length
string-ref
string-set!
string-copy
string-copy!
string-append
(rename string-copy substring)
string-fill!
string->list
list->string
string=?
string<?
string>?
string<=?
string>=?)
;; 6.8. Vectors
(export vector?
vector
make-vector
vector-length
vector-ref
vector-set!
vector-copy!
vector-copy
vector-append
vector-fill!
list->vector
vector->list
string->vector
vector->string)
;; 6.9. Bytevectors
(define (utf8->string v . opts) (define (utf8->string v . opts)
(let ((start (if (pair? opts) (car opts) 0)) (let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2) (end (if (>= (length opts) 2)
@ -657,22 +752,6 @@
(string-length s)))) (string-length s))))
(list->bytevector (map char->integer (string->list s start end))))) (list->bytevector (map char->integer (string->list s start end)))))
(export bytevector?
bytevector
make-bytevector
bytevector-length
bytevector-u8-ref
bytevector-u8-set!
bytevector-copy
bytevector-copy!
bytevector-append
bytevector->list
list->bytevector
utf8->string
string->utf8)
;; 6.10. Control features
(define checkpoints '((0 #f . #f))) (define checkpoints '((0 #f . #f)))
(define (dynamic-wind in thunk out) (define (dynamic-wind in thunk out)
@ -707,22 +786,6 @@
(set! call/cc scheme:call/cc) (set! call/cc scheme:call/cc)
(set! call-with-current-continuation scheme:call/cc) (set! call-with-current-continuation scheme:call/cc)
(export procedure?
apply
map
for-each
string-map
string-for-each
vector-map
vector-for-each
call-with-current-continuation
call/cc
dynamic-wind
values
call-with-values)
;; 6.11. Exceptions
(define (read-error? obj) (define (read-error? obj)
(and (error-object? obj) (and (error-object? obj)
(eq? (error-object-type obj) 'read))) (eq? (error-object-type obj) 'read)))
@ -731,18 +794,6 @@
(and (error-object? obj) (and (error-object? obj)
(eq? (error-object-type obj) 'file))) (eq? (error-object-type obj) 'file)))
(export with-exception-handler
raise
raise-continuable
error
error-object?
error-object-message
error-object-irritants
read-error?
file-error?)
;; 6.13. Input and output
(define (input-port-open? port) (define (input-port-open? port)
(and (input-port? port) (port-open? port))) (and (input-port? port) (port-open? port)))
@ -754,113 +805,8 @@
(close-port port) (close-port port)
res)) res))
(define (open-input-string str)
(open-input-bytevector (list->bytevector (map char->integer (string->list str)))))
(define (open-output-string)
(open-output-bytevector))
(define (get-output-string port)
(list->string (map integer->char (bytevector->list (get-output-bytevector port)))))
(define (read-char . opt)
(let ((b (apply read-u8 opt)))
(if (eof-object? b)
b
(integer->char b))))
(define (peek-char . opt)
(let ((b (apply peek-u8 opt)))
(if (eof-object? b)
b
(integer->char b))))
(define (u8-ready? . opt) (define (u8-ready? . opt)
#t) #t)
(define (read-bytevector k . opt)
(let ((port (if (null? opt) (current-input-port) (car opt))))
(let ((buf (make-bytevector k)))
(let ((n (read-bytevector! buf port 0 k)))
(if (eof-object? n)
(eof-object)
(bytevector-copy buf 0 n))))))
(define (char-ready? . opt) (define (char-ready? . opt)
#t) #t)))
(define (newline . opt)
(apply write-u8 (char->integer #\newline) opt))
(define (write-char c . opt)
(apply write-u8 (char->integer c) opt))
(define (write-string s . opt)
(apply write-bytevector (list->bytevector (map char->integer (string->list s))) opt))
(define (read-line . opt)
(if (eof-object? (apply peek-char opt))
(eof-object)
(let loop ((str "") (c (apply read-char opt)))
(if (or (eof-object? c)
(char=? c #\newline))
str
(loop (string-append str (string c)) (apply read-char opt))))))
(define (read-string k . opt)
(if (eof-object? (apply peek-char opt))
(eof-object)
(let loop ((k k) (str "") (c (apply read-char opt)))
(if (or (eof-object? c)
(zero? k))
str
(loop (- k 1) (string-append str (string c)) (apply read-char opt))))))
(export current-input-port
current-output-port
current-error-port
call-with-port
port?
input-port?
output-port?
(rename port? textual-port?)
(rename port? binary-port?)
input-port-open?
output-port-open?
close-port
(rename close-port close-input-port)
(rename close-port close-output-port)
open-input-string
open-output-string
get-output-string
open-input-bytevector
open-output-bytevector
get-output-bytevector
eof-object?
eof-object
read-char
peek-char
char-ready?
read-line
read-string
read-u8
peek-u8
u8-ready?
read-bytevector
read-bytevector!
newline
write-char
write-string
write-u8
write-bytevector
flush-output-port)
(export features))

215
lib/ext/port.c
View File

@ -655,6 +655,45 @@ pic_port_get_output_bytevector(pic_state *pic)
return pic_blob_value(pic, (unsigned char *)buf, len); return pic_blob_value(pic, (unsigned char *)buf, len);
} }
static pic_value
pic_port_open_input_string(pic_state *pic)
{
pic_value str;
const char *buf;
int len;
pic_get_args(pic, "s", &str);
buf = pic_str(pic, str, &len);
return pic_fmemopen(pic, buf, len, "r");
}
static pic_value
pic_port_open_output_string(pic_state *pic)
{
pic_get_args(pic, "");
return pic_fmemopen(pic, NULL, 0, "w");
}
static pic_value
pic_port_get_output_string(pic_state *pic)
{
pic_value port = pic_stdout(pic);
const char *buf;
int len;
pic_get_args(pic, "|o", &port);
check_port_type(pic, port, FILE_WRITE);
if (pic_fgetbuf(pic, port, &buf, &len) < 0) {
pic_error(pic, "port was not created by open-output-string", 0);
}
return pic_str_value(pic, buf, len);
}
static pic_value static pic_value
pic_port_read_u8(pic_state *pic) pic_port_read_u8(pic_state *pic)
{ {
@ -689,6 +728,40 @@ pic_port_peek_u8(pic_state *pic)
return pic_int_value(pic, c); return pic_int_value(pic, c);
} }
static pic_value
pic_port_read_char(pic_state *pic)
{
pic_value port = pic_stdin(pic);
int c;
pic_get_args(pic, "|o", &port);
check_port_type(pic, port, FILE_READ);
if ((c = pic_fgetc(pic, port)) == EOF) {
return pic_eof_object(pic);
}
return pic_char_value(pic, c);
}
static pic_value
pic_port_peek_char(pic_state *pic)
{
int c;
pic_value port = pic_stdin(pic);
pic_get_args(pic, "|o", &port);
check_port_type(pic, port, FILE_READ);
c = pic_fgetc(pic, port);
if (c == EOF) {
return pic_eof_object(pic);
}
pic_ungetc(pic, c, port);
return pic_char_value(pic, c);
}
static pic_value static pic_value
pic_port_read_bytevector_ip(pic_state *pic) pic_port_read_bytevector_ip(pic_state *pic)
{ {
@ -718,6 +791,78 @@ pic_port_read_bytevector_ip(pic_state *pic)
return pic_int_value(pic, i); return pic_int_value(pic, i);
} }
static pic_value
pic_port_read_bytevector(pic_state *pic)
{
pic_value port = pic_stdin(pic), blob;
int n, k, i;
unsigned char *buf;
n = pic_get_args(pic, "i|o", &k, &port);
check_port_type(pic, port, FILE_READ);
buf = pic_malloc(pic, k);
i = pic_fread(pic, buf, 1, k, port);
if (i == 0) {
pic_free(pic, buf);
return pic_eof_object(pic);
}
blob = pic_blob_value(pic, buf, i);
pic_free(pic, buf);
return blob;
}
static pic_value
pic_port_read_string(pic_state *pic)
{
pic_value port = pic_stdin(pic), blob;
int n, k, i;
char *buf;
n = pic_get_args(pic, "i|o", &k, &port);
check_port_type(pic, port, FILE_READ);
buf = pic_malloc(pic, k);
i = pic_fread(pic, buf, 1, k, port);
if (i == 0) {
pic_free(pic, buf);
return pic_eof_object(pic);
}
blob = pic_str_value(pic, buf, i);
pic_free(pic, buf);
return blob;
}
static pic_value
pic_port_read_line(pic_state *pic)
{
pic_value port = pic_stdin(pic), str;
int c;
char s[1];
pic_get_args(pic, "|o", &port);
check_port_type(pic, port, FILE_READ);
if ((c = pic_fgetc(pic, port)) == EOF) {
return pic_eof_object(pic);
}
s[0] = c;
str = pic_str_value(pic, s, 1);
while ((c = pic_fgetc(pic, port)) != EOF) {
if (c == '\n')
break;
s[0] = c;
str = pic_str_cat(pic, str, pic_str_value(pic, s, 1));
}
return str;
}
static pic_value static pic_value
pic_port_write_u8(pic_state *pic) pic_port_write_u8(pic_state *pic)
{ {
@ -732,6 +877,33 @@ pic_port_write_u8(pic_state *pic)
return pic_undef_value(pic); return pic_undef_value(pic);
} }
static pic_value
pic_port_write_char(pic_state *pic)
{
char c;
pic_value port = pic_stdout(pic);
pic_get_args(pic, "c|o", &c, &port);
check_port_type(pic, port, FILE_WRITE);
pic_fputc(pic, c, port);
return pic_undef_value(pic);
}
static pic_value
pic_port_newline(pic_state *pic)
{
pic_value port = pic_stdout(pic);
pic_get_args(pic, "|o", &port);
check_port_type(pic, port, FILE_WRITE);
pic_fputc(pic, '\n', port);
return pic_undef_value(pic);
}
static pic_value static pic_value
pic_port_write_bytevector(pic_state *pic) pic_port_write_bytevector(pic_state *pic)
{ {
@ -762,6 +934,38 @@ pic_port_write_bytevector(pic_state *pic)
return pic_undef_value(pic); return pic_undef_value(pic);
} }
static pic_value
pic_port_write_string(pic_state *pic)
{
pic_value str, port;
int n, start, end, len, done;
const char *buf;
n = pic_get_args(pic, "s|oii", &str, &port, &start, &end);
buf = pic_str(pic, str, &len);
switch (n) {
case 1:
port = pic_stdout(pic);
case 2:
start = 0;
case 3:
end = len;
}
VALID_RANGE(pic, len, start, end);
check_port_type(pic, port, FILE_WRITE);
done = 0;
while (done < end - start) {
done += pic_fwrite(pic, buf + start + done, 1, end - start - done, port);
/* FIXME: error check... */
}
return pic_undef_value(pic);
}
static pic_value static pic_value
pic_port_flush(pic_state *pic) pic_port_flush(pic_state *pic)
{ {
@ -796,17 +1000,28 @@ pic_init_port(pic_state *pic)
/* input */ /* input */
pic_defun(pic, "read-u8", pic_port_read_u8); pic_defun(pic, "read-u8", pic_port_read_u8);
pic_defun(pic, "peek-u8", pic_port_peek_u8); pic_defun(pic, "peek-u8", pic_port_peek_u8);
pic_defun(pic, "read-char", pic_port_read_char);
pic_defun(pic, "peek-char", pic_port_peek_char);
pic_defun(pic, "read-bytevector!", pic_port_read_bytevector_ip); pic_defun(pic, "read-bytevector!", pic_port_read_bytevector_ip);
pic_defun(pic, "read-bytevector", pic_port_read_bytevector);
pic_defun(pic, "read-string", pic_port_read_string);
pic_defun(pic, "read-line", pic_port_read_line);
/* output */ /* output */
pic_defun(pic, "write-u8", pic_port_write_u8); pic_defun(pic, "write-u8", pic_port_write_u8);
pic_defun(pic, "write-char", pic_port_write_char);
pic_defun(pic, "newline", pic_port_newline);
pic_defun(pic, "write-bytevector", pic_port_write_bytevector); pic_defun(pic, "write-bytevector", pic_port_write_bytevector);
pic_defun(pic, "write-string", pic_port_write_string);
pic_defun(pic, "flush-output-port", pic_port_flush); pic_defun(pic, "flush-output-port", pic_port_flush);
/* string I/O */ /* string I/O */
pic_defun(pic, "open-input-bytevector", pic_port_open_input_bytevector); pic_defun(pic, "open-input-bytevector", pic_port_open_input_bytevector);
pic_defun(pic, "open-output-bytevector", pic_port_open_output_bytevector); pic_defun(pic, "open-output-bytevector", pic_port_open_output_bytevector);
pic_defun(pic, "get-output-bytevector", pic_port_get_output_bytevector); pic_defun(pic, "get-output-bytevector", pic_port_get_output_bytevector);
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);
} }
#endif #endif