Edit
IABSD.fr/xenocara/app/xedit/lisp/package.c
matthieu
- app/xedit/lisp/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(const 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)->value; 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(const char *string) { const 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 { Atom_id string; LispAtom *atom; LispPackage *pack; string = ATOMID(symbol); pack = package->data.package.package; atom = (LispAtom *)hash_check(pack->atoms, string->value, string->length); if (atom) { atom->ext = export ? 1 : 0; return; } 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 head = lisp__data.env.length; LispPackage *pack = NULL; LispAtom *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 (atom = (LispAtom *)hash_iter_first(pack->atoms); atom; atom = (LispAtom *)hash_iter_next(pack->atoms)) { /* Save pointer to next atom. If variable is removed, * predicatable result is only guaranteed if the bound * variable is removed. */ if (LispDoSymbol(package, atom, only_externs, all_symbols)) { LispSetVar(variable, atom->object); for (code = body; CONSP(code); code = CDR(code)) EVAL(CAR(code)); } } 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) { 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); } atom = (LispAtom *)hash_check(pack->atoms, ptr, strlen(ptr)); if (atom) symbol = atom->object; 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 length = 0; LispObj *string_or_symbol; string_or_symbol = ARGUMENT(0); if (STRINGP(string_or_symbol)) { string = THESTR(string_or_symbol); length = STRLEN(string_or_symbol); } else if (SYMBOLP(string_or_symbol)) { string = ATOMID(string_or_symbol)->value; length = ATOMID(string_or_symbol)->length; } else LispDestroy("%s: %s is not a string or symbol", STRFUN(builtin), STROBJ(string_or_symbol)); result = NIL; /* 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 = (LispAtom *)hash_check(pack->atoms, string, length); if (atom && 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); } } } 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)->value); 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)->value); 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); }