From 0a193e032ba1ecf3f003e027e833dc9d274cb740 Mon Sep 17 00:00:00 2001 From: Kaleb Keithley Date: Fri, 14 Nov 2003 16:49:22 +0000 Subject: Initial revision --- lisp/helper.c | 1124 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1124 insertions(+) create mode 100644 lisp/helper.c (limited to 'lisp/helper.c') diff --git a/lisp/helper.c b/lisp/helper.c new file mode 100644 index 0000000..65749c5 --- /dev/null +++ b/lisp/helper.c @@ -0,0 +1,1124 @@ +/* + * Copyright (c) 2001 by The XFree86 Project, Inc. + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL + * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, + * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF + * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + * + * Except as contained in this notice, the name of the XFree86 Project shall + * not be used in advertising or otherwise to promote the sale, use or other + * dealings in this Software without prior written authorization from the + * XFree86 Project. + * + * Author: Paulo César Pereira de Andrade + */ + +/* $XFree86: xc/programs/xedit/lisp/helper.c,v 1.47 2002/11/26 04:06:28 paulo Exp $ */ + +#include "helper.h" +#include "pathname.h" +#include "package.h" +#include "read.h" +#include "stream.h" +#include "write.h" +#include "hash.h" +#include +#include +#include +#include +#include + +/* + * Prototypes + */ +static LispObj *LispReallyDo(LispBuiltin*, int); +static LispObj *LispReallyDoListTimes(LispBuiltin*, int); + +/* in math.c */ +extern LispObj *LispFloatCoerce(LispBuiltin*, LispObj*); + +/* + * Implementation + */ +LispObj * +LispObjectCompare(LispObj *left, LispObj *right, int function) +{ + LispType ltype, rtype; + LispObj *result = left == right ? T : NIL; + + /* If left and right are the same object, or if function is EQ */ + if (result == T || function == FEQ) + return (result); + + ltype = OBJECT_TYPE(left); + rtype = OBJECT_TYPE(right); + + /* Equalp requires that numeric objects be compared by value, and + * strings or characters comparison be case insenstive */ + if (function == FEQUALP) { + switch (ltype) { + case LispFixnum_t: + case LispInteger_t: + case LispBignum_t: + case LispDFloat_t: + case LispRatio_t: + case LispBigratio_t: + case LispComplex_t: + switch (rtype) { + case LispFixnum_t: + case LispInteger_t: + case LispBignum_t: + case LispDFloat_t: + case LispRatio_t: + case LispBigratio_t: + case LispComplex_t: + result = APPLY2(Oequal_, left, right); + break; + default: + break; + } + goto compare_done; + case LispSChar_t: + if (rtype == LispSChar_t && + toupper(SCHAR_VALUE(left)) == toupper(SCHAR_VALUE(right))) + result = T; + goto compare_done; + case LispString_t: + if (rtype == LispString_t && STRLEN(left) == STRLEN(right)) { + long i = STRLEN(left); + char *sl = THESTR(left), *sr = THESTR(right); + + for (--i; i >= 0; i--) + if (toupper(sl[i]) != toupper(sr[i])) + break; + if (i < 0) + result = T; + } + goto compare_done; + case LispArray_t: + if (rtype == LispArray_t && + left->data.array.type == right->data.array.type && + left->data.array.rank == right->data.array.rank && + LispObjectCompare(left->data.array.dim, + right->data.array.dim, + FEQUAL) != NIL) { + LispObj *llist = left->data.array.list, + *rlist = right->data.array.list; + + for (; CONSP(llist); llist = CDR(llist), rlist = CDR(rlist)) + if (LispObjectCompare(CAR(llist), CAR(rlist), + FEQUALP) == NIL) + break; + if (!CONSP(llist)) + result = T; + } + goto compare_done; + case LispStruct_t: + if (rtype == LispStruct_t && + left->data.struc.def == right->data.struc.def) { + LispObj *lfield = left->data.struc.fields, + *rfield = right->data.struc.fields; + + for (; CONSP(lfield); + lfield = CDR(lfield), rfield = CDR(rfield)) { + if (LispObjectCompare(CAR(lfield), CAR(rfield), + FEQUALP) != T) + break; + } + if (!CONSP(lfield)) + result = T; + } + goto compare_done; + case LispHashTable_t: + if (rtype == LispHashTable_t && + left->data.hash.table->count == + right->data.hash.table->count && + left->data.hash.test == right->data.hash.test) { + unsigned long i; + LispObj *test = left->data.hash.test; + LispHashEntry *lentry = left->data.hash.table->entries, + *llast = lentry + + left->data.hash.table->num_entries, + *rentry = right->data.hash.table->entries; + + for (; lentry < llast; lentry++, rentry++) { + if (lentry->count != rentry->count) + break; + for (i = 0; i < lentry->count; i++) { + if (APPLY2(test, + lentry->keys[i], + rentry->keys[i]) == NIL || + LispObjectCompare(lentry->values[i], + rentry->values[i], + FEQUALP) == NIL) + break; + } + if (i < lentry->count) + break; + } + if (lentry == llast) + result = T; + } + goto compare_done; + default: + break; + } + } + + /* Function is EQL or EQUAL, or EQUALP on arguments with the same rules */ + if (ltype == rtype) { + switch (ltype) { + case LispFixnum_t: + case LispSChar_t: + if (FIXNUM_VALUE(left) == FIXNUM_VALUE(right)) + result = T; + break; + case LispInteger_t: + if (INT_VALUE(left) == INT_VALUE(right)) + result = T; + break; + case LispDFloat_t: + if (DFLOAT_VALUE(left) == DFLOAT_VALUE(right)) + result = T; + break; + case LispRatio_t: + if (left->data.ratio.numerator == + right->data.ratio.numerator && + left->data.ratio.denominator == + right->data.ratio.denominator) + result = T; + break; + case LispComplex_t: + if (LispObjectCompare(left->data.complex.real, + right->data.complex.real, + function) == T && + LispObjectCompare(left->data.complex.imag, + right->data.complex.imag, + function) == T) + result = T; + break; + case LispBignum_t: + if (mpi_cmp(left->data.mp.integer, right->data.mp.integer) == 0) + result = T; + break; + case LispBigratio_t: + if (mpr_cmp(left->data.mp.ratio, right->data.mp.ratio) == 0) + result = T; + break; + default: + break; + } + + /* Next types must be the same object for EQL */ + if (function == FEQL) + goto compare_done; + + switch (ltype) { + case LispString_t: + if (STRLEN(left) == STRLEN(right) && + memcmp(THESTR(left), THESTR(right), STRLEN(left)) == 0) + result = T; + break; + case LispCons_t: + if (LispObjectCompare(CAR(left), CAR(right), function) == T && + LispObjectCompare(CDR(left), CDR(right), function) == T) + result = T; + break; + case LispQuote_t: + case LispBackquote_t: + case LispPathname_t: + result = LispObjectCompare(left->data.pathname, + right->data.pathname, function); + break; + case LispLambda_t: + result = LispObjectCompare(left->data.lambda.name, + right->data.lambda.name, + function); + break; + case LispOpaque_t: + if (left->data.opaque.data == right->data.opaque.data) + result = T; + break; + case LispRegex_t: + /* If the regexs are guaranteed to generate the same matches */ + if (left->data.regex.options == right->data.regex.options) + result = LispObjectCompare(left->data.regex.pattern, + right->data.regex.pattern, + function); + break; + default: + break; + } + } + +compare_done: + return (result); +} + +void +LispCheckSequenceStartEnd(LispBuiltin *builtin, + LispObj *sequence, LispObj *start, LispObj *end, + long *pstart, long *pend, long *plength) +{ + /* Calculate length of sequence and check it's type */ + *plength = LispLength(sequence); + + /* Check start argument */ + if (start == UNSPEC || start == NIL) + *pstart = 0; + else { + CHECK_INDEX(start); + *pstart = FIXNUM_VALUE(start); + } + + /* Check end argument */ + if (end == UNSPEC || end == NIL) + *pend = *plength; + else { + CHECK_INDEX(end); + *pend = FIXNUM_VALUE(end); + } + + /* Check start argument */ + if (*pstart > *pend) + LispDestroy("%s: :START %ld is larger than :END %ld", + STRFUN(builtin), *pstart, *pend); + + /* Check end argument */ + if (*pend > *plength) + LispDestroy("%s: :END %ld is larger then sequence length %ld", + STRFUN(builtin), *pend, *plength); +} + +long +LispLength(LispObj *sequence) +{ + long length; + + if (sequence == NIL) + return (0); + switch (OBJECT_TYPE(sequence)) { + case LispString_t: + length = STRLEN(sequence); + break; + case LispArray_t: + if (sequence->data.array.rank != 1) + goto not_a_sequence; + sequence = sequence->data.array.list; + /*FALLTROUGH*/ + case LispCons_t: + for (length = 0; + CONSP(sequence); + length++, sequence = CDR(sequence)) + ; + break; + default: +not_a_sequence: + LispDestroy("LENGTH: %s is not a sequence", STROBJ(sequence)); + /*NOTREACHED*/ + length = 0; + } + + return (length); +} + +LispObj * +LispCharacterCoerce(LispBuiltin *builtin, LispObj *object) +{ + if (SCHARP(object)) + return (object); + else if (STRINGP(object) && STRLEN(object) == 1) + return (SCHAR(THESTR(object)[0])); + else if (SYMBOLP(object) && ATOMID(object)[1] == '\0') + return (SCHAR(ATOMID(object)[0])); + else if (INDEXP(object)) { + int c = FIXNUM_VALUE(object); + + if (c <= 0xff) + return (SCHAR(c)); + } + else if (object == T) + return (SCHAR('T')); + + LispDestroy("%s: cannot convert %s to character", + STRFUN(builtin), STROBJ(object)); + /*NOTREACHED*/ + return (NIL); +} + +LispObj * +LispStringCoerce(LispBuiltin *builtin, LispObj *object) +{ + if (STRINGP(object)) + return (object); + else if (SYMBOLP(object)) + return (LispSymbolName(object)); + else if (SCHARP(object)) { + char string[1]; + + string[0] = SCHAR_VALUE(object); + return (LSTRING(string, 1)); + } + else if (object == NIL) + return (LSTRING(Snil, 3)); + else if (object == T) + return (LSTRING(St, 1)); + else + LispDestroy("%s: cannot convert %s to string", + STRFUN(builtin), STROBJ(object)); + /*NOTREACHED*/ + return (NIL); +} + +LispObj * +LispCoerce(LispBuiltin *builtin, + LispObj *object, LispObj *result_type) +{ + LispObj *result = NIL; + LispType type = LispNil_t; + + if (result_type == NIL) + /* not even NIL can be converted to NIL? */ + LispDestroy("%s: cannot convert %s to NIL", + STRFUN(builtin), STROBJ(object)); + + else if (result_type == T) + /* no conversion */ + return (object); + + else if (!SYMBOLP(result_type)) + /* only know about simple types */ + LispDestroy("%s: bad argument %s", + STRFUN(builtin), STROBJ(result_type)); + + else { + /* check all known types */ + + Atom_id atom = ATOMID(result_type); + + if (atom == Satom) { + if (CONSP(object)) + goto coerce_fail; + return (object); + } + /* only convert ATOM to SYMBOL */ + + if (atom == Sfloat) + type = LispDFloat_t; + else if (atom == Sinteger) + type = LispInteger_t; + else if (atom == Scons || atom == Slist) { + if (object == NIL) + return (object); + type = LispCons_t; + } + else if (atom == Sstring) + type = LispString_t; + else if (atom == Scharacter) + type = LispSChar_t; + else if (atom == Scomplex) + type = LispComplex_t; + else if (atom == Svector || atom == Sarray) + type = LispArray_t; + else if (atom == Sopaque) + type = LispOpaque_t; + else if (atom == Srational) + type = LispRatio_t; + else if (atom == Spathname) + type = LispPathname_t; + else + LispDestroy("%s: invalid type specification %s", + STRFUN(builtin), ATOMID(result_type)); + } + + if (OBJECT_TYPE(object) == LispOpaque_t) { + switch (type) { + case LispAtom_t: + result = ATOM(object->data.opaque.data); + break; + case LispString_t: + result = STRING(object->data.opaque.data); + break; + case LispSChar_t: + result = SCHAR((unsigned long)object->data.opaque.data); + break; + case LispDFloat_t: + result = DFLOAT((double)((long)object->data.opaque.data)); + break; + case LispInteger_t: + result = INTEGER(((long)object->data.opaque.data)); + break; + case LispOpaque_t: + result = OPAQUE(object->data.opaque.data, 0); + break; + default: + goto coerce_fail; + break; + } + } + + else if (OBJECT_TYPE(object) != type) { + switch (type) { + case LispInteger_t: + if (INTEGERP(object)) + result = object; + else if (DFLOATP(object)) { + if ((long)DFLOAT_VALUE(object) == DFLOAT_VALUE(object)) + result = INTEGER((long)DFLOAT_VALUE(object)); + else { + mpi *integer = LispMalloc(sizeof(mpi)); + + mpi_init(integer); + mpi_setd(integer, DFLOAT_VALUE(object)); + if (mpi_getd(integer) != DFLOAT_VALUE(object)) { + mpi_clear(integer); + LispFree(integer); + goto coerce_fail; + } + result = BIGNUM(integer); + } + } + else + goto coerce_fail; + break; + case LispRatio_t: + if (DFLOATP(object)) { + mpr *ratio = LispMalloc(sizeof(mpr)); + + mpr_init(ratio); + mpr_setd(ratio, DFLOAT_VALUE(object)); + if (mpr_fiti(ratio)) { + result = RATIO(mpi_geti(mpr_num(ratio)), + mpi_geti(mpr_den(ratio))); + mpr_clear(ratio); + LispFree(ratio); + } + else + result = BIGRATIO(ratio); + } + else if (RATIONALP(object)) + result = object; + else + goto coerce_fail; + break; + case LispDFloat_t: + result = LispFloatCoerce(builtin, object); + break; + case LispComplex_t: + if (NUMBERP(object)) + result = object; + else + goto coerce_fail; + break; + case LispString_t: + if (object == NIL) + result = STRING(""); + else + result = LispStringCoerce(builtin, object); + break; + case LispSChar_t: + result = LispCharacterCoerce(builtin, object); + break; + case LispArray_t: + if (LISTP(object)) + result = VECTOR(object); + else + goto coerce_fail; + break; + case LispCons_t: + if (ARRAYP(object) && object->data.array.rank == 1) + result = object->data.array.list; + else + goto coerce_fail; + break; + case LispPathname_t: + result = APPLY1(Oparse_namestring, object); + break; + default: + goto coerce_fail; + } + } + else + result = object; + + return (result); + +coerce_fail: + LispDestroy("%s: cannot convert %s to %s", + STRFUN(builtin), STROBJ(object), ATOMID(result_type)); + /* NOTREACHED */ + return (NIL); +} + +static LispObj * +LispReallyDo(LispBuiltin *builtin, int refs) +/* + do init test &rest body + do* init test &rest body + */ +{ + GC_ENTER(); + int stack, lex, head; + LispObj *list, *symbol, *value, *values, *cons; + + LispObj *init, *test, *body; + + body = ARGUMENT(2); + test = ARGUMENT(1); + init = ARGUMENT(0); + + if (!CONSP(test)) + LispDestroy("%s: end test condition must be a list, not %s", + STRFUN(builtin), STROBJ(init)); + + CHECK_LIST(init); + + /* Save state */ + stack = lisp__data.stack.length; + lex = lisp__data.env.lex; + head = lisp__data.env.length; + + values = cons = NIL; + for (list = init; CONSP(list); list = CDR(list)) { + symbol = CAR(list); + if (!SYMBOLP(symbol)) { + CHECK_CONS(symbol); + value = CDR(symbol); + symbol = CAR(symbol); + CHECK_SYMBOL(symbol); + CHECK_CONS(value); + value = EVAL(CAR(value)); + } + else + value = NIL; + + CHECK_CONSTANT(symbol); + + LispAddVar(symbol, value); + + /* Bind variable now */ + if (refs) { + ++lisp__data.env.head; + } + else { + if (values == NIL) { + values = cons = CONS(NIL, NIL); + GC_PROTECT(values); + } + else { + RPLACD(cons, CONS(NIL, NIL)); + cons = CDR(cons); + } + } + } + if (!refs) + lisp__data.env.head = lisp__data.env.length; + + for (;;) { + if (EVAL(CAR(test)) != NIL) + break; + + /* TODO Run this code in an implicit tagbody */ + for (list = body; CONSP(list); list = CDR(list)) + (void)EVAL(CAR(list)); + + /* Error checking already done in the initialization */ + for (list = init, cons = values; CONSP(list); list = CDR(list)) { + symbol = CAR(list); + if (CONSP(symbol)) { + value = CDDR(symbol); + symbol = CAR(symbol); + if (CONSP(value)) + value = EVAL(CAR(value)); + else + value = NIL; + } + else + value = NIL; + + if (refs) + LispSetVar(symbol, value); + else { + RPLACA(cons, value); + cons = CDR(cons); + } + } + if (!refs) { + for (list = init, cons = values; + CONSP(list); + list = CDR(list), cons = CDR(cons)) { + symbol = CAR(list); + if (CONSP(symbol)) { + if (CONSP(CDR(symbol))) + LispSetVar(CAR(symbol), CAR(cons)); + } + } + } + } + + if (CONSP(CDR(test))) + value = EVAL(CADR(test)); + else + value = NIL; + + /* Restore state */ + lisp__data.stack.length = stack; + lisp__data.env.lex = lex; + lisp__data.env.head = lisp__data.env.length = head; + GC_LEAVE(); + + return (value); +} + +LispObj * +LispDo(LispBuiltin *builtin, int refs) +/* + do init test &rest body + do* init test &rest body + */ +{ + int jumped, *pjumped; + LispObj *result, **presult; + LispBlock *block; + + jumped = 1; + result = NIL; + presult = &result; + pjumped = &jumped; + block = LispBeginBlock(NIL, LispBlockTag); + if (setjmp(block->jmp) == 0) { + result = LispReallyDo(builtin, refs); + jumped = 0; + } + LispEndBlock(block); + if (jumped) + result = lisp__data.block.block_ret; + + return (result); +} + +static LispObj * +LispReallyDoListTimes(LispBuiltin *builtin, int times) +/* + dolist init &rest body + dotimes init &rest body + */ +{ + GC_ENTER(); + int head = lisp__data.env.length; + long count = 0, end = 0; + LispObj *symbol, *value = NIL, *result = NIL, *init, *body, *object; + + body = ARGUMENT(1); + init = ARGUMENT(0); + + /* Parse arguments */ + CHECK_CONS(init); + symbol = CAR(init); + CHECK_SYMBOL(symbol); + init = CDR(init); + + if (init == NIL) { + if (times) + LispDestroy("%s: NIL is not a number", STRFUN(builtin)); + } + else { + CHECK_CONS(init); + value = CAR(init); + init = CDR(init); + if (init != NIL) { + CHECK_CONS(init); + result = CAR(init); + } + + value = EVAL(value); + + if (times) { + CHECK_INDEX(value); + end = FIXNUM_VALUE(value); + } + else { + CHECK_LIST(value); + /* Protect iteration control from gc */ + GC_PROTECT(value); + } + } + + /* The variable is only bound inside the loop, so it is safe to optimize + * it out if there is no code to execute. But the result form may reference + * the bound variable. */ + if (!CONSP(body)) { + if (times) + count = end; + else + value = NIL; + } + + /* Initialize counter */ + CHECK_CONSTANT(symbol); + if (times) + LispAddVar(symbol, FIXNUM(count)); + else + LispAddVar(symbol, CONSP(value) ? CAR(value) : value); + ++lisp__data.env.head; + + if (!CONSP(body) || (times && count >= end) || (!times && !CONSP(value))) + goto loop_done; + + /* Execute iterations */ + for (;;) { + for (object = body; CONSP(object); object = CDR(object)) + (void)EVAL(CAR(object)); + + /* Update symbols and check exit condition */ + if (times) { + ++count; + LispSetVar(symbol, FIXNUM(count)); + if (count >= end) + break; + } + else { + value = CDR(value); + if (!CONSP(value)) { + LispSetVar(symbol, NIL); + break; + } + LispSetVar(symbol, CAR(value)); + } + } + +loop_done: + result = EVAL(result); + lisp__data.env.head = lisp__data.env.length = head; + GC_LEAVE(); + + return (result); +} + +LispObj * +LispDoListTimes(LispBuiltin *builtin, int times) +/* + dolist init &rest body + dotimes init &rest body + */ +{ + int did_jump, *pdid_jump = &did_jump; + LispObj *result, **presult = &result; + LispBlock *block; + + *presult = NIL; + *pdid_jump = 1; + block = LispBeginBlock(NIL, LispBlockTag); + if (setjmp(block->jmp) == 0) { + result = LispReallyDoListTimes(builtin, times); + did_jump = 0; + } + LispEndBlock(block); + if (did_jump) + result = lisp__data.block.block_ret; + + return (result); +} + +LispObj * +LispLoadFile(LispObj *filename, int verbose, int print, int ifdoesnotexist) +{ + LispObj *stream, *cod, *obj, *result; + int ch; + + LispObj *savepackage; + LispPackage *savepack; + + if (verbose) + LispMessage("; Loading %s", THESTR(filename)); + + if (ifdoesnotexist) { + GC_ENTER(); + result = CONS(filename, CONS(Kif_does_not_exist, CONS(Kerror, NIL))); + GC_PROTECT(result); + stream = APPLY(Oopen, result); + GC_LEAVE(); + } + else + stream = APPLY1(Oopen, filename); + + if (stream == NIL) + return (NIL); + + result = NIL; + LispPushInput(stream); + ch = LispGet(); + if (ch != '#') + LispUnget(ch); + else if ((ch = LispGet()) == '!') { + for (;;) { + ch = LispGet(); + if (ch == '\n' || ch == EOF) + break; + } + } + else { + LispUnget(ch); + LispUnget('#'); + } + + /* Save package environment */ + savepackage = PACKAGE; + savepack = lisp__data.pack; + + cod = COD; + + /*CONSTCOND*/ + while (1) { + if ((obj = LispRead()) != NULL) { + result = EVAL(obj); + COD = cod; + if (print) { + int i; + + if (RETURN_COUNT >= 0) + LispPrint(result, NIL, 1); + for (i = 0; i < RETURN_COUNT; i++) + LispPrint(RETURN(i), NIL, 1); + } + } + if (lisp__data.eof) + break; + } + LispPopInput(stream); + + /* Restore package environment */ + PACKAGE = savepackage; + lisp__data.pack = savepack; + + APPLY1(Oclose, stream); + + return (T); +} + +void +LispGetStringArgs(LispBuiltin *builtin, + char **string1, char **string2, + long *start1, long *end1, long *start2, long *end2) +{ + long length1, length2; + LispObj *ostring1, *ostring2, *ostart1, *oend1, *ostart2, *oend2; + + oend2 = ARGUMENT(5); + ostart2 = ARGUMENT(4); + oend1 = ARGUMENT(3); + ostart1 = ARGUMENT(2); + ostring2 = ARGUMENT(1); + ostring1 = ARGUMENT(0); + + CHECK_STRING(ostring1); + *string1 = THESTR(ostring1); + length1 = STRLEN(ostring1); + + CHECK_STRING(ostring2); + *string2 = THESTR(ostring2); + length2 = STRLEN(ostring2); + + if (ostart1 == UNSPEC) + *start1 = 0; + else { + CHECK_INDEX(ostart1); + *start1 = FIXNUM_VALUE(ostart1); + } + if (oend1 == UNSPEC) + *end1 = length1; + else { + CHECK_INDEX(oend1); + *end1 = FIXNUM_VALUE(oend1); + } + + if (ostart2 == UNSPEC) + *start2 = 0; + else { + CHECK_INDEX(ostart2); + *start2 = FIXNUM_VALUE(ostart2); + } + + if (oend2 == UNSPEC) + *end2 = length2; + else { + CHECK_INDEX(oend2); + *end2 = FIXNUM_VALUE(oend2); + } + + if (*start1 > *end1) + LispDestroy("%s: :START1 %ld larger than :END1 %ld", + STRFUN(builtin), *start1, *end1); + if (*start2 > *end2) + LispDestroy("%s: :START2 %ld larger than :END2 %ld", + STRFUN(builtin), *start2, *end2); + if (*end1 > length1) + LispDestroy("%s: :END1 %ld larger than string length %ld", + STRFUN(builtin), *end1, length1); + if (*end2 > length2) + LispDestroy("%s: :END2 %ld larger than string length %ld", + STRFUN(builtin), *end2, length2); +} + +LispObj * +LispPathnameField(int field, int string) +{ + int offset = field; + LispObj *pathname, *result, *object; + + pathname = ARGUMENT(0); + + if (PATHNAMEP(pathname)) + pathname = APPLY1(Oparse_namestring, pathname); + + result = pathname->data.pathname; + while (offset) { + result = CDR(result); + --offset; + } + object = result; + result = CAR(result); + + if (string) { + if (!STRINGP(result)) { + if (result == NIL) + result = STRING(""); + else if (field == PATH_DIRECTORY) { + char *name = THESTR(CAR(pathname->data.pathname)), *ptr; + + ptr = strrchr(name, PATH_SEP); + if (ptr) { + int length = ptr - name + 1; + char data[PATH_MAX]; + + if (length > PATH_MAX - 1) + length = PATH_MAX - 1; + strncpy(data, name, length); + data[length] = '\0'; + result = STRING(data); + } + else + result = STRING(""); + } + else + result = Kunspecific; + } + else if (field == PATH_NAME) { + object = CAR(CDR(object)); + if (STRINGP(object)) { + int length; + char name[PATH_MAX + 1]; + + strcpy(name, THESTR(result)); + length = STRLEN(result); + if (length + 1 < sizeof(name)) { + name[length++] = PATH_TYPESEP; + name[length] = '\0'; + } + if (STRLEN(object) + length < sizeof(name)) + strcpy(name + length, THESTR(object)); + /* else LispDestroy ... */ + result = STRING(name); + } + } + } + + return (result); +} + +LispObj * +LispProbeFile(LispBuiltin *builtin, int probe) +{ + GC_ENTER(); + LispObj *result; + char *name = NULL, resolved[PATH_MAX + 1]; + struct stat st; + + LispObj *pathname; + + pathname = ARGUMENT(0); + + if (!POINTERP(pathname)) + goto bad_pathname; + + if (XSTRINGP(pathname)) + name = THESTR(pathname); + else if (XPATHNAMEP(pathname)) + name = THESTR(CAR(pathname->data.pathname)); + else if (STREAMP(pathname) && pathname->data.stream.type == LispStreamFile) + name = THESTR(CAR(pathname->data.stream.pathname->data.pathname)); + + if (realpath(name, &resolved[0]) == NULL || + stat(resolved, &st)) { + if (probe) + return (NIL); + LispDestroy("%s: realpath(\"%s\"): %s", + STRFUN(builtin), name, strerror(errno)); + } + + if (S_ISDIR(st.st_mode)) { + int length = strlen(resolved); + + if (!length || resolved[length - 1] != PATH_SEP) { + resolved[length++] = PATH_SEP; + resolved[length] = '\0'; + } + } + + result = STRING(resolved); + GC_PROTECT(result); + result = APPLY1(Oparse_namestring, result); + GC_LEAVE(); + + return (result); + +bad_pathname: + LispDestroy("%s: bad pathname %s", STRFUN(builtin), STROBJ(pathname)); + /*NOTREACHED*/ + return (NIL); +} + +LispObj * +LispWriteString_(LispBuiltin *builtin, int newline) +/* + write-line string &optional output-stream &key start end + write-string string &optional output-stream &key start end + */ +{ + char *text; + long start, end, length; + + LispObj *string, *output_stream, *ostart, *oend; + + oend = ARGUMENT(3); + ostart = ARGUMENT(2); + output_stream = ARGUMENT(1); + string = ARGUMENT(0); + + CHECK_STRING(string); + LispCheckSequenceStartEnd(builtin, string, ostart, oend, + &start, &end, &length); + if (output_stream == UNSPEC) + output_stream = NIL; + text = THESTR(string); + if (end > start) + LispWriteStr(output_stream, text + start, end - start); + if (newline) + LispWriteChar(output_stream, '\n'); + + return (string); +} -- cgit v1.2.3