steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

file responder works with native factor

cvs
Slava Pestov 2004-08-29 02:25:59 +00:00
parent b64d81b3d2
commit 4879b08161
23 changed files with 210 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -1,5 +1,5 @@
CC = gcc CC = gcc
CFLAGS = -g -Os -mpentiumpro -Wall -fomit-frame-pointer CFLAGS = -g -Os -mpentiumpro -Wall
LIBS = -lm LIBS = -lm
STRIP = strip STRIP = strip

6
library/cross-compiler.factor
View File

@ -62,7 +62,7 @@ DEFER: port?
DEFER: open-file DEFER: open-file
DEFER: client-socket DEFER: client-socket
DEFER: server-socket DEFER: server-socket
DEFER: close-fd DEFER: close-port
DEFER: add-accept-io-task DEFER: add-accept-io-task
DEFER: accept-fd DEFER: accept-fd
DEFER: can-read-line? DEFER: can-read-line?
@ -74,6 +74,7 @@ DEFER: read-count-fd-8
DEFER: can-write? DEFER: can-write?
DEFER: add-write-io-task DEFER: add-write-io-task
DEFER: write-fd-8 DEFER: write-fd-8
DEFER: add-copy-io-task
DEFER: next-io-task DEFER: next-io-task
IN: math IN: math
@ -222,7 +223,7 @@ IN: cross-compiler
exit* exit*
client-socket client-socket
server-socket server-socket
close-fd close-port
add-accept-io-task add-accept-io-task
accept-fd accept-fd
can-read-line? can-read-line?
@ -234,6 +235,7 @@ IN: cross-compiler
can-write? can-write?
add-write-io-task add-write-io-task
write-fd-8 write-fd-8
add-copy-io-task
next-io-task next-io-task
room room
os-env os-env

1
library/files.factor
View File

@ -60,4 +60,5 @@ USE: strings
[ "gz" | "application/octet-stream" ] [ "gz" | "application/octet-stream" ]
[ "factor" | "application/x-factor" ] [ "factor" | "application/x-factor" ]
[ "factsp" | "application/x-factor-server-page" ]
] set-mime-types ] set-mime-types

12
library/httpd/default-responders.factor
View File

