Logo Search packages:      
Sourcecode: x11-apps version File versions  Download package

helper.c

/*
 * 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.50 2003/05/27 22:27:03 tsi Exp $ */

#include "lisp/helper.h"
#include "lisp/pathname.h"
#include "lisp/package.h"
#include "lisp/read.h"
#include "lisp/stream.h"
#include "lisp/write.h"
#include "lisp/hash.h"
#include <ctype.h>
#include <fcntl.h>
#include <errno.h>
#include <math.h>
#include <sys/stat.h>

/*
 * 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;
    LispObj *result;
    LispBlock *block;

    jumped = 1;
    result = NIL;
    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));

#ifndef __UNIXOS2__
    if (realpath(name, &resolved[0]) == NULL ||
      stat(resolved, &st)) {
#else
    if ((name == NULL) || stat(resolved, &st)) {
#endif
      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);
}

Generated by  Doxygen 1.6.0   Back to index