package.c revision 5dfecf96 
1/*
2 * Copyright (c) 2002 by The XFree86 Project, Inc.
3 *
4 * Permission is hereby granted, free of charge, to any person obtaining a
5 * copy of this software and associated documentation files (the "Software"),
6 * to deal in the Software without restriction, including without limitation
7 * the rights to use, copy, modify, merge, publish, distribute, sublicense,
8 * and/or sell copies of the Software, and to permit persons to whom the
9 * Software is furnished to do so, subject to the following conditions:
10 *
11 * The above copyright notice and this permission notice shall be included in
12 * all copies or substantial portions of the Software.
13 *
14 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
17 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
18 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
19 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
20 * SOFTWARE.
21 *
22 * Except as contained in this notice, the name of the XFree86 Project shall
23 * not be used in advertising or otherwise to promote the sale, use or other
24 * dealings in this Software without prior written authorization from the
25 * XFree86 Project.
26 *
27 * Author: Paulo César Pereira de Andrade
28 */
29
30/* $XFree86: xc/programs/xedit/lisp/package.c,v 1.20tsi Exp $ */
31
32#include "lisp/package.h"
33#include "lisp/private.h"
34
35/*
36 * Prototypes
37 */
38static int LispDoSymbol(LispObj*, LispAtom*, int, int);
39static LispObj *LispReallyDoSymbols(LispBuiltin*, int, int);
40static LispObj *LispDoSymbols(LispBuiltin*, int, int);
41static LispObj *LispFindSymbol(LispBuiltin*, int);
42static LispObj *LispFindPackageOrDie(LispBuiltin*, LispObj*);
43static void LispDoExport(LispBuiltin*, LispObj*, LispObj*, int);
44static void LispDoImport(LispBuiltin*, LispObj*);
45
46/*
47 * Initialization
48 */
49extern LispProperty *NOPROPERTY;
50static LispObj *Kinternal, *Kexternal, *Kinherited;
51
52/*
53 * Implementation
54 */
55void
56LispPackageInit(void)
57{
58    Kinternal	= KEYWORD("INTERNAL");
59    Kexternal	= KEYWORD("EXTERNAL");
60    Kinherited	= KEYWORD("INHERITED");
61}
62
63LispObj *
64LispFindPackageFromString(char *string)
65{
66    LispObj *list, *package, *nick;
67
68    for (list = PACK; CONSP(list); list = CDR(list)) {
69	package = CAR(list);
70	if (strcmp(THESTR(package->data.package.name), string) == 0)
71	    return (package);
72	for (nick = package->data.package.nicknames;
73	     CONSP(nick); nick = CDR(nick))
74	    if (strcmp(THESTR(CAR(nick)), string) == 0)
75		return (package);
76    }
77
78    return (NIL);
79}
80
81LispObj *
82LispFindPackage(LispObj *name)
83{
84    char *string = NULL;
85
86    if (PACKAGEP(name))
87	return (name);
88
89    if (SYMBOLP(name))
90	string = ATOMID(name);
91    else if (STRINGP(name))
92	string = THESTR(name);
93    else
94	LispDestroy("FIND-PACKAGE: %s is not a string or symbol", STROBJ(name));
95
96    return (LispFindPackageFromString(string));
97}
98
99int
100LispCheckAtomString(char *string)
101{
102    char *ptr;
103
104    if (*string == '\0')
105	return (0);
106
107    for (ptr = string; *ptr; ptr++) {
108	if (islower(*ptr) || strchr("\"\\;#()`'|:", *ptr) ||
109	    ((ptr == string || ptr[1] == '\0') && strchr(".,@", *ptr)))
110	    return (0);
111    }
112
113    return (1);
114}
115
116/*   This function is used to avoid some namespace polution caused by the
117 * way builtin functions are created, all function name arguments enter
118 * the current package, but most of them do not have a property */
119static int
120LispDoSymbol(LispObj *package, LispAtom *atom, int if_extern, int all_packages)
121{
122    int dosymbol;
123
124    /* condition 1: atom package is current package */
125    dosymbol = !all_packages || atom->package == package;
126    if (dosymbol) {
127	/* condition 2: intern and extern symbols or symbol is extern */
128	dosymbol = !if_extern || atom->ext;
129	if (dosymbol) {
130	    /* condition 3: atom has properties or is in
131	     * the current package */
132	    dosymbol = atom->property != NOPROPERTY ||
133		       package == lisp__data.keyword ||
134		       package == PACKAGE;
135	}
136    }
137
138    return (dosymbol);
139}
140
141static LispObj *
142LispFindPackageOrDie(LispBuiltin *builtin, LispObj *name)
143{
144    LispObj *package;
145
146    package = LispFindPackage(name);
147
148    if (package == NIL)
149	LispDestroy("%s: package %s is not available",
150		    STRFUN(builtin), STROBJ(name));
151
152    return (package);
153}
154
155/* package must be of type LispPackage_t, symbol type is checked
156   bypass lisp.c:LispExportSymbol() */
157static void
158LispDoExport(LispBuiltin *builtin,
159	     LispObj *package, LispObj *symbol, int export)
160{
161    CHECK_SYMBOL(symbol);
162    if (!export) {
163	if (package == lisp__data.keyword ||
164	    symbol->data.atom->package == lisp__data.keyword)
165	    LispDestroy("%s: symbol %s cannot be unexported",
166			STRFUN(builtin), STROBJ(symbol));
167    }
168
169    if (package == PACKAGE)
170	symbol->data.atom->ext = export ? 1 : 0;
171    else {
172	int i;
173	char *string;
174	LispAtom *atom;
175	LispPackage *pack;
176
177	string = ATOMID(symbol);
178	pack = package->data.package.package;
179	i = STRHASH(string);
180	atom = pack->atoms[i];
181	while (atom) {
182	    if (strcmp(atom->string, string) == 0) {
183		atom->ext = export ? 1 : 0;
184		return;
185	    }
186
187	    atom = atom->next;
188	}
189
190	LispDestroy("%s: the symbol %s is not available in package %s",
191		    STRFUN(builtin), STROBJ(symbol),
192		    THESTR(package->data.package.name));
193    }
194}
195
196static void
197LispDoImport(LispBuiltin *builtin, LispObj *symbol)
198{
199    CHECK_SYMBOL(symbol);
200    LispImportSymbol(symbol);
201}
202
203static LispObj *
204LispReallyDoSymbols(LispBuiltin *builtin, int only_externs, int all_symbols)
205{
206    int i, head = lisp__data.env.length;
207    LispPackage *pack = NULL;
208    LispAtom *atom, *next_atom;
209    LispObj *variable, *package = NULL, *list, *code, *result_form;
210
211    LispObj *init, *body;
212
213    body = ARGUMENT(1);
214    init = ARGUMENT(0);
215
216    /* Prepare for loop */
217    CHECK_CONS(init);
218    variable = CAR(init);
219    CHECK_SYMBOL(variable);
220
221    if (!all_symbols) {
222	/* if all_symbols, a package name is not specified in the init form */
223
224	init = CDR(init);
225	if (!CONSP(init))
226	    LispDestroy("%s: missing package name", STRFUN(builtin));
227
228	/* Evaluate package specification */
229	package = EVAL(CAR(init));
230	if (!PACKAGEP(package))
231	    package = LispFindPackageOrDie(builtin, package);
232
233	pack = package->data.package.package;
234    }
235
236    result_form = NIL;
237
238    init = CDR(init);
239    if (CONSP(init))
240	result_form = init;
241
242    /* Initialize iteration variable */
243    CHECK_CONSTANT(variable);
244    LispAddVar(variable, NIL);
245    ++lisp__data.env.head;
246
247    for (list = PACK; CONSP(list); list = CDR(list)) {
248	if (all_symbols) {
249	    package = CAR(list);
250	    pack = package->data.package.package;
251	}
252
253	/* Traverse the symbol list, executing body */
254	for (i = 0; i < STRTBLSZ; i++) {
255	    atom = pack->atoms[i];
256	    while (atom) {
257		/* Save pointer to next atom. If variable is removed,
258		 * predicatable result is only guaranteed if the bound
259		 * variable is removed. */
260		next_atom = atom->next;
261
262		if (LispDoSymbol(package, atom, only_externs, all_symbols)) {
263		    LispSetVar(variable, atom->object);
264		    for (code = body; CONSP(code); code = CDR(code))
265			EVAL(CAR(code));
266		}
267
268		atom = next_atom;
269	    }
270	}
271
272	if (!all_symbols)
273	    break;
274    }
275
276    /* Variable is still bound */
277    for (code = result_form; CONSP(code); code = CDR(code))
278	EVAL(CAR(code));
279
280    lisp__data.env.head = lisp__data.env.length = head;
281
282    return (NIL);
283}
284
285static LispObj *
286LispDoSymbols(LispBuiltin *builtin, int only_externs, int all_symbols)
287{
288    int did_jump, *pdid_jump = &did_jump;
289    LispObj *result, **presult = &result;
290    LispBlock *block;
291
292    *presult = NIL;
293    *pdid_jump = 1;
294    block = LispBeginBlock(NIL, LispBlockTag);
295    if (setjmp(block->jmp) == 0) {
296	*presult = LispReallyDoSymbols(builtin, only_externs, all_symbols);
297	*pdid_jump = 0;
298    }
299    LispEndBlock(block);
300    if (*pdid_jump)
301	*presult = lisp__data.block.block_ret;
302
303    return (*presult);
304}
305
306LispObj *
307LispFindSymbol(LispBuiltin *builtin, int intern)
308{
309    int i;
310    char *ptr;
311    LispAtom *atom;
312    LispObj *symbol;
313    LispPackage *pack;
314
315    LispObj *string, *package;
316
317    package = ARGUMENT(1);
318    string = ARGUMENT(0);
319
320    CHECK_STRING(string);
321    if (package != UNSPEC)
322	package = LispFindPackageOrDie(builtin, package);
323    else
324	package = PACKAGE;
325
326    /* If got here, package is a LispPackage_t */
327    pack = package->data.package.package;
328
329    /* Search symbol in specified package */
330    ptr = THESTR(string);
331
332    RETURN_COUNT = 1;
333
334    symbol = NULL;
335    /* Fix for current behaviour where NIL and T aren't symbols... */
336    if (STRLEN(string) == 3 && memcmp(ptr, "NIL", 3) == 0)
337	symbol = NIL;
338    else if (STRLEN(string) == 1 && ptr[0] == 'T')
339	symbol = T;
340    if (symbol) {
341	RETURN(0) = NIL;
342	return (symbol);
343    }
344
345    i = STRHASH(ptr);
346    atom = pack->atoms[i];
347    while (atom) {
348	if (strcmp(atom->string, ptr) == 0) {
349	    symbol = atom->object;
350	    break;
351	}
352	atom = atom->next;
353    }
354
355    if (symbol == NULL || symbol->data.atom->package == NULL) {
356	RETURN(0) = NIL;
357	if (intern) {
358	    /* symbol does not exist in the specified package, create a new
359	     * internal symbol */
360
361	    if (package == PACKAGE)
362		symbol = ATOM(ptr);
363	    else {
364		LispPackage *savepack;
365		LispObj *savepackage;
366
367		/* Save package environment */
368		savepackage = PACKAGE;
369		savepack = lisp__data.pack;
370
371		/* Change package environment */
372		PACKAGE = package;
373		lisp__data.pack = package->data.package.package;
374
375		symbol = ATOM(ptr);
376
377		/* Restore package environment */
378		PACKAGE = savepackage;
379		lisp__data.pack = savepack;
380	    }
381
382	    symbol->data.atom->unreadable = !LispCheckAtomString(ptr);
383	    /* If symbol being create in the keyword package, make it external */
384	    if (package == lisp__data.keyword)
385		symbol->data.atom->ext = symbol->data.atom->constant = 1;
386	}
387	else
388	    symbol = NIL;
389    }
390    else {
391	if (symbol->data.atom->package == package)
392	    RETURN(0) = symbol->data.atom->ext ? Kexternal : Kinternal;
393	else
394	    RETURN(0) = Kinherited;
395    }
396
397    return (symbol);
398}
399
400
401LispObj *
402Lisp_DoAllSymbols(LispBuiltin *builtin)
403/*
404 do-all-symbols init &rest body
405 */
406{
407    return (LispDoSymbols(builtin, 0, 1));
408}
409
410LispObj *
411Lisp_DoExternalSymbols(LispBuiltin *builtin)
412/*
413 do-external-symbols init &rest body
414 */
415{
416    return (LispDoSymbols(builtin, 1, 0));
417}
418
419LispObj *
420Lisp_DoSymbols(LispBuiltin *builtin)
421/*
422 do-symbols init &rest body
423 */
424{
425    return (LispDoSymbols(builtin, 0, 0));
426}
427
428LispObj *
429Lisp_FindAllSymbols(LispBuiltin *builtin)
430/*
431 find-all-symbols string-or-symbol
432 */
433{
434    GC_ENTER();
435    char *string = NULL;
436    LispAtom *atom;
437    LispPackage *pack;
438    LispObj *list, *package, *result;
439    int i;
440
441    LispObj *string_or_symbol;
442
443    string_or_symbol = ARGUMENT(0);
444
445    if (STRINGP(string_or_symbol))
446	string = THESTR(string_or_symbol);
447    else if (SYMBOLP(string_or_symbol))
448	string = ATOMID(string_or_symbol);
449    else
450	LispDestroy("%s: %s is not a string or symbol",
451		    STRFUN(builtin), STROBJ(string_or_symbol));
452
453    result = NIL;
454    i = STRHASH(string);
455
456    /* Traverse all packages, searching for symbols matching specified string */
457    for (list = PACK; CONSP(list); list = CDR(list)) {
458	package = CAR(list);
459	pack = package->data.package.package;
460
461	atom = pack->atoms[i];
462	while (atom) {
463	    if (strcmp(atom->string, string) == 0 &&
464		LispDoSymbol(package, atom, 0, 1)) {
465		/* Return only one pointer to a matching symbol */
466
467		if (result == NIL) {
468		    result = CONS(atom->object, NIL);
469		    GC_PROTECT(result);
470		}
471		else {
472		    /* Put symbols defined first in the
473		     * beginning of the result list */
474		    RPLACD(result, CONS(CAR(result), CDR(result)));
475		    RPLACA(result, atom->object);
476		}
477	    }
478	    atom = atom->next;
479	}
480    }
481    GC_LEAVE();
482
483    return (result);
484}
485
486LispObj *
487Lisp_FindSymbol(LispBuiltin *builtin)
488/*
489 find-symbol string &optional package
490 */
491{
492    return (LispFindSymbol(builtin, 0));
493}
494
495LispObj *
496Lisp_FindPackage(LispBuiltin *builtin)
497/*
498 find-package name
499 */
500{
501    LispObj *name;
502
503    name = ARGUMENT(0);
504
505    return (LispFindPackage(name));
506}
507
508LispObj *
509Lisp_Export(LispBuiltin *builtin)
510/*
511 export symbols &optional package
512 */
513{
514    LispObj *list;
515
516    LispObj *symbols, *package;
517
518    package = ARGUMENT(1);
519    symbols = ARGUMENT(0);
520
521    /* If specified, make sure package is available */
522    if (package != UNSPEC)
523	package = LispFindPackageOrDie(builtin, package);
524    else
525	package = PACKAGE;
526
527    /* Export symbols */
528    if (CONSP(symbols)) {
529	for (list = symbols; CONSP(list); list = CDR(list))
530	    LispDoExport(builtin, package, CAR(list), 1);
531    }
532    else
533	LispDoExport(builtin, package, symbols, 1);
534
535    return (T);
536}
537
538LispObj *
539Lisp_Import(LispBuiltin *builtin)
540/*
541 import symbols &optional package
542 */
543{
544    int restore_package;
545    LispPackage *savepack = NULL;
546    LispObj *list, *savepackage = NULL;
547
548    LispObj *symbols, *package;
549
550    package = ARGUMENT(1);
551    symbols = ARGUMENT(0);
552
553    /* If specified, make sure package is available */
554    if (package != UNSPEC)
555	package = LispFindPackageOrDie(builtin, package);
556    else
557	package = PACKAGE;
558
559    restore_package = package != PACKAGE;
560    if (restore_package) {
561	/* Save package environment */
562	savepackage = PACKAGE;
563	savepack = lisp__data.pack;
564
565	/* Change package environment */
566	PACKAGE = package;
567	lisp__data.pack = package->data.package.package;
568    }
569
570    /* Export symbols */
571    if (CONSP(symbols)) {
572	for (list = symbols; CONSP(list); list = CDR(list))
573	    LispDoImport(builtin, CAR(list));
574    }
575    else
576	LispDoImport(builtin, symbols);
577
578    if (restore_package) {
579	/* Restore package environment */
580	PACKAGE = savepackage;
581	lisp__data.pack = savepack;
582    }
583
584    return (T);
585}
586
587LispObj *
588Lisp_InPackage(LispBuiltin *builtin)
589/*
590 in-package name
591 */
592{
593    LispObj *package;
594
595    LispObj *name;
596
597    name = ARGUMENT(0);
598
599    package = LispFindPackageOrDie(builtin, name);
600
601    /* Update pointer to package symbol table */
602    lisp__data.pack = package->data.package.package;
603    PACKAGE = package;
604
605    return (package);
606}
607
608LispObj *
609Lisp_Intern(LispBuiltin *builtin)
610/*
611 intern string &optional package
612 */
613{
614    return (LispFindSymbol(builtin, 1));
615}
616
617LispObj *
618Lisp_ListAllPackages(LispBuiltin *builtin)
619/*
620 list-all-packages
621 */
622{
623    /*   Maybe this should be read-only or a copy of the package list.
624     *   But, if properly implemented, it should be possible to (rplaca)
625     * this variable from lisp code with no problems. Don't do it at home. */
626
627    return (PACK);
628}
629
630LispObj *
631Lisp_MakePackage(LispBuiltin *builtin)
632/*
633 make-package package-name &key nicknames use
634 */
635{
636    GC_ENTER();
637    LispObj *list, *package, *nicks, *cons, *savepackage;
638
639    LispObj *package_name, *nicknames, *use;
640
641    use = ARGUMENT(2);
642    nicknames = ARGUMENT(1);
643    package_name = ARGUMENT(0);
644
645    /* Check if package already exists */
646    package = LispFindPackage(package_name);
647    if (package != NIL)
648	/* FIXME: this should be a correctable error */
649	LispDestroy("%s: package %s already defined",
650		    STRFUN(builtin), STROBJ(package_name));
651
652    /* Error checks done, package_name is either a symbol or string */
653    if (!XSTRINGP(package_name))
654	package_name = STRING(ATOMID(package_name));
655
656    GC_PROTECT(package_name);
657
658    /* Check nicknames */
659    nicks = cons = NIL;
660    for (list = nicknames; CONSP(list); list = CDR(list)) {
661	package = LispFindPackage(CAR(list));
662	if (package != NIL)
663	    /* FIXME: this should be a correctable error */
664	    LispDestroy("%s: nickname %s matches package %s",
665			STRFUN(builtin), STROBJ(CAR(list)),
666			THESTR(package->data.package.name));
667	/* Store all nicknames as strings */
668	package = CAR(list);
669	if (!XSTRINGP(package))
670	    package = STRING(ATOMID(package));
671	if (nicks == NIL) {
672	    nicks = cons = CONS(package, NIL);
673	    GC_PROTECT(nicks);
674	}
675	else {
676	    RPLACD(cons, CONS(package, NIL));
677	    cons = CDR(cons);
678	}
679    }
680
681    /* Check use list */
682    for (list = use; CONSP(list); list = CDR(list))
683	(void)LispFindPackageOrDie(builtin, CAR(list));
684
685    /* No errors, create new package */
686    package = LispNewPackage(package_name, nicks);
687
688    /* Update list of packages */
689    PACK = CONS(package, PACK);
690
691    /* No need for gc protection anymore */
692    GC_LEAVE();
693
694    /* Import symbols from use list */
695    savepackage = PACKAGE;
696
697    /* Update pointer to package symbol table */
698    lisp__data.pack = package->data.package.package;
699    PACKAGE = package;
700
701    if (use != UNSPEC) {
702	for (list = use; CONSP(list); list = CDR(list))
703	    LispUsePackage(LispFindPackage(CAR(list)));
704    }
705    else
706	LispUsePackage(lisp__data.lisp);
707
708    /* Restore pointer to package symbol table */
709    lisp__data.pack = savepackage->data.package.package;
710    PACKAGE = savepackage;
711
712    return (package);
713}
714
715LispObj *
716Lisp_Packagep(LispBuiltin *builtin)
717/*
718 packagep object
719 */
720{
721    LispObj *object;
722
723    object = ARGUMENT(0);
724
725    return (PACKAGEP(object) ? T : NIL);
726}
727
728LispObj *
729Lisp_PackageName(LispBuiltin *builtin)
730/*
731 package-name package
732 */
733{
734    LispObj *package;
735
736    package = ARGUMENT(0);
737
738    package = LispFindPackageOrDie(builtin, package);
739
740    return (package->data.package.name);
741}
742
743LispObj *
744Lisp_PackageNicknames(LispBuiltin *builtin)
745/*
746 package-nicknames package
747 */
748{
749    LispObj *package;
750
751    package = ARGUMENT(0);
752
753    package = LispFindPackageOrDie(builtin, package);
754
755    return (package->data.package.nicknames);
756}
757
758LispObj *
759Lisp_PackageUseList(LispBuiltin *builtin)
760/*
761 package-use-list package
762 */
763{
764    /*  If the variable returned by this function is expected to be changeable,
765     * need to change the layout of the LispPackage structure. */
766
767    LispPackage *pack;
768    LispObj *package, *use, *cons;
769
770    package = ARGUMENT(0);
771
772    package = LispFindPackageOrDie(builtin, package);
773
774    use = cons = NIL;
775    pack = package->data.package.package;
776
777    if (pack->use.length) {
778	GC_ENTER();
779	int i = pack->use.length - 1;
780
781	use = cons = CONS(pack->use.pairs[i], NIL);
782	GC_PROTECT(use);
783	for (--i; i >= 0; i--) {
784	    RPLACD(cons, CONS(pack->use.pairs[i], NIL));
785	    cons = CDR(cons);
786	}
787	GC_LEAVE();
788    }
789
790    return (use);
791}
792
793LispObj *
794Lisp_PackageUsedByList(LispBuiltin *builtin)
795/*
796 package-used-by-list package
797 */
798{
799    GC_ENTER();
800    int i;
801    LispPackage *pack;
802    LispObj *package, *other, *used, *cons, *list;
803
804    package = ARGUMENT(0);
805
806    package = LispFindPackageOrDie(builtin, package);
807
808    used = cons = NIL;
809
810    for (list = PACK; CONSP(list); list = CDR(list)) {
811	other = CAR(list);
812	if (package == other)
813	    /* Surely package uses itself */
814	    continue;
815
816	pack = other->data.package.package;
817
818	for (i = 0; i < pack->use.length; i++) {
819	    if (pack->use.pairs[i] == package) {
820		if (used == NIL) {
821		    used = cons = CONS(other, NIL);
822		    GC_PROTECT(used);
823		}
824		else {
825		    RPLACD(cons, CONS(other, NIL));
826		    cons = CDR(cons);
827		}
828	    }
829	}
830    }
831
832    GC_LEAVE();
833
834    return (used);
835}
836
837LispObj *
838Lisp_Unexport(LispBuiltin *builtin)
839/*
840 unexport symbols &optional package
841 */
842{
843    LispObj *list;
844
845    LispObj *symbols, *package;
846
847    package = ARGUMENT(1);
848    symbols = ARGUMENT(0);
849
850    /* If specified, make sure package is available */
851    if (package != UNSPEC)
852	package = LispFindPackageOrDie(builtin, package);
853    else
854	package = PACKAGE;
855
856    /* Export symbols */
857    if (CONSP(symbols)) {
858	for (list = symbols; CONSP(list); list = CDR(list))
859	    LispDoExport(builtin, package, CAR(list), 0);
860    }
861    else
862	LispDoExport(builtin, package, symbols, 0);
863
864    return (T);
865}
866