reimplement port functions in c
This commit is contained in:
Yuichi Nishiwaki
parent
e938fb57a5
commit
e62eaa1628
|
|
@ -69,6 +69,290 @@
|
|||
|
||||
;; 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)
|
||||
(letrec
|
||||
((else?
|
||||
|
|
@ -121,21 +405,6 @@
|
|||
(lambda ()
|
||||
(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)
|
||||
(+ n 1))
|
||||
|
||||
|
|
@ -371,42 +640,10 @@
|
|||
(define-auxiliary-syntax _)
|
||||
(define-auxiliary-syntax ...)
|
||||
|
||||
(export syntax-rules
|
||||
_
|
||||
...)
|
||||
|
||||
;; 4.3.3. Signaling errors in macro transformers
|
||||
|
||||
(define-macro syntax-error
|
||||
(lambda (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 real? number?)
|
||||
(define rational? number?)
|
||||
|
|
@ -501,148 +738,6 @@
|
|||
(let ((s (exact (floor (sqrt k)))))
|
||||
(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)
|
||||
(let ((start (if (pair? opts) (car opts) 0))
|
||||
(end (if (>= (length opts) 2)
|
||||
|
|
@ -657,22 +752,6 @@
|
|||
(string-length s))))
|
||||
(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 (dynamic-wind in thunk out)
|
||||
|
|
@ -707,22 +786,6 @@
|
|||
(set! call/cc 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)
|
||||
(and (error-object? obj)
|
||||
(eq? (error-object-type obj) 'read)))
|
||||
|
|
@ -731,18 +794,6 @@
|
|||
(and (error-object? obj)
|
||||
(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)
|
||||
(and (input-port? port) (port-open? port)))
|
||||
|
||||
|
|
@ -754,113 +805,8 @@
|
|||
(close-port port)
|
||||
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)
|
||||
#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)
|
||||
#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))
|
||||
#t)))
|
||||
|
|
|
|||
215
lib/ext/port.c
215
lib/ext/port.c
|
|
@ -655,6 +655,45 @@ pic_port_get_output_bytevector(pic_state *pic)
|
|||
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
|
||||
pic_port_read_u8(pic_state *pic)
|
||||
{
|
||||
|
|
@ -689,6 +728,40 @@ pic_port_peek_u8(pic_state *pic)
|
|||
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
|
||||
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);
|
||||
}
|
||||
|
||||
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
|
||||
pic_port_write_u8(pic_state *pic)
|
||||
{
|
||||
|
|
@ -732,6 +877,33 @@ pic_port_write_u8(pic_state *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
|
||||
pic_port_write_bytevector(pic_state *pic)
|
||||
{
|
||||
|
|
@ -762,6 +934,38 @@ pic_port_write_bytevector(pic_state *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
|
||||
pic_port_flush(pic_state *pic)
|
||||
{
|
||||
|
|
@ -796,17 +1000,28 @@ pic_init_port(pic_state *pic)
|
|||
/* input */
|
||||
pic_defun(pic, "read-u8", pic_port_read_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);
|
||||
pic_defun(pic, "read-string", pic_port_read_string);
|
||||
pic_defun(pic, "read-line", pic_port_read_line);
|
||||
|
||||
/* output */
|
||||
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-string", pic_port_write_string);
|
||||
pic_defun(pic, "flush-output-port", pic_port_flush);
|
||||
|
||||
/* string I/O */
|
||||
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, "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
|
||||
|
|
|
|||
Loading…
Reference in New Issue