@ -53,12 +53,12 @@ USE: wiki-responder
"quit" "responder" set "quit" "responder" set
[ quit-responder ] "get" set [ quit-responder ] "get" set
] extend "quit" set ] extend "quit" set
!
! <responder> [ <responder> [
! "file" "responder" set "file" "responder" set
! [ file-responder ] "get" set [ file-responder ] "get" set
! ] extend "file" set ] extend "file" set
!
! <responder> [ ! <responder> [
! "wiki" "responder" set ! "wiki" "responder" set
! [ wiki-get-responder ] "get" set ! [ wiki-get-responder ] "get" set

81
library/httpd/file-responder.factor
View File

@ -1,4 +1,4 @@
! :folding=indent:collapseFolds=0: ! :folding=indent:collapseFolds=1:
! $Id$ ! $Id$
! !
@ -27,82 +27,45 @@
IN: file-responder IN: file-responder
USE: combinators USE: combinators
USE: html USE: errors
USE: kernel USE: kernel
USE: lists
USE: files USE: files
USE: httpd
USE: httpd-responder
USE: namespaces USE: namespaces
USE: parser USE: parser
USE: regexp
USE: stack USE: stack
USE: stdio USE: stdio
USE: streams USE: streams
USE: strings USE: strings
USE: httpd : parse-object-name ( filename -- argument filename )
USE: httpd-responder dup [ "?" split1 swap ] [ "/" ] ifte
"doc-root" get swap cat2 ;
!!! Serving files.
: file-header ( filename -- header )
"200 Document follows" swap mime-type response ;
: serve-file ( filename -- )
dup file-header print <filebr> "stdio" get fcopy ;
!!! Serving directories.
: file>html ( filename -- ... )
"<li><a href=\"" swap
! dup directory? [ "/" cat2 ] when
chars>entities
"\">" over "</a></li>" ;
: directory>html ( directory -- html )
directory [ file>html ] map cat ;
: list-directory ( directory -- )
serving-html
[
"<html><head><title>" swap
"</title></head><body><h1>" over
"</h1><ul>" over
directory>html
"</ul></body></html>"
] cons expand cat write ;
: serve-directory ( directory -- )
dup "/index.html" cat2 dup exists? [
nip serve-file
] [
drop list-directory
] ifte ;
!!! Serving objects.
: serve-static ( filename -- )
dup directory? [
serve-directory
] [
serve-file
] ifte ;
: serve-script ( argument filename -- ) : serve-script ( argument filename -- )
[ swap "argument" set run-file ] with-scope ; [ swap "argument" set run-file ] with-scope ;
: parse-object-name ( filename -- argument filename ) : file-header ( mime-type -- header )
dup [ "200 Document follows" swap response ;
dup "(.*?)\\?(.*)" groups dup [ nip call ] when swap
: copy-and-close ( from -- )
[ dupd "stdio" get fcopy ] [ >r fclose r> rethrow ] catch ;
: serve-static ( argument filename mime-type -- )
file-header print <filebr> "stdio" get fcopy drop ;
: serve-file ( argument filename -- )
dup mime-type dup "application/x-factor-server-page" = [
drop serve-script
] [ ] [
drop f "/" serve-static
] ifte ; ] ifte ;
: file-responder ( filename -- ) : file-responder ( filename -- )
"doc-root" get [ "doc-root" get [
parse-object-name "doc-root" get swap cat2 parse-object-name dup exists? [
dup exists? [ serve-file
dup file-extension "lhtml" = [
serve-script
] [
nip serve-static
] ifte
] [ ] [
2drop "404 not found" httpd-error 2drop "404 not found" httpd-error
] ifte ] ifte

3
library/platform/jvm/stream.factor
View File

@ -37,7 +37,8 @@ USE: stack
USE: strings USE: strings
: fcopy ( from to -- ) : fcopy ( from to -- )
! Copy the contents of the byte-stream 'from' to the byte-stream 'to'. #! Copy the contents of the byte-stream 'from' to the
#! byte-stream 'to'.
[ [ "in" get ] bind ] dip [ [ "in" get ] bind ] dip
[ "out" get ] bind [ "out" get ] bind
[ "java.io.InputStream" "java.io.OutputStream" ] [ "java.io.InputStream" "java.io.OutputStream" ]

1
library/platform/native/boot-stage2.factor
View File

@ -117,6 +117,7 @@ USE: stdio
"/library/httpd/http-common.factor" "/library/httpd/http-common.factor"
"/library/httpd/responder.factor" "/library/httpd/responder.factor"
"/library/httpd/httpd.factor" "/library/httpd/httpd.factor"
"/library/httpd/file-responder.factor"
"/library/httpd/inspect-responder.factor" "/library/httpd/inspect-responder.factor"
"/library/httpd/test-responder.factor" "/library/httpd/test-responder.factor"
"/library/httpd/quit-responder.factor" "/library/httpd/quit-responder.factor"

20
library/platform/native/io-internals.factor
View File

@ -36,30 +36,29 @@ USE: threads
: stdin 0 getenv ; : stdin 0 getenv ;
: stdout 1 getenv ; : stdout 1 getenv ;
: stderr 2 getenv ;
: flush-fd ( port -- ) : blocking-flush ( port -- )
[ swap add-write-io-task (yield) ] callcc0 drop ; [ add-write-io-task (yield) ] callcc0 drop ;
: wait-to-write ( len port -- ) : wait-to-write ( len port -- )
tuck can-write? [ drop ] [ flush-fd ] ifte ; tuck can-write? [ drop ] [ blocking-flush ] ifte ;
: blocking-write ( str port -- ) : blocking-write ( str port -- )
over over
dup string? [ str-length ] [ drop 1 ] ifte dup string? [ str-length ] [ drop 1 ] ifte
over wait-to-write write-fd-8 ; over wait-to-write write-fd-8 ;
: fill-fd ( port -- ) : blocking-fill ( port -- )
[ swap add-read-line-io-task (yield) ] callcc0 drop ; [ add-read-line-io-task (yield) ] callcc0 drop ;
: wait-to-read-line ( port -- ) : wait-to-read-line ( port -- )
dup can-read-line? [ drop ] [ fill-fd ] ifte ; dup can-read-line? [ drop ] [ blocking-fill ] ifte ;
: blocking-read-line ( port -- line ) : blocking-read-line ( port -- line )
dup wait-to-read-line read-line-fd-8 dup [ sbuf>str ] when ; dup wait-to-read-line read-line-fd-8 dup [ sbuf>str ] when ;
: fill-fd# ( count port -- ) : fill-fd# ( count port -- )
[ -rot add-read-count-io-task (yield) ] callcc0 2drop ; [ add-read-count-io-task (yield) ] callcc0 2drop ;
: wait-to-read# ( count port -- ) : wait-to-read# ( count port -- )
2dup can-read-count? [ 2drop ] [ fill-fd# ] ifte ; 2dup can-read-count? [ 2drop ] [ fill-fd# ] ifte ;
@ -68,7 +67,10 @@ USE: threads
2dup wait-to-read# read-count-fd-8 dup [ sbuf>str ] when ; 2dup wait-to-read# read-count-fd-8 dup [ sbuf>str ] when ;
: wait-to-accept ( socket -- ) : wait-to-accept ( socket -- )
[ swap add-accept-io-task (yield) ] callcc0 drop ; [ add-accept-io-task (yield) ] callcc0 drop ;
: blocking-accept ( socket -- host port in out ) : blocking-accept ( socket -- host port in out )
dup wait-to-accept accept-fd ; dup wait-to-accept accept-fd ;
: blocking-copy ( in out -- )
[ add-copy-io-task (yield) ] callcc0 ;

2
library/platform/native/network.factor
View File

@ -46,7 +46,7 @@ USE: unparser
"socket" set "socket" set
( -- ) ( -- )
[ "socket" get close-fd ] "fclose" set [ "socket" get close-port ] "fclose" set
] extend ; ] extend ;
: <client-stream> ( host port in out -- stream ) : <client-stream> ( host port in out -- stream )

11
library/platform/native/stream.factor
View File

@ -56,12 +56,12 @@ USE: namespaces
] "fread#" set ] "fread#" set
( -- ) ( -- )
[ "out" get [ flush-fd ] when* ] "fflush" set [ "out" get [ blocking-flush ] when* ] "fflush" set
( -- ) ( -- )
[ [
"out" get [ dup flush-fd close-fd ] when* "out" get [ dup blocking-flush close-port ] when*
"in" get [ close-fd ] when* "in" get [ close-port ] when*
] "fclose" set ] "fclose" set
] extend ; ] extend ;
@ -83,3 +83,8 @@ USE: namespaces
: exists? ( file -- ? ) : exists? ( file -- ? )
#! This is terrible. #! This is terrible.
[ <filebr> fclose t ] [ nip not ] catch ; [ <filebr> fclose t ] [ nip not ] catch ;
: fcopy ( from to -- )
#! Copy the contents of the fd-stream 'from' to the
#! fd-stream 'to'.
"out" swap get* >r "in" swap get* r> blocking-copy ;

