/[gcl]/gcl/o/package.d
ViewVC logotype

Diff of /gcl/o/package.d

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.8 by camm, Sun Oct 6 03:59:40 2002 UTC revision 1.9 by camm, Wed Oct 9 03:46:34 2002 UTC
# Line 49  object x, l; Line 49  object x, l;
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;
# Line 115  int isize,esize; Line 147  int isize,esize;
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);
# Line 138  int isize,esize; Line 172  int isize,esize;
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);
# Line 184  int isize,esize; Line 220  int isize,esize;
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);
# Line 205  int isize,esize; Line 243  int isize,esize;
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);
# Line 224  object x, n, ns; Line 262  object x, n, ns;
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);
# Line 236  object x, n, ns; Line 276  object x, n, ns;
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;
# Line 247  object x, n, ns; Line 289  object x, n, ns;
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.
# Line 258  object n; Line 301  object n;
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    
# Line 406  object st, p; Line 443  object st, p;
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)
# Line 607  object s, p; Line 645  object s, p;
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);
# Line 673  object x0, p; Line 712  object x0, p;
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))`)
# Line 690  object x0, p; Line 785  object x0, p;
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);
# Line 705  Lfind_package() Line 801  Lfind_package()
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
# Line 718  Lpackage_nicknames() Line 826  Lpackage_nicknames()
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  @)  @)
# Line 736  Lpackage_use_list() Line 845  Lpackage_use_list()
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  }  }
# Line 746  Lpackage_used_by_list() Line 855  Lpackage_used_by_list()
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  }  }
# Line 756  Lpackage_shadowing_symbols() Line 865  Lpackage_shadowing_symbols()
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  }  }
# Line 778  Llist_all_packages() Line 887  Llist_all_packages()
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)
# Line 794  Llist_all_packages() Line 903  Llist_all_packages()
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)
# Line 809  Llist_all_packages() Line 918  Llist_all_packages()
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)
# Line 821  Llist_all_packages() Line 930  Llist_all_packages()
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)) {
# Line 847  BEGIN: Line 956  BEGIN:
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)) {
# Line 872  BEGIN: Line 981  BEGIN:
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)) {
# Line 897  BEGIN: Line 1006  BEGIN:
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)) {
# Line 922  BEGIN: Line 1031  BEGIN:
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);
# Line 938  BEGIN: Line 1049  BEGIN:
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)
# Line 947  BEGIN: Line 1058  BEGIN:
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)) {
# Line 957  BEGIN: Line 1068  BEGIN:
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    
# Line 975  BEGIN: Line 1087  BEGIN:
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)) {
# Line 985  BEGIN: Line 1097  BEGIN:
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    
# Line 1035  void Line 1148  void
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
# Line 1101  void Line 1214  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);

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26