Logo Search packages:      
Sourcecode: xbase-clients version File versions  Download package

package.c

/*
 * Copyright (c) 2002 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/package.c,v 1.20tsi Exp $ */

#include "lisp/package.h"
#include "lisp/private.h"

/*
 * Prototypes
 */
static int LispDoSymbol(LispObj*, LispAtom*, int, int);
static LispObj *LispReallyDoSymbols(LispBuiltin*, int, int);
static LispObj *LispDoSymbols(LispBuiltin*, int, int);
static LispObj *LispFindSymbol(LispBuiltin*, int);
static LispObj *LispFindPackageOrDie(LispBuiltin*, LispObj*);
static void LispDoExport(LispBuiltin*, LispObj*, LispObj*, int);
static void LispDoImport(LispBuiltin*, LispObj*);

/*
 * Initialization
 */
extern LispProperty *NOPROPERTY;
static LispObj *Kinternal, *Kexternal, *Kinherited;

/*
 * Implementation
 */
void
LispPackageInit(void)
{
    Kinternal     = KEYWORD("INTERNAL");
    Kexternal     = KEYWORD("EXTERNAL");
    Kinherited    = KEYWORD("INHERITED");
}

LispObj *
LispFindPackageFromString(char *string)
{
    LispObj *list, *package, *nick;

    for (list = PACK; CONSP(list); list = CDR(list)) {
      package = CAR(list);
      if (strcmp(THESTR(package->data.package.name), string) == 0)
          return (package);
      for (nick = package->data.package.nicknames;
           CONSP(nick); nick = CDR(nick))
          if (strcmp(THESTR(CAR(nick)), string) == 0)
            return (package);
    }

    return (NIL);
}

LispObj *
LispFindPackage(LispObj *name)
{
    char *string = NULL;

    if (PACKAGEP(name))
      return (name);

    if (SYMBOLP(name))
      string = ATOMID(name);
    else if (STRINGP(name))
      string = THESTR(name);
    else
      LispDestroy("FIND-PACKAGE: %s is not a string or symbol", STROBJ(name));

    return (LispFindPackageFromString(string));
}

int
LispCheckAtomString(char *string)
{
    char *ptr;

    if (*string == '\0')
      return (0);

    for (ptr = string; *ptr; ptr++) {
      if (islower(*ptr) || strchr("\"\\;#()`'|:", *ptr) ||
          ((ptr == string || ptr[1] == '\0') && strchr(".,@", *ptr)))
          return (0);
    }

    return (1);
}

/*   This function is used to avoid some namespace polution caused by the
 * way builtin functions are created, all function name arguments enter
 * the current package, but most of them do not have a property */
static int
LispDoSymbol(LispObj *package, LispAtom *atom, int if_extern, int all_packages)
{
    int dosymbol;

    /* condition 1: atom package is current package */
    dosymbol = !all_packages || atom->package == package;
    if (dosymbol) {
      /* condition 2: intern and extern symbols or symbol is extern */
      dosymbol = !if_extern || atom->ext;
      if (dosymbol) {
          /* condition 3: atom has properties or is in
           * the current package */
          dosymbol = atom->property != NOPROPERTY ||
                   package == lisp__data.keyword ||
                   package == PACKAGE;
      }
    }

    return (dosymbol);
}

static LispObj *
LispFindPackageOrDie(LispBuiltin *builtin, LispObj *name)
{
    LispObj *package;

    package = LispFindPackage(name);

    if (package == NIL)
      LispDestroy("%s: package %s is not available",
                STRFUN(builtin), STROBJ(name));

    return (package);
}

/* package must be of type LispPackage_t, symbol type is checked
   bypass lisp.c:LispExportSymbol() */
