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(const 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)->value;
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(const char *string)
101{
102    const 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	Atom_id string;
173	LispAtom *atom;
174	LispPackage *pack;
175
176	string = ATOMID(symbol);
177	pack = package->data.package.package;
178	atom = (LispAtom *)hash_check(pack->atoms,
179				      string->value, string->length);
180
181	if (atom) {
182	    atom->ext = export ? 1 : 0;
183	    return;
184	}
185
186	LispDestroy("%s: the symbol %s is not available in package %s",
187		    STRFUN(builtin), STROBJ(symbol),
188		    THESTR(package->data.package.name));
189    }
190}
191
192static void
193LispDoImport(LispBuiltin *builtin, LispObj *symbol)
194{
195    CHECK_SYMBOL(symbol);
196    LispImportSymbol(symbol);
197}
198
199static LispObj *
200LispReallyDoSymbols(LispBuiltin *builtin, int only_externs, int all_symbols)
201{
202    int head = lisp__data.env.length;
203    LispPackage *pack = NULL;
204    LispAtom *atom;
205    LispObj *variable, *package = NULL, *list, *code, *result_form;
206
207    LispObj *init, *body;
208
209    body = ARGUMENT(1);
210    init = ARGUMENT(0);
211
212    /* Prepare for loop */
213    CHECK_CONS(init);
214    variable = CAR(init);
215    CHECK_SYMBOL(variable);
216
217    if (!all_symbols) {
218	/* if all_symbols, a package name is not specified in the init form */
219
220	init = CDR(init);
221	if (!CONSP(init))
222	    LispDestroy("%s: missing package name", STRFUN(builtin));
223
224	/* Evaluate package specification */
225	package = EVAL(CAR(init));
226	if (!PACKAGEP(package))
227	    package = LispFindPackageOrDie(builtin, package);
228
229	pack = package->data.package.package;
230    }
231
232    result_form = NIL;
233
234    init = CDR(init);
235    if (CONSP(init))
236	result_form = init;
237
238    /* Initialize iteration variable */
239    CHECK_CONSTANT(variable);
240    LispAddVar(variable, NIL);
241    ++lisp__data.env.head;
242
243    for (list = PACK; CONSP(list); list = CDR(list)) {
244	if (all_symbols) {
245	    package = CAR(list);
246	    pack = package->data.package.package;
247	}
248
249	/* Traverse the symbol list, executing body */
250	for (atom = (LispAtom *)hash_iter_first(pack->atoms);
251	     atom;
252	     atom = (LispAtom *)hash_iter_next(pack->atoms)) {
253		/* Save pointer to next atom. If variable is removed,
254		 * predicatable result is only guaranteed if the bound
255		 * variable is removed. */
256
257	    if (LispDoSymbol(package, atom, only_externs, all_symbols)) {
258		LispSetVar(variable, atom->object);
259		for (code = body; CONSP(code); code = CDR(code))
260		    EVAL(CAR(code));
261	    }
262	}
263
264	if (!all_symbols)
265	    break;
266    }
267
268    /* Variable is still bound */
269    for (code = result_form; CONSP(code); code = CDR(code))
270	EVAL(CAR(code));
271
272    lisp__data.env.head = lisp__data.env.length = head;
273
274    return (NIL);
275}
276
277static LispObj *
278LispDoSymbols(LispBuiltin *builtin, int only_externs, int all_symbols)
279{
280    int did_jump, *pdid_jump = &did_jump;
281    LispObj *result, **presult = &result;
282    LispBlock *block;
283
284    *presult = NIL;
285    *pdid_jump = 1;
286    block = LispBeginBlock(NIL, LispBlockTag);
287    if (setjmp(block->jmp) == 0) {
288	*presult = LispReallyDoSymbols(builtin, only_externs, all_symbols);
289	*pdid_jump = 0;
290    }
291    LispEndBlock(block);
292    if (*pdid_jump)
293	*presult = lisp__data.block.block_ret;
294
295    return (*presult);
296}
297
298LispObj *
299LispFindSymbol(LispBuiltin *builtin, int intern)
300{
301    char *ptr;
302    LispAtom *atom;
303    LispObj *symbol;
304    LispPackage *pack;
305
306    LispObj *string, *package;
307
308    package = ARGUMENT(1);
309    string = ARGUMENT(0);
310
311    CHECK_STRING(string);
312    if (package != UNSPEC)
313	package = LispFindPackageOrDie(builtin, package);
314    else
315	package = PACKAGE;
316
317    /* If got here, package is a LispPackage_t */
318    pack = package->data.package.package;
319
320    /* Search symbol in specified package */
321    ptr = THESTR(string);
322
323    RETURN_COUNT = 1;
324
325    symbol = NULL;
326    /* Fix for current behaviour where NIL and T aren't symbols... */
327    if (STRLEN(string) == 3 && memcmp(ptr, "NIL", 3) == 0)
328	symbol = NIL;
329    else if (STRLEN(string) == 1 && ptr[0] == 'T')
330	symbol = T;
331    if (symbol) {
332	RETURN(0) = NIL;
333	return (symbol);
334    }
335
336    atom = (LispAtom *)hash_check(pack->atoms, ptr, strlen(ptr));
337    if (atom)
338	symbol = atom->object;
339
340    if (symbol == NULL || symbol->data.atom->package == NULL) {
341	RETURN(0) = NIL;
342	if (intern) {
343	    /* symbol does not exist in the specified package, create a new
344	     * internal symbol */
345
346	    if (package == PACKAGE)
347		symbol = ATOM(ptr);
348	    else {
349		LispPackage *savepack;
350		LispObj *savepackage;
351
352		/* Save package environment */
353		savepackage = PACKAGE;
354		savepack = lisp__data.pack;
355
356		/* Change package environment */
357		PACKAGE = package;
358		lisp__data.pack = package->data.package.package;
359
360		symbol = ATOM(ptr);
361
362		/* Restore package environment */
363		PACKAGE = savepackage;
364		lisp__data.pack = savepack;
365	    }
366
367	    symbol->data.atom->unreadable = !LispCheckAtomString(ptr);
368	    /* If symbol being create in the keyword package, make it external */
369	    if (package == lisp__data.keyword)
370		symbol->data.atom->ext = symbol->data.atom->constant = 1;
371	}
372	else
373	    symbol = NIL;
374    }
375    else {
376	if (symbol->data.atom->package == package)
377	    RETURN(0) = symbol->data.atom->ext ? Kexternal : Kinternal;
378	else
379	    RETURN(0) = Kinherited;
380    }
381
382    return (symbol);
383}
384
385
386LispObj *
387Lisp_DoAllSymbols(LispBuiltin *builtin)
388/*
389 do-all-symbols init &rest body
390 */
391{
392    return (LispDoSymbols(builtin, 0, 1));
393}
394
395LispObj *
396Lisp_DoExternalSymbols(LispBuiltin *builtin)
397/*
398 do-external-symbols init &rest body
399 */
400{
401    return (LispDoSymbols(builtin, 1, 0));
402}
403
404LispObj *
405Lisp_DoSymbols(LispBuiltin *builtin)
406/*
407 do-symbols init &rest body
408 */
409{
410    return (LispDoSymbols(builtin, 0, 0));
411}
412
413LispObj *
414Lisp_FindAllSymbols(LispBuiltin *builtin)
415/*
416 find-all-symbols string-or-symbol
417 */
418{
419    GC_ENTER();
420    char *string = NULL;
421    LispAtom *atom;
422    LispPackage *pack;
423    LispObj *list, *package, *result;
424    int length = 0;
425
426    LispObj *string_or_symbol;
427
428    string_or_symbol = ARGUMENT(0);
429
430    if (STRINGP(string_or_symbol)) {
431	string = THESTR(string_or_symbol);
432	length = STRLEN(string_or_symbol);
433    }
434    else if (SYMBOLP(string_or_symbol)) {
435	string = ATOMID(string_or_symbol)->value;
436	length = ATOMID(string_or_symbol)->length;
437    }
438    else
439	LispDestroy("%s: %s is not a string or symbol",
440		    STRFUN(builtin), STROBJ(string_or_symbol));
441
442    result = NIL;
443
444    /* Traverse all packages, searching for symbols matching specified string */
445    for (list = PACK; CONSP(list); list = CDR(list)) {
446	package = CAR(list);
447	pack = package->data.package.package;
448
449	atom = (LispAtom *)hash_check(pack->atoms, string, length);
450	if (atom && LispDoSymbol(package, atom, 0, 1)) {
451	    /* Return only one pointer to a matching symbol */
452
453	    if (result == NIL) {
454		result = CONS(atom->object, NIL);
455		GC_PROTECT(result);
456	    }
457	    else {
458		/* Put symbols defined first in the
459		 * beginning of the result list */
460		RPLACD(result, CONS(CAR(result), CDR(result)));
461		RPLACA(result, atom->object);
462	    }
463	}
464    }
465    GC_LEAVE();
466
467    return (result);
468}
469
470LispObj *
471Lisp_FindSymbol(LispBuiltin *builtin)
472/*
473 find-symbol string &optional package
474 */
475{
476    return (LispFindSymbol(builtin, 0));
477}
478
479LispObj *
480Lisp_FindPackage(LispBuiltin *builtin)
481/*
482 find-package name
483 */
484{
485    LispObj *name;
486
487    name = ARGUMENT(0);
488
489    return (LispFindPackage(name));
490}
491
492LispObj *
493Lisp_Export(LispBuiltin *builtin)
494/*
495 export symbols &optional package
496 */
497{
498    LispObj *list;
499
500    LispObj *symbols, *package;
501
502    package = ARGUMENT(1);
503    symbols = ARGUMENT(0);
504
505    /* If specified, make sure package is available */
506    if (package != UNSPEC)
507	package = LispFindPackageOrDie(builtin, package);
508    else
509	package = PACKAGE;
510
511    /* Export symbols */
512    if (CONSP(symbols)) {
513	for (list = symbols; CONSP(list); list = CDR(list))
514	    LispDoExport(builtin, package, CAR(list), 1);
515    }
516    else
517	LispDoExport(builtin, package, symbols, 1);
518
519    return (T);
520}
521
522LispObj *
523Lisp_Import(LispBuiltin *builtin)
524/*
525 import symbols &optional package
526 */
527{
528    int restore_package;
529    LispPackage *savepack = NULL;
530    LispObj *list, *savepackage = NULL;
531
532    LispObj *symbols, *package;
533
534    package = ARGUMENT(1);
535    symbols = ARGUMENT(0);
536
537    /* If specified, make sure package is available */
538    if (package != UNSPEC)
539	package = LispFindPackageOrDie(builtin, package);
540    else
541	package = PACKAGE;
542
543    restore_package = package != PACKAGE;
544    if (restore_package) {
545	/* Save package environment */
546	savepackage = PACKAGE;
547	savepack = lisp__data.pack;
548
549	/* Change package environment */
550	PACKAGE = package;
551	lisp__data.pack = package->data.package.package;
552    }
553
554    /* Export symbols */
555    if (CONSP(symbols)) {
556	for (list = symbols; CONSP(list); list = CDR(list))
557	    LispDoImport(builtin, CAR(list));
558    }
559    else
560	LispDoImport(builtin, symbols);
561
562    if (restore_package) {
563	/* Restore package environment */
564	PACKAGE = savepackage;
565	lisp__data.pack = savepack;
566    }
567
568    return (T);
569}
570
571LispObj *
572Lisp_InPackage(LispBuiltin *builtin)
573/*
574 in-package name
575 */
576{
577    LispObj *package;
578
579    LispObj *name;
580
581    name = ARGUMENT(0);
582
583    package = LispFindPackageOrDie(builtin, name);
584
585    /* Update pointer to package symbol table */
586    lisp__data.pack = package->data.package.package;
587    PACKAGE = package;
588
589    return (package);
590}
591
592LispObj *
593Lisp_Intern(LispBuiltin *builtin)
594/*
595 intern string &optional package
596 */
597{
598    return (LispFindSymbol(builtin, 1));
599}
600
601LispObj *
602Lisp_ListAllPackages(LispBuiltin *builtin)
603/*
604 list-all-packages
605 */
606{
607    /*   Maybe this should be read-only or a copy of the package list.
608     *   But, if properly implemented, it should be possible to (rplaca)
609     * this variable from lisp code with no problems. Don't do it at home. */
610
611    return (PACK);
612}
613
614LispObj *
615Lisp_MakePackage(LispBuiltin *builtin)
616/*
617 make-package package-name &key nicknames use
618 */
619{
620    GC_ENTER();
621    LispObj *list, *package, *nicks, *cons, *savepackage;
622
623    LispObj *package_name, *nicknames, *use;
624
625    use = ARGUMENT(2);
626    nicknames = ARGUMENT(1);
627    package_name = ARGUMENT(0);
628
629    /* Check if package already exists */
630    package = LispFindPackage(package_name);
631    if (package != NIL)
632	/* FIXME: this should be a correctable error */
633	LispDestroy("%s: package %s already defined",
634		    STRFUN(builtin), STROBJ(package_name));
635
636    /* Error checks done, package_name is either a symbol or string */
637    if (!XSTRINGP(package_name))
638	package_name = STRING(ATOMID(package_name)->value);
639
640    GC_PROTECT(package_name);
641
642    /* Check nicknames */
643    nicks = cons = NIL;
644    for (list = nicknames; CONSP(list); list = CDR(list)) {
645	package = LispFindPackage(CAR(list));
646	if (package != NIL)
647	    /* FIXME: this should be a correctable error */
648	    LispDestroy("%s: nickname %s matches package %s",
649			STRFUN(builtin), STROBJ(CAR(list)),
650			THESTR(package->data.package.name));
651	/* Store all nicknames as strings */
652	package = CAR(list);
653	if (!XSTRINGP(package))
654	    package = STRING(ATOMID(package)->value);
655	if (nicks == NIL) {
656	    nicks = cons = CONS(package, NIL);
657	    GC_PROTECT(nicks);
658	}
659	else {
660	    RPLACD(cons, CONS(package, NIL));
661	    cons = CDR(cons);
662	}
663    }
664
665    /* Check use list */
666    for (list = use; CONSP(list); list = CDR(list))
667	(void)LispFindPackageOrDie(builtin, CAR(list));
668
669    /* No errors, create new package */
670    package = LispNewPackage(package_name, nicks);
671
672    /* Update list of packages */
673    PACK = CONS(package, PACK);
674
675    /* No need for gc protection anymore */
676    GC_LEAVE();
677
678    /* Import symbols from use list */
679    savepackage = PACKAGE;
680
681    /* Update pointer to package symbol table */
682    lisp__data.pack = package->data.package.package;
683    PACKAGE = package;
684
685    if (use != UNSPEC) {
686	for (list = use; CONSP(list); list = CDR(list))
687	    LispUsePackage(LispFindPackage(CAR(list)));
688    }
689    else
690	LispUsePackage(lisp__data.lisp);
691
692    /* Restore pointer to package symbol table */
693    lisp__data.pack = savepackage->data.package.package;
694    PACKAGE = savepackage;
695
696    return (package);
697}
698
699LispObj *
700Lisp_Packagep(LispBuiltin *builtin)
701/*
702 packagep object
703 */
704{
705    LispObj *object;
706
707    object = ARGUMENT(0);
708
709    return (PACKAGEP(object) ? T : NIL);
710}
711
712LispObj *
713Lisp_PackageName(LispBuiltin *builtin)
714/*
715 package-name package
716 */
717{
718    LispObj *package;
719
720    package = ARGUMENT(0);
721
722    package = LispFindPackageOrDie(builtin, package);
723
724    return (package->data.package.name);
725}
726
727LispObj *
728Lisp_PackageNicknames(LispBuiltin *builtin)
729/*
730 package-nicknames package
731 */
732{
733    LispObj *package;
734
735    package = ARGUMENT(0);
736
737    package = LispFindPackageOrDie(builtin, package);
738
739    return (package->data.package.nicknames);
740}
741
742LispObj *
743Lisp_PackageUseList(LispBuiltin *builtin)
744/*
745 package-use-list package
746 */
747{
748    /*  If the variable returned by this function is expected to be changeable,
749     * need to change the layout of the LispPackage structure. */
750
751    LispPackage *pack;
752    LispObj *package, *use, *cons;
753
754    package = ARGUMENT(0);
755
756    package = LispFindPackageOrDie(builtin, package);
757
758    use = cons = NIL;
759    pack = package->data.package.package;
760
761    if (pack->use.length) {
762	GC_ENTER();
763	int i = pack->use.length - 1;
764
765	use = cons = CONS(pack->use.pairs[i], NIL);
766	GC_PROTECT(use);
767	for (--i; i >= 0; i--) {
768	    RPLACD(cons, CONS(pack->use.pairs[i], NIL));
769	    cons = CDR(cons);
770	}
771	GC_LEAVE();
772    }
773
774    return (use);
775}
776
777LispObj *
778Lisp_PackageUsedByList(LispBuiltin *builtin)
779/*
780 package-used-by-list package
781 */
782{
783    GC_ENTER();
784    int i;
785    LispPackage *pack;
786    LispObj *package, *other, *used, *cons, *list;
787
788    package = ARGUMENT(0);
789
790    package = LispFindPackageOrDie(builtin, package);
791
792    used = cons = NIL;
793
794    for (list = PACK; CONSP(list); list = CDR(list)) {
795	other = CAR(list);
796	if (package == other)
797	    /* Surely package uses itself */
798	    continue;
799
800	pack = other->data.package.package;
801
802	for (i = 0; i < pack->use.length; i++) {
803	    if (pack->use.pairs[i] == package) {
804		if (used == NIL) {
805		    used = cons = CONS(other, NIL);
806		    GC_PROTECT(used);
807		}
808		else {
809		    RPLACD(cons, CONS(other, NIL));
810		    cons = CDR(cons);
811		}
812	    }
813	}
814    }
815
816    GC_LEAVE();
817
818    return (used);
819}
820
821LispObj *
822Lisp_Unexport(LispBuiltin *builtin)
823/*
824 unexport symbols &optional package
825 */
826{
827    LispObj *list;
828
829    LispObj *symbols, *package;
830
831    package = ARGUMENT(1);
832    symbols = ARGUMENT(0);
833
834    /* If specified, make sure package is available */
835    if (package != UNSPEC)
836	package = LispFindPackageOrDie(builtin, package);
837    else
838	package = PACKAGE;
839
840    /* Export symbols */
841    if (CONSP(symbols)) {
842	for (list = symbols; CONSP(list); list = CDR(list))
843	    LispDoExport(builtin, package, CAR(list), 0);
844    }
845    else
846	LispDoExport(builtin, package, symbols, 0);
847
848    return (T);
849}
850