49 |
return(FALSE); |
return(FALSE); |
50 |
} |
} |
51 |
|
|
52 |
|
static bool |
53 |
|
designate_package(object x,struct package *p) { |
54 |
|
|
55 |
|
switch(type_of(x)) { |
56 |
|
case t_string: case t_symbol: |
57 |
|
return string_equal(x,p->p_name) || member_string_equal(x, p->p_nicknames); |
58 |
|
break; |
59 |
|
case t_character: |
60 |
|
return designate_package(coerce_to_string(x),p); |
61 |
|
break; |
62 |
|
case t_package: |
63 |
|
return x==(object)p; |
64 |
|
break; |
65 |
|
default: |
66 |
|
FEwrong_type_argument(TSor_symbol_string_package,x); |
67 |
|
break; |
68 |
|
} |
69 |
|
return FALSE; |
70 |
|
|
71 |
|
} |
72 |
|
|
73 |
|
/* #define bad_package_name(a) (type_of(a)==t_string &&\ */ |
74 |
|
/* (memchr((a)->st.st_self,'-',(a)->st.st_fillp) || \ */ |
75 |
|
/* ((a)->st.st_self[0]=='*' && (a)->st.st_fillp==1))) */ |
76 |
|
|
77 |
|
#define check_package_designator(a) if (type_of(a)!=t_string && \ |
78 |
|
type_of(a)!=t_character && \ |
79 |
|
type_of(a)!=t_symbol && \ |
80 |
|
type_of(a)!=t_package) \ |
81 |
|
FEwrong_type_argument(TSor_symbol_string_package,(a)) |
82 |
|
#define check_type_or_symbol_string_package(a) check_package_designator(*a) |
83 |
|
|
84 |
void |
void |
85 |
rehash_pack(ptab,n,m) |
rehash_pack(ptab,n,m) |
86 |
object **ptab; |
object **ptab; |
147 |
vs_head->st.st_self = n->s.s_self; |
vs_head->st.st_self = n->s.s_self; |
148 |
n = vs_head; |
n = vs_head; |
149 |
} |
} |
150 |
|
if (type_of(n)==t_character) |
151 |
|
n=coerce_to_string(n); |
152 |
if (find_package(n) != Cnil) |
if (find_package(n) != Cnil) |
153 |
package_already(n); |
package_already(n); |
154 |
x = alloc_object(t_package); |
x = alloc_object(t_package); |
172 |
vs_head->st.st_self = n->s.s_self; |
vs_head->st.st_self = n->s.s_self; |
173 |
n = vs_head; |
n = vs_head; |
174 |
} |
} |
175 |
|
if (type_of(n)==t_character) |
176 |
|
n=coerce_to_string(n); |
177 |
if (find_package(n) != Cnil) { |
if (find_package(n) != Cnil) { |
178 |
vs_reset; |
vs_reset; |
179 |
package_already(n); |
package_already(n); |
220 |
|
|
221 |
x = find_package(n); |
x = find_package(n); |
222 |
if (x == Cnil) { |
if (x == Cnil) { |
223 |
x = make_package(n, ns, ul,isize,esize); |
FEpackage_error(n,"No such package"); |
224 |
goto L; |
return Cnil; |
225 |
|
/* x = make_package(n, ns, ul,isize,esize); */ |
226 |
|
/* goto L; */ |
227 |
} |
} |
228 |
if (isize) rehash_pack(&(x->p.p_internal), |
if (isize) rehash_pack(&(x->p.p_internal), |
229 |
&x->p.p_internal_size,isize); |
&x->p.p_internal_size,isize); |
243 |
} |
} |
244 |
for (; !endp(ul); ul = ul->c.c_cdr) |
for (; !endp(ul); ul = ul->c.c_cdr) |
245 |
use_package(ul->c.c_car, x); |
use_package(ul->c.c_car, x); |
246 |
L: |
/* L: */ |
247 |
sLApackageA->s.s_dbind = x; |
sLApackageA->s.s_dbind = x; |
248 |
vs_reset; |
vs_reset; |
249 |
return(x); |
return(x); |
262 |
vs_head->st.st_self = n->s.s_self; |
vs_head->st.st_self = n->s.s_self; |
263 |
n = vs_head; |
n = vs_head; |
264 |
} |
} |
265 |
|
if (type_of(n)==t_character) |
266 |
|
n=coerce_to_string(n); |
267 |
if (!(equal(x->p.p_name,n)) && |
if (!(equal(x->p.p_name,n)) && |
268 |
find_package(n) != Cnil) |
find_package(n) != Cnil) |
269 |
package_already(n); |
package_already(n); |
276 |
vs_head->st.st_self = n->s.s_self; |
vs_head->st.st_self = n->s.s_self; |
277 |
n = vs_head; |
n = vs_head; |
278 |
} |
} |
279 |
|
if (type_of(n)==t_character) |
280 |
|
n=coerce_to_string(n); |
281 |
y = find_package(n); |
y = find_package(n); |
282 |
if (x == y) |
if (x == y) |
283 |
continue; |
continue; |
289 |
return(x); |
return(x); |
290 |
} |
} |
291 |
|
|
292 |
|
|
293 |
/* |
/* |
294 |
Find_package(n) seaches for a package with name n, |
Find_package(n) seaches for a package with name n, |
295 |
which is a string or a symbol. |
which is a string or a symbol. |
301 |
{ |
{ |
302 |
struct package *p; |
struct package *p; |
303 |
|
|
304 |
if (type_of(n) == t_symbol) |
check_package_designator(n); |
305 |
; |
for (p = pack_pointer; p != NULL; p = p->p_link) |
306 |
else if (type_of(n) != t_string) |
if (designate_package(n,p)) |
307 |
FEwrong_type_argument(TSor_string_symbol, n); |
return ((object)p); |
|
for (p = pack_pointer; p != NULL; p = p->p_link) { |
|
|
if (string_equal(p->p_name, n)) |
|
|
return((object)p); |
|
|
if (member_string_equal(n, p->p_nicknames)) |
|
|
return((object)p); |
|
|
} |
|
308 |
return(Cnil); |
return(Cnil); |
309 |
} |
} |
310 |
|
|
443 |
int j; |
int j; |
444 |
object *ip, *ep, l, ul; |
object *ip, *ep, l, ul; |
445 |
{BEGIN_NO_INTERRUPT; |
{BEGIN_NO_INTERRUPT; |
446 |
|
if (type_of(st)==t_character) st=coerce_to_string(st); |
447 |
j = pack_hash(st); |
j = pack_hash(st); |
448 |
ip = &P_INTERNAL(p ,j); |
ip = &P_INTERNAL(p ,j); |
449 |
for (l = *ip; type_of(l) == t_cons; l = l->c.c_cdr) |
for (l = *ip; type_of(l) == t_cons; l = l->c.c_cdr) |
645 |
int j; |
int j; |
646 |
object *ip; |
object *ip; |
647 |
|
|
648 |
|
if (type_of(s)==t_character) s=coerce_to_string(s); |
649 |
find_symbol(s, p); |
find_symbol(s, p); |
650 |
if (intern_flag == INTERNAL || intern_flag == EXTERNAL) { |
if (intern_flag == INTERNAL || intern_flag == EXTERNAL) { |
651 |
p->p.p_shadowings = make_cons(s, p->p.p_shadowings); |
p->p.p_shadowings = make_cons(s, p->p.p_shadowings); |
712 |
delete_eq(p, &x->p.p_usedbylist); |
delete_eq(p, &x->p.p_usedbylist); |
713 |
} |
} |
714 |
|
|
715 |
|
|
716 |
|
|
717 |
|
object |
718 |
|
delete_package(object n) { |
719 |
|
|
720 |
|
struct package *p,*pp; |
721 |
|
object t; |
722 |
|
|
723 |
|
/* if (type_of(n)!=t_package && type_of(n)!=t_symbol && type_of(n)!=t_string) */ |
724 |
|
/* FEwrong_type_argument(TSor_symbol_string_package, n); */ |
725 |
|
|
726 |
|
for (p = pack_pointer,pp=NULL; p != NULL; pp=p,p = p->p_link) |
727 |
|
|
728 |
|
if (designate_package(n,p)) { |
729 |
|
|
730 |
|
if (p->p_usedbylist!=Cnil) { |
731 |
|
/* VFUN_NARGS=4; */ |
732 |
|
/* fLspecific_correctable_error(sKpackage_error,make_simple_string("Package ~S is used by other packages: ~S"), */ |
733 |
|
/* p,p->p_usedbylist); */ |
734 |
|
/* FEpackage_error((object)p,"Package used by other packages."); */ |
735 |
|
for (t=p->p_usedbylist;!endp(t);t=t->c.c_cdr) |
736 |
|
unuse_package(p,t->c.c_car); |
737 |
|
} |
738 |
|
|
739 |
|
if (p->p_uselist!=Cnil) { |
740 |
|
/* VFUN_NARGS=4; */ |
741 |
|
/* fLspecific_correctable_error(sKpackage_error,make_simple_string("Package ~S is used by other packages: ~S"), */ |
742 |
|
/* p,p->p_usedbylist); */ |
743 |
|
/* FEpackage_error((object)p,"Package used by other packages."); */ |
744 |
|
for (t=p->p_uselist;!endp(t);t=t->c.c_cdr) |
745 |
|
unuse_package(t->c.c_car,p); |
746 |
|
} |
747 |
|
|
748 |
|
p->p_name=Cnil; |
749 |
|
|
750 |
|
if (pp) |
751 |
|
pp->p_link=p->p_link; |
752 |
|
else |
753 |
|
pack_pointer=p->p_link; |
754 |
|
|
755 |
|
return(Ct); |
756 |
|
|
757 |
|
} |
758 |
|
|
759 |
|
/* VFUN_NARGS=3; */ |
760 |
|
/* fLspecific_correctable_error(sKpackage_error,make_simple_string("~S does not designate a package"),n); */ |
761 |
|
/* FEpackage_error(n,"No such pachage."); */ |
762 |
|
|
763 |
|
return(Cnil); |
764 |
|
|
765 |
|
} |
766 |
|
|
767 |
|
/* (use `make_cons(lisp_package, Cnil)`) */ |
768 |
|
|
769 |
|
|
770 |
@(defun make_package (pack_name |
@(defun make_package (pack_name |
771 |
&key nicknames |
&key nicknames |
772 |
(use `make_cons(lisp_package, Cnil)`) |
(use Cnil) |
773 |
(internal `small_fixnum(0)`) |
(internal `small_fixnum(0)`) |
774 |
(external `small_fixnum(0)`) |
(external `small_fixnum(0)`) |
775 |
) |
) |
776 |
@ |
@ |
777 |
|
if (type_of(pack_name)==t_character) pack_name=coerce_to_string(pack_name); |
778 |
check_type_or_string_symbol(&pack_name); |
check_type_or_string_symbol(&pack_name); |
779 |
@(return `make_package(pack_name, nicknames, use, |
@(return `make_package(pack_name, nicknames, use, |
780 |
fix(internal),fix(external))`) |
fix(internal),fix(external))`) |
785 |
(external `small_fixnum(0)`) |
(external `small_fixnum(0)`) |
786 |
) |
) |
787 |
@ |
@ |
788 |
|
if (type_of(pack_name)==t_character) pack_name=coerce_to_string(pack_name); |
789 |
check_type_or_string_symbol(&pack_name); |
check_type_or_string_symbol(&pack_name); |
790 |
if (find_package(pack_name) == Cnil && !(use_sp)) |
if (find_package(pack_name) == Cnil && !(use_sp)) |
791 |
use = make_cons(lisp_package, Cnil); |
use = make_cons(lisp_package, Cnil); |
801 |
} |
} |
802 |
|
|
803 |
void |
void |
804 |
Lpackage_name() |
Ldelete_package() |
805 |
{ |
{ |
806 |
check_arg(1); |
check_arg(1); |
807 |
|
|
808 |
check_type_package(&vs_base[0]); |
vs_base[0] = delete_package(vs_base[0]); |
809 |
vs_base[0] = vs_base[0]->p.p_name; |
} |
810 |
|
|
811 |
|
void |
812 |
|
Lpackage_name() |
813 |
|
{ |
814 |
|
object t; |
815 |
|
|
816 |
|
check_arg(1); |
817 |
|
|
818 |
|
check_package_designator(vs_base[0]); |
819 |
|
t=coerce_to_package(vs_base[0]); |
820 |
|
vs_base[0]=t==Cnil ? t : t->p.p_name; |
821 |
|
|
822 |
} |
} |
823 |
|
|
824 |
void |
void |
826 |
{ |
{ |
827 |
check_arg(1); |
check_arg(1); |
828 |
|
|
829 |
check_type_or_symbol_string_package(&vs_base[0]); |
check_package_designator(vs_base[0]); |
830 |
vs_base[0] = coerce_to_package(vs_base[0]); |
vs_base[0] = coerce_to_package(vs_base[0]); |
831 |
vs_base[0] = vs_base[0]->p.p_nicknames; |
vs_base[0] = vs_base[0]->p.p_nicknames; |
832 |
} |
} |
833 |
|
|
834 |
@(defun rename_package (pack new_name &o new_nicknames) |
@(defun rename_package (pack new_name &o new_nicknames) |
835 |
@ |
@ |
836 |
check_type_or_symbol_string_package(&pack); |
check_package_designator(pack); |
837 |
pack = coerce_to_package(pack); |
pack = coerce_to_package(pack); |
838 |
|
if (type_of(new_name)==t_character) new_name=coerce_to_string(new_name); |
839 |
check_type_or_string_symbol(&new_name); |
check_type_or_string_symbol(&new_name); |
840 |
@(return `rename_package(pack, new_name, new_nicknames)`) |
@(return `rename_package(pack, new_name, new_nicknames)`) |
841 |
@) |
@) |
845 |
{ |
{ |
846 |
check_arg(1); |
check_arg(1); |
847 |
|
|
848 |
check_type_or_symbol_string_package(&vs_base[0]); |
check_package_designator(vs_base[0]); |
849 |
vs_base[0] = coerce_to_package(vs_base[0]); |
vs_base[0] = coerce_to_package(vs_base[0]); |
850 |
vs_base[0] = vs_base[0]->p.p_uselist; |
vs_base[0] = vs_base[0]->p.p_uselist; |
851 |
} |
} |
855 |
{ |
{ |
856 |
check_arg(1); |
check_arg(1); |
857 |
|
|
858 |
check_type_or_symbol_string_package(&vs_base[0]); |
check_package_designator(vs_base[0]); |
859 |
vs_base[0] = coerce_to_package(vs_base[0]); |
vs_base[0] = coerce_to_package(vs_base[0]); |
860 |
vs_base[0] = vs_base[0]->p.p_usedbylist; |
vs_base[0] = vs_base[0]->p.p_usedbylist; |
861 |
} |
} |
865 |
{ |
{ |
866 |
check_arg(1); |
check_arg(1); |
867 |
|
|
868 |
check_type_or_symbol_string_package(&vs_base[0]); |
check_package_designator(vs_base[0]); |
869 |
vs_base[0] = coerce_to_package(vs_base[0]); |
vs_base[0] = coerce_to_package(vs_base[0]); |
870 |
vs_base[0] = vs_base[0]->p.p_shadowings; |
vs_base[0] = vs_base[0]->p.p_shadowings; |
871 |
} |
} |
887 |
@(defun intern (strng &optional (p `current_package()`) &aux sym) |
@(defun intern (strng &optional (p `current_package()`) &aux sym) |
888 |
@ |
@ |
889 |
check_type_string(&strng); |
check_type_string(&strng); |
890 |
check_type_or_symbol_string_package(&p); |
check_package_designator(p); |
891 |
p = coerce_to_package(p); |
p = coerce_to_package(p); |
892 |
sym = intern(strng, p); |
sym = intern(strng, p); |
893 |
if (intern_flag == INTERNAL) |
if (intern_flag == INTERNAL) |
903 |
object x; |
object x; |
904 |
@ |
@ |
905 |
check_type_string(&strng); |
check_type_string(&strng); |
906 |
check_type_or_symbol_string_package(&p); |
check_package_designator(p); |
907 |
p = coerce_to_package(p); |
p = coerce_to_package(p); |
908 |
x = find_symbol(strng, p); |
x = find_symbol(strng, p); |
909 |
if (intern_flag == INTERNAL) |
if (intern_flag == INTERNAL) |
918 |
@(defun unintern (symbl &optional (p `current_package()`)) |
@(defun unintern (symbl &optional (p `current_package()`)) |
919 |
@ |
@ |
920 |
check_type_symbol(&symbl); |
check_type_symbol(&symbl); |
921 |
check_type_or_symbol_string_package(&p); |
check_package_designator(p); |
922 |
p = coerce_to_package(p); |
p = coerce_to_package(p); |
923 |
if (unintern(symbl, p)) |
if (unintern(symbl, p)) |
924 |
@(return Ct) |
@(return Ct) |
930 |
object l; |
object l; |
931 |
|
|
932 |
@ |
@ |
933 |
check_type_or_symbol_string_package(&pack); |
check_package_designator(pack); |
934 |
pack = coerce_to_package(pack); |
pack = coerce_to_package(pack); |
935 |
BEGIN: |
BEGIN: |
936 |
switch (type_of(symbols)) { |
switch (type_of(symbols)) { |
956 |
object l; |
object l; |
957 |
|
|
958 |
@ |
@ |
959 |
check_type_or_symbol_string_package(&pack); |
check_package_designator(pack); |
960 |
pack = coerce_to_package(pack); |
pack = coerce_to_package(pack); |
961 |
BEGIN: |
BEGIN: |
962 |
switch (type_of(symbols)) { |
switch (type_of(symbols)) { |
981 |
@(defun import (symbols &o (pack `current_package()`)) |
@(defun import (symbols &o (pack `current_package()`)) |
982 |
object l; |
object l; |
983 |
@ |
@ |
984 |
check_type_or_symbol_string_package(&pack); |
check_package_designator(pack); |
985 |
pack = coerce_to_package(pack); |
pack = coerce_to_package(pack); |
986 |
BEGIN: |
BEGIN: |
987 |
switch (type_of(symbols)) { |
switch (type_of(symbols)) { |
1006 |
@(defun shadowing_import (symbols &o (pack `current_package()`)) |
@(defun shadowing_import (symbols &o (pack `current_package()`)) |
1007 |
object l; |
object l; |
1008 |
@ |
@ |
1009 |
check_type_or_symbol_string_package(&pack); |
check_package_designator(pack); |
1010 |
pack = coerce_to_package(pack); |
pack = coerce_to_package(pack); |
1011 |
BEGIN: |
BEGIN: |
1012 |
switch (type_of(symbols)) { |
switch (type_of(symbols)) { |
1031 |
@(defun shadow (symbols &o (pack `current_package()`)) |
@(defun shadow (symbols &o (pack `current_package()`)) |
1032 |
object l; |
object l; |
1033 |
@ |
@ |
1034 |
check_type_or_symbol_string_package(&pack); |
check_package_designator(pack); |
1035 |
pack = coerce_to_package(pack); |
pack = coerce_to_package(pack); |
1036 |
BEGIN: |
BEGIN: |
1037 |
switch (type_of(symbols)) { |
switch (type_of(symbols)) { |
1038 |
case t_symbol: |
case t_symbol: |
1039 |
|
case t_string: |
1040 |
|
case t_character: |
1041 |
if (symbols == Cnil) |
if (symbols == Cnil) |
1042 |
break; |
break; |
1043 |
shadow(symbols, pack); |
shadow(symbols, pack); |
1049 |
break; |
break; |
1050 |
|
|
1051 |
default: |
default: |
1052 |
check_type_symbol(&symbols); |
check_type_or_symbol_string(&symbols); |
1053 |
goto BEGIN; |
goto BEGIN; |
1054 |
} |
} |
1055 |
@(return Ct) |
@(return Ct) |
1058 |
@(defun use_package (pack &o (pa `current_package()`)) |
@(defun use_package (pack &o (pa `current_package()`)) |
1059 |
object l; |
object l; |
1060 |
@ |
@ |
1061 |
check_type_or_symbol_string_package(&pa); |
check_package_designator(pa); |
1062 |
pa = coerce_to_package(pa); |
pa = coerce_to_package(pa); |
1063 |
BEGIN: |
BEGIN: |
1064 |
switch (type_of(pack)) { |
switch (type_of(pack)) { |
1068 |
|
|
1069 |
case t_string: |
case t_string: |
1070 |
case t_package: |
case t_package: |
1071 |
|
case t_character: |
1072 |
use_package(pack, pa); |
use_package(pack, pa); |
1073 |
break; |
break; |
1074 |
|
|
1087 |
@(defun unuse_package (pack &o (pa `current_package()`)) |
@(defun unuse_package (pack &o (pa `current_package()`)) |
1088 |
object l; |
object l; |
1089 |
@ |
@ |
1090 |
check_type_or_symbol_string_package(&pa); |
check_package_designator(pa); |
1091 |
pa = coerce_to_package(pa); |
pa = coerce_to_package(pa); |
1092 |
BEGIN: |
BEGIN: |
1093 |
switch (type_of(pack)) { |
switch (type_of(pack)) { |
1097 |
|
|
1098 |
case t_string: |
case t_string: |
1099 |
case t_package: |
case t_package: |
1100 |
|
case t_character: |
1101 |
unuse_package(pack, pa); |
unuse_package(pack, pa); |
1102 |
break; |
break; |
1103 |
|
|
1148 |
no_package(n) |
no_package(n) |
1149 |
object n; |
object n; |
1150 |
{ |
{ |
1151 |
FEerror("There is no package with the name ~A.", 1, n); |
FEwrong_type_argument(TSor_symbol_string_package,n); |
1152 |
} |
} |
1153 |
|
|
1154 |
void |
void |
1214 |
init_package_function() |
init_package_function() |
1215 |
{ |
{ |
1216 |
make_function("MAKE-PACKAGE", Lmake_package); |
make_function("MAKE-PACKAGE", Lmake_package); |
1217 |
|
make_function("DELETE-PACKAGE", Ldelete_package); |
1218 |
make_function("IN-PACKAGE", Lin_package); |
make_function("IN-PACKAGE", Lin_package); |
1219 |
make_function("FIND-PACKAGE", Lfind_package); |
make_function("FIND-PACKAGE", Lfind_package); |
1220 |
make_function("PACKAGE-NAME", Lpackage_name); |
make_function("PACKAGE-NAME", Lpackage_name); |