10
library/platform/native/threads.factor
View File

@ -57,15 +57,15 @@ USE: stack
#! If there is a quotation in the run queue, call it, #! If there is a quotation in the run queue, call it,
#! otherwise wait for I/O. The currently executing #! otherwise wait for I/O. The currently executing
#! continuation is suspended. Use yield instead. #! continuation is suspended. Use yield instead.
next-thread dup [ next-thread [
call call
] [ ] [
drop next-io-task dup [ next-io-task [
call call
] [ ] [
drop (yield) (yield)
] ifte ] ifte*
] ifte ; ] ifte* ;
: yield ( -- ) : yield ( -- )
#! Add the current continuation to the run queue, and yield #! Add the current continuation to the run queue, and yield

22
library/test/httpd/httpd.factor
View File

@ -1,4 +1,5 @@
IN: scratchpad IN: scratchpad
USE: file-responder
USE: httpd USE: httpd
USE: httpd-responder USE: httpd-responder
USE: logging USE: logging
@ -66,3 +67,24 @@ USE: url-encoding
[ [ [ "Foo" | "Bar" ] ] ] [ "Foo=Bar" post-request>alist ] unit-test [ [ [ "Foo" | "Bar" ] ] ] [ "Foo=Bar" post-request>alist ] unit-test
[ [ [ "Foo" | "Bar" ] [ "Baz" | "Quux" ] ] ] [ [ [ "Foo" | "Bar" ] [ "Baz" | "Quux" ] ] ]
[ "Foo=Bar&Baz=Quux" post-request>alist ] unit-test [ "Foo=Bar&Baz=Quux" post-request>alist ] unit-test
[ f "/foo/hello.html" ] [
[
"/foo/" "doc-root" set
"hello.html" parse-object-name
] with-scope
] unit-test
[ "some-arg" "/foo/hello.html" ] [
[
"/foo/" "doc-root" set
"hello.html?some-arg" parse-object-name
] with-scope
] unit-test
[ f "/foo/" ] [
[
"/foo" "doc-root" set
f parse-object-name
] with-scope
] unit-test