static void
LispDoExport(LispBuiltin *builtin,
           LispObj *package, LispObj *symbol, int export)
{
    CHECK_SYMBOL(symbol);
    if (!export) {
      if (package == lisp__data.keyword ||
          symbol->data.atom->package == lisp__data.keyword)
          LispDestroy("%s: symbol %s cannot be unexported",
                  STRFUN(builtin), STROBJ(symbol));
    }

    if (package == PACKAGE)
      symbol->data.atom->ext = export ? 1 : 0;
    else {
      int i;
      char *string;
      LispAtom *atom;
      LispPackage *pack;

      string = ATOMID(symbol);
      pack = package->data.package.package;
      i = STRHASH(string);
      atom = pack->atoms[i];
      while (atom) {
          if (strcmp(atom->string, string) == 0) {
            atom->ext = export ? 1 : 0;
            return;
          }

          atom = atom->next;
      }

      LispDestroy("%s: the symbol %s is not available in package %s",
                STRFUN(builtin), STROBJ(symbol),
                THESTR(package->data.package.name));
    }
}

static void
LispDoImport(LispBuiltin *builtin, LispObj *symbol)
{
    CHECK_SYMBOL(symbol);
    LispImportSymbol(symbol);
}

static LispObj *
LispReallyDoSymbols(LispBuiltin *builtin, int only_externs, int all_symbols)
{
    int i, head = lisp__data.env.length;
    LispPackage *pack = NULL;
    LispAtom *atom, *next_atom;
    LispObj *variable, *package = NULL, *list, *code, *result_form;

    LispObj *init, *body;

    body = ARGUMENT(1);
    init = ARGUMENT(0);

    /* Prepare for loop */
    CHECK_CONS(init);
    variable = CAR(init);
    CHECK_SYMBOL(variable);

    if (!all_symbols) {
      /* if all_symbols, a package name is not specified in the init form */

      init = CDR(init);
      if (!CONSP(init))
          LispDestroy("%s: missing package name", STRFUN(builtin));

      /* Evaluate package specification */
      package = EVAL(CAR(init));
      if (!PACKAGEP(package))
          package = LispFindPackageOrDie(builtin, package);

      pack = package->data.package.package;
    }

    result_form = NIL;

    init = CDR(init);
    if (CONSP(init))
      result_form = init;

    /* Initialize iteration variable */
    CHECK_CONSTANT(variable);
    LispAddVar(variable, NIL);
    ++lisp__data.env.head;

    for (list = PACK; CONSP(list); list = CDR(list)) {
      if (all_symbols) {
          package = CAR(list);
          pack = package->data.package.package;
      }

      /* Traverse the symbol list, executing body */
      for (i = 0; i < STRTBLSZ; i++) {
          atom = pack->atoms[i];
          while (atom) {
            /* Save pointer to next atom. If variable is removed,
             * predicatable result is only guaranteed if the bound
             * variable is removed. */
            next_atom = atom->next;

            if (LispDoSymbol(package, atom, only_externs, all_symbols)) {
                LispSetVar(variable, atom->object);
                for (code = body; CONSP(code); code = CDR(code))
                  EVAL(CAR(code));
            }

            atom = next_atom;
          }
      }

      if (!all_symbols)
          break;
    }

    /* Variable is still bound */
    for (code = result_form; CONSP(code); code = CDR(code))
      EVAL(CAR(code));

    lisp__data.env.head = lisp__data.env.length = head;

    return (NIL);
}

static LispObj *
LispDoSymbols(LispBuiltin *builtin, int only_externs, int all_symbols)
{
    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) {
      *presult = LispReallyDoSymbols(builtin, only_externs, all_symbols);
      *pdid_jump = 0;
    }
    LispEndBlock(block);
    if (*pdid_jump)
      *presult = lisp__data.block.block_ret;

    return (*presult);
}

