154 lines
3.6 KiB
C
154 lines
3.6 KiB
C
/*
|
|
* v p o r t . c -- Virtual ports management
|
|
*
|
|
* Copyright © 1998-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
*
|
|
*
|
|
* Permission to use, copy, modify, distribute,and license this
|
|
* software and its documentation for any purpose is hereby granted,
|
|
* provided that existing copyright notices are retained in all
|
|
* copies and that this notice is included verbatim in any
|
|
* distributions. No written agreement, license, or royalty fee is
|
|
* required for any of the authorized uses.
|
|
* This software is provided ``AS IS'' without express or implied
|
|
* warranty.
|
|
*
|
|
*
|
|
* Author: Erick Gallesio [eg@unice.fr]
|
|
* Creation date: 26-Oct-1998 15:55
|
|
* Last file update: 3-Sep-1999 21:02 (eg)
|
|
*
|
|
*/
|
|
|
|
#include "stk.h"
|
|
#include "vport.h"
|
|
|
|
|
|
static void verify_param(char *proc_name, SCM proc, int pos)
|
|
{
|
|
if (proc != Ntruth && STk_procedurep(proc) != Truth)
|
|
Serror("Uncorrect procedure at position", STk_makeinteger(pos));
|
|
}
|
|
|
|
|
|
void STk_mark_virtual_port(SCM port)
|
|
{
|
|
struct virtual_iob *p;
|
|
|
|
p = (struct virtual_iob *) PORT_FILE(port);
|
|
STk_gc_mark(p->getc);
|
|
STk_gc_mark(p->readyp);
|
|
STk_gc_mark(p->eofp);
|
|
STk_gc_mark(p->close);
|
|
STk_gc_mark(p->putc);
|
|
STk_gc_mark(p->puts);
|
|
STk_gc_mark(p->flush);
|
|
}
|
|
|
|
void STk_free_virtual_port(SCM port)
|
|
{
|
|
struct virtual_iob *p;
|
|
|
|
p = (struct virtual_iob *) PORT_FILE(port);
|
|
free(p);
|
|
free(port->storage_as.port.p);
|
|
}
|
|
|
|
|
|
PRIMITIVE STk_open_input_virtual(SCM l, int len)
|
|
{
|
|
struct virtual_iob *p;
|
|
SCM getc, readyp, eofp, close, z;
|
|
|
|
ENTER_PRIMITIVE("open-input-virtual");
|
|
|
|
if (len != 4) Serror("bad number of arguments", l);
|
|
getc = CAR(l);
|
|
readyp = CAR(CDR(l));
|
|
eofp = CAR(CDR(CDR(l)));
|
|
close = CAR(CDR(CDR(CDR(l))));
|
|
|
|
verify_param(proc_name, getc, 1);
|
|
verify_param(proc_name, readyp, 2);
|
|
verify_param(proc_name, eofp, 3);
|
|
verify_param(proc_name, close, 4);
|
|
|
|
p = (struct virtual_iob *) must_malloc(sizeof (struct virtual_iob));
|
|
|
|
p->signature = VPORT_SIGNATURE;
|
|
p->flag = READING;
|
|
p->ungetted = EOF;
|
|
p->getc = getc;
|
|
p->readyp = readyp;
|
|
p->eofp = eofp;
|
|
p->close = close;
|
|
p->putc = Ntruth;
|
|
p->puts = Ntruth;
|
|
p->flush = Ntruth;
|
|
|
|
/* Vport_descr is a short version of a port_descr */
|
|
NEWCELL(z, tc_ivport);
|
|
z->storage_as.port.p = (struct port_descr *)
|
|
must_malloc(sizeof(struct vport_descr));
|
|
PORT_UNGETC(z) = EOF;
|
|
PORT_FILE(z) = (FILE *) p;
|
|
PORT_FLAGS(z) = 0;
|
|
|
|
return z;
|
|
}
|
|
|
|
PRIMITIVE STk_open_output_virtual(SCM l, int len)
|
|
{
|
|
struct virtual_iob *p;
|
|
SCM putc, puts, flush, close, z;
|
|
|
|
ENTER_PRIMITIVE("open-output-virtual");
|
|
|
|
if (len != 4) Serror("bad number of arguments", l);
|
|
putc = CAR(l);
|
|
puts = CAR(CDR(l));
|
|
flush = CAR(CDR(CDR(l)));
|
|
close = CAR(CDR(CDR(CDR(l))));
|
|
|
|
verify_param(proc_name, putc, 1);
|
|
verify_param(proc_name, puts, 2);
|
|
verify_param(proc_name, flush, 3);
|
|
verify_param(proc_name, close, 4);
|
|
|
|
p = (struct virtual_iob *) must_malloc(sizeof (struct virtual_iob));
|
|
|
|
p->signature = VPORT_SIGNATURE;
|
|
p->flag = WRITING;
|
|
p->ungetted = EOF;
|
|
p->getc = Ntruth;
|
|
p->readyp = Ntruth;
|
|
p->eofp = Ntruth;
|
|
p->close = close;
|
|
p->putc = putc;
|
|
p->puts = puts;
|
|
p->flush = flush;
|
|
|
|
/* Vport_descr is a short version of a port_descr */
|
|
NEWCELL(z, tc_ovport);
|
|
z->storage_as.port.p = (struct port_descr *)
|
|
must_malloc(sizeof(struct vport_descr));
|
|
PORT_UNGETC(z) = EOF;
|
|
PORT_FILE(z) = (FILE *) p;
|
|
PORT_FLAGS(z) = 0;
|
|
|
|
return z;
|
|
}
|
|
|
|
|
|
PRIMITIVE STk_input_virtual_portp(SCM port)
|
|
{
|
|
return (IVPORTP(port)) ? Truth: Ntruth;
|
|
}
|
|
|
|
PRIMITIVE STk_output_virtual_portp(SCM port)
|
|
{
|
|
return (OVPORTP(port)) ? Truth: Ntruth;
|
|
}
|
|
|
|
|