2
native/float.c
View File

@ -45,7 +45,7 @@ void primitive_str_to_float(void)
void primitive_float_to_str(void) void primitive_float_to_str(void)
{ {
char tmp[33]; char tmp[33];
snprintf(&tmp,32,"%.16g",to_float(dpeek())->n); snprintf(tmp,32,"%.16g",to_float(dpeek())->n);
tmp[32] = '\0'; tmp[32] = '\0';
drepl(tag_object(from_c_string(tmp))); drepl(tag_object(from_c_string(tmp)));
} }

2
native/gc.c
View File

@ -2,7 +2,7 @@
/* Stop-and-copy garbage collection using Cheney's algorithm. */ /* Stop-and-copy garbage collection using Cheney's algorithm. */
/* #define GC_DEBUG /* */ /* #define GC_DEBUG */
INLINE void gc_debug(char* msg, CELL x) { INLINE void gc_debug(char* msg, CELL x) {
#ifdef GC_DEBUG #ifdef GC_DEBUG

76
native/io.c
View File

@ -28,18 +28,20 @@ void init_io(void)
IO_TASK* add_io_task( IO_TASK* add_io_task(
IO_TASK_TYPE type, IO_TASK_TYPE type,
PORT* port, CELL port,
CELL other_port,
CELL callback, CELL callback,
IO_TASK* io_tasks, IO_TASK* io_tasks,
int* fd_count) int* fd_count)
{ {
int fd = port->fd; int fd = untag_port(port)->fd;
if(io_tasks[fd].callbacks != F && type != IO_TASK_WRITE) if(io_tasks[fd].callbacks != F && type != IO_TASK_WRITE)
general_error(ERROR_IO_TASK_TWICE,tag_object(port)); general_error(ERROR_IO_TASK_TWICE,port);
io_tasks[fd].type = type; io_tasks[fd].type = type;
io_tasks[fd].port = tag_object(port); io_tasks[fd].port = port;
io_tasks[fd].other_port = other_port;
io_tasks[fd].callbacks = tag_cons(cons(callback, io_tasks[fd].callbacks = tag_cons(cons(callback,
io_tasks[fd].callbacks)); io_tasks[fd].callbacks));
@ -49,14 +51,6 @@ IO_TASK* add_io_task(
return &io_tasks[fd]; return &io_tasks[fd];
} }
void primitive_add_accept_io_task(void)
{
PORT* port = untag_port(dpop());
CELL callback = dpop();
add_io_task(IO_TASK_ACCEPT,port,callback,
read_io_tasks,&read_fd_count);
}
void remove_io_task( void remove_io_task(
IO_TASK_TYPE type, IO_TASK_TYPE type,
PORT* port, PORT* port,
@ -66,6 +60,7 @@ void remove_io_task(
int fd = port->fd; int fd = port->fd;
io_tasks[fd].port = F; io_tasks[fd].port = F;
io_tasks[fd].other_port = F;
io_tasks[fd].callbacks = F; io_tasks[fd].callbacks = F;
if(fd == *fd_count - 1) if(fd == *fd_count - 1)
@ -80,6 +75,55 @@ void remove_io_tasks(PORT* port)
write_io_tasks,&write_fd_count); write_io_tasks,&write_fd_count);
} }
bool perform_copy_from_io_task(PORT* port, PORT* other_port)
{
if(port->buf_fill == 0)
{
if(read_step(port))
{
/* EOF? */
if(port->buf_fill == 0)
return true;
}
else
return false;
}
if(can_write(other_port,port->buf_fill))
{
write_string_raw(other_port,
(char*)(port->buffer + 1),
port->buf_fill);
port->buf_pos = port->buf_fill = 0;
}
return false;
}
bool perform_copy_to_io_task(PORT* port, PORT* other_port)
{
bool success = perform_write_io_task(port);
/* only return 'true' if the COPY_FROM task is done also. */
if(read_io_tasks[other_port->fd].port == F)
return success;
else
return false;
}
void primitive_add_copy_io_task(void)
{
CELL callback = dpop();
CELL to = dpop();
CELL from = dpop();
/* callback for COPY_FROM is F since we only care about
when BOTH tasks are done, and this is taken care of by
COPY_TO. */
add_io_task(IO_TASK_COPY_FROM,from,to,F,
read_io_tasks,&read_fd_count);
add_io_task(IO_TASK_COPY_TO,to,from,callback,
write_io_tasks,&write_fd_count);
}
bool set_up_fd_set(fd_set* fdset, int fd_count, IO_TASK* io_tasks) bool set_up_fd_set(fd_set* fdset, int fd_count, IO_TASK* io_tasks)
{ {
bool retval = false; bool retval = false;
@ -134,6 +178,14 @@ CELL perform_io_task(IO_TASK* io_task, IO_TASK* io_tasks, int* fd_count)
case IO_TASK_ACCEPT: case IO_TASK_ACCEPT:
success = accept_connection(port); success = accept_connection(port);
break; break;
case IO_TASK_COPY_FROM:
success = perform_copy_from_io_task(port,
untag_port(io_task->other_port));
break;
case IO_TASK_COPY_TO:
success = perform_copy_to_io_task(port,
untag_port(io_task->other_port));
break;
default: default:
critical_error("Bad I/O task",io_task->type); critical_error("Bad I/O task",io_task->type);
success = false; success = false;

13
native/io.h
View File

@ -4,12 +4,16 @@ typedef enum {
IO_TASK_READ_LINE, IO_TASK_READ_LINE,
IO_TASK_READ_COUNT, IO_TASK_READ_COUNT,
IO_TASK_WRITE, IO_TASK_WRITE,
IO_TASK_ACCEPT IO_TASK_ACCEPT,
IO_TASK_COPY_FROM,
IO_TASK_COPY_TO
} IO_TASK_TYPE; } IO_TASK_TYPE;
typedef struct { typedef struct {
IO_TASK_TYPE type; IO_TASK_TYPE type;
CELL port; CELL port;
/* Used for COPY_FROM and COPY_TO only */
CELL other_port;
/* TAGGED list of callbacks, or F */ /* TAGGED list of callbacks, or F */
/* Multiple callbacks per port are only permitted for IO_TASK_WRITE. */ /* Multiple callbacks per port are only permitted for IO_TASK_WRITE. */
CELL callbacks; CELL callbacks;
@ -29,17 +33,20 @@ void init_io_tasks(fd_set* fd_set, IO_TASK* io_tasks);
void init_io(void); void init_io(void);
IO_TASK* add_io_task( IO_TASK* add_io_task(
IO_TASK_TYPE type, IO_TASK_TYPE type,
PORT* port, CELL port,
CELL other_port,
CELL callback, CELL callback,
IO_TASK* io_tasks, IO_TASK* io_tasks,
int* fd_count); int* fd_count);
void primitive_add_accept_io_task(void);
void remove_io_task( void remove_io_task(
IO_TASK_TYPE type, IO_TASK_TYPE type,
PORT* port, PORT* port,
IO_TASK* io_tasks, IO_TASK* io_tasks,
int* fd_count); int* fd_count);
void remove_io_tasks(PORT* port); void remove_io_tasks(PORT* port);
bool perform_copy_from_io_task(PORT* port, PORT* other_port);
bool perform_copy_to_io_task(PORT* port, PORT* other_port);
void primitive_add_copy_io_task(void);
CELL pop_io_task_callback( CELL pop_io_task_callback(
IO_TASK_TYPE type, IO_TASK_TYPE type,
PORT* port, PORT* port,

1
native/primitives.c
View File

@ -129,6 +129,7 @@ XT primitives[] = {
primitive_can_write, primitive_can_write,
primitive_add_write_io_task, primitive_add_write_io_task,
primitive_write_8, primitive_write_8,
primitive_add_copy_io_task,
primitive_next_io_task, primitive_next_io_task,
primitive_room, primitive_room,
primitive_os_env, primitive_os_env,

2
native/primitives.h
View File

@ -1,4 +1,4 @@
extern XT primitives[]; extern XT primitives[];
#define PRIMITIVE_COUNT 140 #define PRIMITIVE_COUNT 141
CELL primitive_to_xt(CELL primitive); CELL primitive_to_xt(CELL primitive);

11
native/read.c
View File

@ -107,12 +107,12 @@ void primitive_can_read_line(void)
void primitive_add_read_line_io_task(void) void primitive_add_read_line_io_task(void)
{ {
PORT* port = untag_port(dpop());
CELL callback = dpop(); CELL callback = dpop();
add_io_task(IO_TASK_READ_LINE,port,callback, CELL port = dpop();
add_io_task(IO_TASK_READ_LINE,port,F,callback,
read_io_tasks,&read_fd_count); read_io_tasks,&read_fd_count);
init_line_buffer(port,LINE_SIZE); init_line_buffer(untag_port(port),LINE_SIZE);
} }
bool perform_read_line_io_task(PORT* port) bool perform_read_line_io_task(PORT* port)
@ -206,10 +206,11 @@ void primitive_can_read_count(void)
void primitive_add_read_count_io_task(void) void primitive_add_read_count_io_task(void)
{ {
CELL callback = dpop();
PORT* port = untag_port(dpop()); PORT* port = untag_port(dpop());
FIXNUM count = to_fixnum(dpop()); FIXNUM count = to_fixnum(dpop());
CELL callback = dpop(); add_io_task(IO_TASK_READ_COUNT,
add_io_task(IO_TASK_READ_COUNT,port,callback, tag_object(port),F,callback,
read_io_tasks,&read_fd_count); read_io_tasks,&read_fd_count);
port->count = count; port->count = count;

8
native/socket.c
View File

@ -94,6 +94,14 @@ void primitive_server_socket(void)
dpush(tag_object(port(PORT_SPECIAL,make_server_socket(p)))); dpush(tag_object(port(PORT_SPECIAL,make_server_socket(p))));
} }
void primitive_add_accept_io_task(void)
{
CELL callback = dpop();
CELL port = dpop();
add_io_task(IO_TASK_ACCEPT,port,F,callback,
read_io_tasks,&read_fd_count);
}
CELL accept_connection(PORT* p) CELL accept_connection(PORT* p)
{ {
struct sockaddr_in clientname; struct sockaddr_in clientname;

1
native/socket.h
View File

@ -4,5 +4,6 @@ int make_client_socket(const char* hostname, uint16_t port);
void primitive_client_socket(void); void primitive_client_socket(void);
int make_server_socket(uint16_t port); int make_server_socket(uint16_t port);
void primitive_server_socket(void); void primitive_server_socket(void);
void primitive_add_accept_io_task(void);
CELL accept_connection(PORT* p); CELL accept_connection(PORT* p);
void primitive_accept_fd(void); void primitive_accept_fd(void);

25
native/write.c
View File

@ -56,9 +56,9 @@ void primitive_can_write(void)
void primitive_add_write_io_task(void) void primitive_add_write_io_task(void)
{ {
PORT* port = untag_port(dpop());
CELL callback = dpop(); CELL callback = dpop();
add_io_task(IO_TASK_WRITE,port,callback, CELL port = dpop();
add_io_task(IO_TASK_WRITE,port,F,callback,
write_io_tasks,&write_fd_count); write_io_tasks,&write_fd_count);
} }
@ -89,6 +89,16 @@ void write_char_8(PORT* port, FIXNUM ch)
port->buf_fill++; port->buf_fill++;
} }
/* Caller must ensure buffer is of the right size. */
void write_string_raw(PORT* port, char* str, CELL len)
{
/* Append string to buffer */
memcpy((void*)((CELL)port->buffer + sizeof(STRING)
+ port->buf_fill),str,len);
port->buf_fill += len;
}
void write_string_8(PORT* port, STRING* str) void write_string_8(PORT* port, STRING* str)
{ {
char* c_str; char* c_str;
@ -98,12 +108,7 @@ void write_string_8(PORT* port, STRING* str)
io_error(__FUNCTION__); io_error(__FUNCTION__);
c_str = to_c_string(str); c_str = to_c_string(str);
write_string_raw(port,c_str,str->capacity);
/* Append string to buffer */
memcpy((void*)((CELL)port->buffer + sizeof(STRING)
+ port->buf_fill),c_str,str->capacity);
port->buf_fill += str->capacity;
} }
void primitive_write_8(void) void primitive_write_8(void)
@ -112,6 +117,7 @@ void primitive_write_8(void)
CELL text = dpop(); CELL text = dpop();
CELL type = type_of(text); CELL type = type_of(text);
STRING* str;
pending_io_error(port); pending_io_error(port);
@ -122,7 +128,8 @@ void primitive_write_8(void)
write_char_8(port,to_fixnum(text)); write_char_8(port,to_fixnum(text));
break; break;
case STRING_TYPE: case STRING_TYPE:
write_string_8(port,untag_string(text)); str = untag_string(text);
write_string_8(port,str);
break; break;
default: default:
type_error(STRING_TYPE,text); type_error(STRING_TYPE,text);

1
native/write.h
View File

@ -4,5 +4,6 @@ void primitive_can_write(void);
void primitive_add_write_io_task(void); void primitive_add_write_io_task(void);
bool perform_write_io_task(PORT* port); bool perform_write_io_task(PORT* port);
void write_char_8(PORT* port, FIXNUM ch); void write_char_8(PORT* port, FIXNUM ch);
void write_string_raw(PORT* port, char* str, CELL len);
void write_string_8(PORT* port, STRING* str); void write_string_8(PORT* port, STRING* str);
void primitive_write_8(void); void primitive_write_8(void);