LispObj *
LispFindSymbol(LispBuiltin *builtin, int intern)
{
    int i;
    char *ptr;
    LispAtom *atom;
    LispObj *symbol;
    LispPackage *pack;

    LispObj *string, *package;

    package = ARGUMENT(1);
    string = ARGUMENT(0);

    CHECK_STRING(string);
    if (package != UNSPEC)
      package = LispFindPackageOrDie(builtin, package);
    else
      package = PACKAGE;

    /* If got here, package is a LispPackage_t */
    pack = package->data.package.package;

    /* Search symbol in specified package */
    ptr = THESTR(string);

    RETURN_COUNT = 1;

    symbol = NULL;
    /* Fix for current behaviour where NIL and T aren't symbols... */
    if (STRLEN(string) == 3 && memcmp(ptr, "NIL", 3) == 0)
      symbol = NIL;
    else if (STRLEN(string) == 1 && ptr[0] == 'T')
      symbol = T;
    if (symbol) {
      RETURN(0) = NIL;
      return (symbol);
    }

    i = STRHASH(ptr);
    atom = pack->atoms[i];
    while (atom) {
      if (strcmp(atom->string, ptr) == 0) {
          symbol = atom->object;
          break;
      }
      atom = atom->next;
    }

    if (symbol == NULL || symbol->data.atom->package == NULL) {
      RETURN(0) = NIL;
      if (intern) {
          /* symbol does not exist in the specified package, create a new
           * internal symbol */

          if (package == PACKAGE)
            symbol = ATOM(ptr);
          else {
            LispPackage *savepack;
            LispObj *savepackage;

            /* Save package environment */
            savepackage = PACKAGE;
            savepack = lisp__data.pack;

            /* Change package environment */
            PACKAGE = package;
            lisp__data.pack = package->data.package.package;

            symbol = ATOM(ptr);

            /* Restore package environment */
            PACKAGE = savepackage;
            lisp__data.pack = savepack;
          }

          symbol->data.atom->unreadable = !LispCheckAtomString(ptr);
          /* If symbol being create in the keyword package, make it external */
          if (package == lisp__data.keyword)
            symbol->data.atom->ext = symbol->data.atom->constant = 1;
      }
      else
          symbol = NIL;
    }
    else {
      if (symbol->data.atom->package == package)
          RETURN(0) = symbol->data.atom->ext ? Kexternal : Kinternal;
      else
          RETURN(0) = Kinherited;
    }

    return (symbol);
}


LispObj *
Lisp_DoAllSymbols(LispBuiltin *builtin)
/*
 do-all-symbols init &rest body
 */
{
    return (LispDoSymbols(builtin, 0, 1));
}

LispObj *
Lisp_DoExternalSymbols(LispBuiltin *builtin)
/*
 do-external-symbols init &rest body
 */
{
    return (LispDoSymbols(builtin, 1, 0));
}

LispObj *
Lisp_DoSymbols(LispBuiltin *builtin)
/*
 do-symbols init &rest body
 */
{
    return (LispDoSymbols(builtin, 0, 0));
}

LispObj *
Lisp_FindAllSymbols(LispBuiltin *builtin)
/*
 find-all-symbols string-or-symbol
 */
{
    GC_ENTER();
    char *string = NULL;
    LispAtom *atom;
    LispPackage *pack;
    LispObj *list, *package, *result;
    int i;

    LispObj *string_or_symbol;

    string_or_symbol = ARGUMENT(0);

    if (STRINGP(string_or_symbol))
      string = THESTR(string_or_symbol);
    else if (SYMBOLP(string_or_symbol))
      string = ATOMID(string_or_symbol);
    else
      LispDestroy("%s: %s is not a string or symbol",
                STRFUN(builtin), STROBJ(string_or_symbol));

    result = NIL;
    i = STRHASH(string);

    /* Traverse all packages, searching for symbols matching specified string */
    for (list = PACK; CONSP(list); list = CDR(list)) {
      package = CAR(list);
      pack = package->data.package.package;

      atom = pack->atoms[i];
      while (atom) {
          if (strcmp(atom->string, string) == 0 &&
            LispDoSymbol(package, atom, 0, 1)) {
            /* Return only one pointer to a matching symbol */

            if (result == NIL) {
                result = CONS(atom->object, NIL);
                GC_PROTECT(result);
            }
            else {
                /* Put symbols defined first in the
                 * beginning of the result list */
                RPLACD(result, CONS(CAR(result), CDR(result)));
                RPLACA(result, atom->object);
            }
          }
          atom = atom->next;
      }
    }
    GC_LEAVE();

    return (result);
}

LispObj *
Lisp_FindSymbol(LispBuiltin *builtin)
/*
 find-symbol string &optional package
 */
{
    return (LispFindSymbol(builtin, 0));
}

LispObj *
Lisp_FindPackage(LispBuiltin *builtin)
/*
 find-package name
 */
{
    LispObj *name;

    name = ARGUMENT(0);

    return (LispFindPackage(name));
}

