unroff/src/prim.c

383 lines
9.7 KiB
C

/* $Revision: 1.19 $
*/
/* The implementation of those Scheme primitives that do not deal with
* events, tables, streams, expressions, substitutions, and file
* insertions.
*/
#include "unroff.h"
static Object error_port;
static Object p_error_port(void) {
return error_port;
}
static Object p_read_line_expand(void) {
Buffer *ip, *op;
Object ret;
ip = buffer_new(0);
op = buffer_new(0);
if (safe_readline(ip) && ip->size == 0) {
ret = Eof;
} else {
(void)parse_expand(ip, op);
ret = Make_String(op->data, op->size);
}
buffer_delete(ip);
buffer_delete(op);
return ret;
}
static Object p_read_line(void) {
Buffer *ip;
Object ret;
ip = buffer_new(0);
if (safe_readline(ip) && ip->size == 0) {
ret = Eof;
} else
ret = Make_String(ip->data, ip->size);
buffer_delete(ip);
return ret;
}
static Object primitive_parse(int ac, Object *av, int what) {
Buffer *ip, *op;
Object ret;
ip = buffer_new(0);
op = buffer_new(0);
while (ac-- > 0) {
Object x = *av++;
switch (TYPE(x)) {
case T_Character:
buffer_putc(ip, CHAR(x));
break;
case T_Symbol:
x = SYMBOL(x)->name; /* fall through */
case T_String:
buffer_puts(ip, STRING(x)->data, STRING(x)->size);
break;
default:
Primitive_Error("cannot coerce argument to string");
}
}
switch (what) {
case 'c': parse_escape(ip, op, 1, 1); break;
case 'p': parse_escape(ip, op, 1, 0); break;
case 't': parse_escape(ip, op, 0, 0); break;
case 'l': parse_line(ip, op); break;
case 'e': parse_expand(ip, op); break;
}
ret = what == 'l' ? Void : Make_String(op->data, op->size);
buffer_delete(ip);
buffer_delete(op);
return ret;
}
static Object p_parse(int ac, Object *av) {
return primitive_parse(ac, av, 'p');
}
static Object p_translate(int ac, Object *av) {
return primitive_parse(ac, av, 't');
}
static Object p_parse_line(int ac, Object *av) {
return primitive_parse(ac, av, 'l');
}
static Object p_parse_copy_mode(int ac, Object *av) {
return primitive_parse(ac, av, 'c');
}
static Object p_parse_expand(int ac, Object *av) {
return primitive_parse(ac, av, 'e');
}
static Object concat(int ac, Object *av, int spread) {
Buffer *op;
Object ret;
op = buffer_new(0);
while (ac-- > 0) {
Object x = *av++;
switch (TYPE(x)) {
case T_Character:
buffer_putc(op, CHAR(x));
break;
case T_Symbol:
x = SYMBOL(x)->name; /* fall through */
case T_String:
buffer_puts(op, STRING(x)->data, STRING(x)->size);
break;
default:
Primitive_Error("cannot coerce argument to string");
}
if (spread && ac > 0)
buffer_putc(op, ' ')
}
ret = Make_String(op->data, op->size);
buffer_delete(op);
return ret;
}
static Object p_concat(int ac, Object *av) {
return concat(ac, av, 0);
}
static Object p_spread(int ac, Object *av) {
return concat(ac, av, 1);
}
static Object p_emit(int ac, Object *av) {
while (ac-- > 0) {
Object x = *av++;
switch (TYPE(x)) {
case T_Character:
safe_write_char(CHAR(x));
break;
case T_Symbol:
x = SYMBOL(x)->name; /* fall through */
case T_String:
safe_write(STRING(x)->data, STRING(x)->size);
break;
default:
Primitive_Error("cannot coerce argument to string");
}
}
return Void;
}
static Object p_shell_command(Object cmd) {
return Make_Integer(system(Get_Strsym(cmd)));
}
static Object p_remove_file(Object fn) {
char *s = Get_Strsym(fn);
if (remove(s)) warn("cannot remove file `%s'", s);
return Void;
}
static Object p_parse_pair(Object x) {
char *p, *ep, *s1, *s2, delim;
Object str, ret;
GC_Node3;
str = ret = False;
GC_Link3(x, str, ret);
Check_Type(x, T_String);
p = STRING(x)->data;
ep = p + STRING(x)->size;
if (p <= ep-3) {
delim = *p++;
for (s1 = p; p < ep && *p != delim; p++)
;
if (p < ep) {
for (s2 = ++p; p < ep && *p != delim; p++)
;
if (p == ep-1) {
str = Make_String(s1, s2-s1-1);
ret = Cons(str, Null);
str = Make_String(s2, p-s2);
Cdr(ret) = str;
}
}
}
GC_Unlink;
return ret;
}
static Object p_parse_triple(Object x) {
char *p, *ep, *s1, *s2, *s3, delim;
Object str, ret;
GC_Node3;
str = ret = False;
GC_Link3(x, str, ret);
Check_Type(x, T_String);
p = STRING(x)->data;
ep = p + STRING(x)->size;
if (p <= ep-4) {
delim = *p++;
for (s1 = p; p < ep && *p != delim; p++)
;
if (p < ep) {
for (s2 = ++p; p < ep && *p != delim; p++)
;
if (p < ep) {
for (s3 = ++p; p < ep && *p != delim; p++)
;
if (p == ep-1) {
str = Make_String(s3, p-s3);
ret = Cons(Null, str);
str = Make_String(s2, s3-s2-1);
Car(ret) = str;
ret = Cons(Null, ret);
str = Make_String(s1, s2-s1-1);
Car(ret) = str;
}
}
}
}
GC_Unlink;
return ret;
}
static Object p_skip_group(void) {
Buffer *ip;
int level = 0;
char *p, *ep;
ip = buffer_new(0);
do {
if (safe_readline(ip) && ip->size == 0) {
warn("end-of-scream while skipping requests");
break;
}
for (p = ip->data, ep = p + ip->size; p < ep-2; p++)
if (*p == escape)
if (*++p == '{') level++;
else if (*p == '}') level--;
buffer_clear(ip);
} while (level > 0);
buffer_delete(ip);
return Void;
}
static Object p_set_escape(Object c) {
Check_Type(c, T_Character);
escape = CHAR(c);
return Void;
}
static Object p_troff_compatible(void) {
extern int compatible;
return compatible ? True : False;
}
static Object p_string_prune_left(Object str, Object pref, Object fail) {
int l1, l2;
Check_Type(str, T_String);
Check_Type(pref, T_String);
l1 = STRING(str)->size, l2 = STRING(pref)->size;
if (l2 <= l1 && memcmp(STRING(str)->data, STRING(pref)->data, l2) == 0)
return Make_String(STRING(str)->data+l2, l1-l2);
return fail;
}
static Object p_string_prune_right(Object str, Object suff, Object fail) {
int l1, l2, l;
Check_Type(str, T_String);
Check_Type(suff, T_String);
l1 = STRING(str)->size, l2 = STRING(suff)->size, l = l1-l2;
if (l >= 0 && memcmp(STRING(str)->data+l, STRING(suff)->data, l2) == 0)
return Make_String(STRING(str)->data, l);
return fail;
}
static Object p_string_compose(Object old, Object new) {
Buffer *bp;
struct S_String *s, *t;
int i;
Object ret;
bp = buffer_new(0);
Check_Type(old, T_String);
Check_Type(new, T_String);
s = STRING(old), t = STRING(new);
if (t->size > 0) {
switch (t->data[0]) {
case '+':
buffer_puts(bp, s->data, s->size);
buffer_puts(bp, t->data+1, t->size-1);
break;
case '-':
for (i = 0; i < s->size; i++)
if (!memchr(t->data, s->data[i], t->size))
buffer_putc(bp, s->data[i]);
break;
default:
buffer_puts(bp, t->data, t->size);
}
}
ret = Make_String(bp->data, bp->size);
buffer_delete(bp);
return ret;
}
static Object p_repeat_string(Object num, Object str) {
Buffer *bp;
Object ret;
int n;
Check_Type(str, T_String);
bp = buffer_new(0);
for (n = Get_Integer(num); n > 0; n--)
buffer_puts(bp, STRING(str)->data, STRING(str)->size);
ret = Make_String(bp->data, bp->size);
buffer_delete(bp);
return ret;
}
static Object p_filter_eqn_line(Object str) {
char *p, *q, *ep;
Check_Type(str, T_String);
p = STRING(str)->data, ep = p + STRING(str)->size;
for ( ; p < ep && isspace(UCHAR(*p)); p++)
;
if (p == ep)
return False;
for (q = p; p < ep && !isspace(UCHAR(*p)); p++)
;
if (p == ep)
return True;
if (p-q == 5 && strncmp(q, "delim", 5) == 0) {
p++;
if (ep-p == 3 && strncmp(p, "off", 3) == 0)
eqn_delim1 = 0;
else if (ep-p >= 2)
eqn_delim1 = *p, eqn_delim2 = p[1];
return False;
}
return p-q == 6 && strncmp(q, "define", 6) == 0 ? False : True;
}
void init_prim(void) {
error_port = Make_Port (0, stderr, Make_String ("stderr", 6));
if (setvbuf(stderr, 0, _IOLBF, BUFSIZ) != 0)
fatal_error("cannot set stderr line buffered");
Global_GC_Link(error_port);
Define_Primitive(p_error_port, "error-port", 0, 0, EVAL);
Define_Primitive(p_read_line, "read-line", 0, 0, EVAL);
Define_Primitive(p_read_line_expand, "read-line-expand", 0, 0, EVAL);
Define_Primitive(p_parse, "parse", 0, MANY, VARARGS);
Define_Primitive(p_parse_copy_mode, "parse-copy-mode", 0, MANY, VARARGS);
Define_Primitive(p_parse_line, "parse-line", 0, MANY, VARARGS);
Define_Primitive(p_parse_expand, "parse-expand", 0, MANY, VARARGS);
Define_Primitive(p_translate, "translate", 0, MANY, VARARGS);
Define_Primitive(p_concat, "concat", 0, MANY, VARARGS);
Define_Primitive(p_spread, "spread", 0, MANY, VARARGS);
Define_Primitive(p_emit, "emit", 0, MANY, VARARGS);
Define_Primitive(p_substitute, "substitute", 1, MANY, VARARGS);
Define_Primitive(p_shell_command, "shell-command", 1, 1, EVAL);
Define_Primitive(p_remove_file, "remove-file", 1, 1, EVAL);
Define_Primitive(p_parse_pair, "parse-pair", 1, 1, EVAL);
Define_Primitive(p_parse_triple, "parse-triple", 1, 1, EVAL);
Define_Primitive(p_skip_group, "skip-group", 0, 0, EVAL);
Define_Primitive(p_set_escape, "set-escape!", 1, 1, EVAL);
Define_Primitive(p_troff_compatible, "troff-compatible?", 0, 0, EVAL);
Define_Primitive(p_string_prune_left, "string-prune-left", 3, 3, EVAL);
Define_Primitive(p_string_prune_right,"string-prune-right", 3, 3, EVAL);
Define_Primitive(p_string_compose, "string-compose", 2, 2, EVAL);
Define_Primitive(p_repeat_string, "repeat-string", 2, 2, EVAL);
Define_Primitive(p_filter_eqn_line, "filter-eqn-line", 1, 1, EVAL);
}