385 lines
9.7 KiB
C
385 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);
|
|
}
|