LispObj *
Lisp_Export(LispBuiltin *builtin)
/*
 export symbols &optional package
 */
{
    LispObj *list;

    LispObj *symbols, *package;

    package = ARGUMENT(1);
    symbols = ARGUMENT(0);

    /* If specified, make sure package is available */
    if (package != UNSPEC)
      package = LispFindPackageOrDie(builtin, package);
    else
      package = PACKAGE;

    /* Export symbols */
    if (CONSP(symbols)) {
      for (list = symbols; CONSP(list); list = CDR(list))
          LispDoExport(builtin, package, CAR(list), 1);
    }
    else
      LispDoExport(builtin, package, symbols, 1);

    return (T);
}

LispObj *
Lisp_Import(LispBuiltin *builtin)
/*
 import symbols &optional package
 */
{
    int restore_package;
    LispPackage *savepack = NULL;
    LispObj *list, *savepackage = NULL;

    LispObj *symbols, *package;

    package = ARGUMENT(1);
    symbols = ARGUMENT(0);

    /* If specified, make sure package is available */
    if (package != UNSPEC)
      package = LispFindPackageOrDie(builtin, package);
    else
      package = PACKAGE;

    restore_package = package != PACKAGE;
    if (restore_package) {
      /* Save package environment */
      savepackage = PACKAGE;
      savepack = lisp__data.pack;

      /* Change package environment */
      PACKAGE = package;
      lisp__data.pack = package->data.package.package;
    }

    /* Export symbols */
    if (CONSP(symbols)) {
      for (list = symbols; CONSP(list); list = CDR(list))
          LispDoImport(builtin, CAR(list));
    }
    else
      LispDoImport(builtin, symbols);

    if (restore_package) {
      /* Restore package environment */
      PACKAGE = savepackage;
      lisp__data.pack = savepack;
    }

    return (T);
}

LispObj *
Lisp_InPackage(LispBuiltin *builtin)
/*
 in-package name
 */
{
    LispObj *package;

    LispObj *name;

    name = ARGUMENT(0);

    package = LispFindPackageOrDie(builtin, name);

    /* Update pointer to package symbol table */
    lisp__data.pack = package->data.package.package;
    PACKAGE = package;

    return (package);
}

LispObj *
Lisp_Intern(LispBuiltin *builtin)
/*
 intern string &optional package
 */
{
    return (LispFindSymbol(builtin, 1));
}

LispObj *
Lisp_ListAllPackages(LispBuiltin *builtin)
/*
 list-all-packages
 */
{
    /*   Maybe this should be read-only or a copy of the package list.
     *   But, if properly implemented, it should be possible to (rplaca)
     * this variable from lisp code with no problems. Don't do it at home. */

    return (PACK);
}

LispObj *
Lisp_MakePackage(LispBuiltin *builtin)
/*
 make-package package-name &key nicknames use
 */
{
    GC_ENTER();
    LispObj *list, *package, *nicks, *cons, *savepackage;

    LispObj *package_name, *nicknames, *use;

    use = ARGUMENT(2);
    nicknames = ARGUMENT(1);
    package_name = ARGUMENT(0);

    /* Check if package already exists */
    package = LispFindPackage(package_name);
    if (package != NIL)
      /* FIXME: this should be a correctable error */
      LispDestroy("%s: package %s already defined",
                STRFUN(builtin), STROBJ(package_name));

    /* Error checks done, package_name is either a symbol or string */
    if (!XSTRINGP(package_name))
      package_name = STRING(ATOMID(package_name));

    GC_PROTECT(package_name);

    /* Check nicknames */
    nicks = cons = NIL;
    for (list = nicknames; CONSP(list); list = CDR(list)) {
      package = LispFindPackage(CAR(list));
      if (package != NIL)
          /* FIXME: this should be a correctable error */
          LispDestroy("%s: nickname %s matches package %s",
                  STRFUN(builtin), STROBJ(CAR(list)),
                  THESTR(package->data.package.name));
      /* Store all nicknames as strings */
      package = CAR(list);
      if (!XSTRINGP(package))
          package = STRING(ATOMID(package));
      if (nicks == NIL) {
          nicks = cons = CONS(package, NIL);
          GC_PROTECT(nicks);
      }
      else {
          RPLACD(cons, CONS(package, NIL));
          cons = CDR(cons);
      }
    }

    /* Check use list */
    for (list = use; CONSP(list); list = CDR(list))
      (void)LispFindPackageOrDie(builtin, CAR(list));

    /* No errors, create new package */
    package = LispNewPackage(package_name, nicks);

    /* Update list of packages */
    PACK = CONS(package, PACK);

    /* No need for gc protection anymore */
    GC_LEAVE();

    /* Import symbols from use list */
    savepackage = PACKAGE;

    /* Update pointer to package symbol table */
    lisp__data.pack = package->data.package.package;
    PACKAGE = package;

    if (use != UNSPEC) {
      for (list = use; CONSP(list); list = CDR(list))
          LispUsePackage(LispFindPackage(CAR(list)));
    }
    else
      LispUsePackage(lisp__data.lisp);

    /* Restore pointer to package symbol table */
    lisp__data.pack = savepackage->data.package.package;
    PACKAGE = savepackage;

    return (package);
}

LispObj *
Lisp_Packagep(LispBuiltin *builtin)
/*
 packagep object
 */
{
    LispObj *object;

    object = ARGUMENT(0);

    return (PACKAGEP(object) ? T : NIL);
}

LispObj *
Lisp_PackageName(LispBuiltin *builtin)
/*
 package-name package
 */
{
    LispObj *package;

    package = ARGUMENT(0);

    package = LispFindPackageOrDie(builtin, package);

    return (package->data.package.name);
}

LispObj *
Lisp_PackageNicknames(LispBuiltin *builtin)
/*
 package-nicknames package
 */
{
    LispObj *package;

    package = ARGUMENT(0);

    package = LispFindPackageOrDie(builtin, package);

    return (package->data.package.nicknames);
}

LispObj *
Lisp_PackageUseList(LispBuiltin *builtin)
/*
 package-use-list package
 */
{
    /*  If the variable returned by this function is expected to be changeable,
     * need to change the layout of the LispPackage structure. */

    LispPackage *pack;
    LispObj *package, *use, *cons;

    package = ARGUMENT(0);

    package = LispFindPackageOrDie(builtin, package);

    use = cons = NIL;
    pack = package->data.package.package;

    if (pack->use.length) {
      GC_ENTER();
      int i = pack->use.length - 1;

      use = cons = CONS(pack->use.pairs[i], NIL);
      GC_PROTECT(use);
      for (--i; i >= 0; i--) {
          RPLACD(cons, CONS(pack->use.pairs[i], NIL));
          cons = CDR(cons);
      }
      GC_LEAVE();
    }

    return (use);
}

LispObj *
Lisp_PackageUsedByList(LispBuiltin *builtin)
/*
 package-used-by-list package
 */
{
    GC_ENTER();
    int i;
    LispPackage *pack;
    LispObj *package, *other, *used, *cons, *list;

    package = ARGUMENT(0);

    package = LispFindPackageOrDie(builtin, package);

    used = cons = NIL;

    for (list = PACK; CONSP(list); list = CDR(list)) {
      other = CAR(list);
      if (package == other)
          /* Surely package uses itself */
          continue;

      pack = other->data.package.package;

      for (i = 0; i < pack->use.length; i++) {
          if (pack->use.pairs[i] == package) {
            if (used == NIL) {
                used = cons = CONS(other, NIL);
                GC_PROTECT(used);
            }
            else {
                RPLACD(cons, CONS(other, NIL));
                cons = CDR(cons);
            }
          }
      }
    }

    GC_LEAVE();

    return (used);
}

LispObj *
Lisp_Unexport(LispBuiltin *builtin)
/*
 unexport symbols &optional package
 */
{
    LispObj *list;

    LispObj *symbols, *package;

    package = ARGUMENT(1);
    symbols = ARGUMENT(0);

    /* If specified, make sure package is available */
    if (package != UNSPEC)
      package = LispFindPackageOrDie(builtin, package);
    else
      package = PACKAGE;

    /* Export symbols */
    if (CONSP(symbols)) {
      for (list = symbols; CONSP(list); list = CDR(list))
          LispDoExport(builtin, package, CAR(list), 0);
    }
    else
      LispDoExport(builtin, package, symbols, 0);

    return (T);
}

Generated by  Doxygen 1.6.0   Back to index