← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to o/.#package.d.1.19

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
o/.#package.d.1.19
 
1
/*
 
2
 Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
 
3
 
 
4
This file is part of GNU Common Lisp, herein referred to as GCL
 
5
 
 
6
GCL is free software; you can redistribute it and/or modify it under
 
7
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
 
8
the Free Software Foundation; either version 2, or (at your option)
 
9
any later version.
 
10
 
 
11
GCL is distributed in the hope that it will be useful, but WITHOUT
 
12
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 
13
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
 
14
License for more details.
 
15
 
 
16
You should have received a copy of the GNU Library General Public License 
 
17
along with GCL; see the file COPYING.  If not, write to the Free Software
 
18
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
19
*/
 
20
 
 
21
/*
 
22
        package.d
 
23
*/
 
24
 
 
25
#include <string.h>
 
26
#include "include.h"
 
27
 
 
28
#define HASHCOEF        12345           /*  hashing coefficient  */
 
29
 
 
30
void check_type_or_symbol_string_package(object *);
 
31
 
 
32
#define INTERNAL        1
 
33
#define EXTERNAL        2
 
34
#define INHERITED       3
 
35
 
 
36
#define P_INTERNAL(x,j) ((x)->p.p_internal[(j) % (x)->p.p_internal_size])
 
37
#define P_EXTERNAL(x,j) ((x)->p.p_external[(j) % (x)->p.p_external_size])
 
38
 
 
39
 
 
40
 
 
41
 
 
42
static bool
 
43
member_string_equal(x, l)
 
44
object x, l;
 
45
{
 
46
        for (;  type_of(l) == t_cons;  l = l->c.c_cdr)
 
47
                if (string_equal(x, l->c.c_car))
 
48
                        return(TRUE);
 
49
        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
static void
 
85
rehash_pack(ptab,n,m)
 
86
     object **ptab;
 
87
     int *n,m;
 
88
{ object *ntab;
 
89
  object *tab = *ptab;
 
90
  object l,ll;
 
91
  int k,i;
 
92
  i=0;
 
93
  k = *n;
 
94
  {BEGIN_NO_INTERRUPT;
 
95
  ntab= AR_ALLOC(alloc_contblock,m,object);
 
96
  *ptab = ntab;
 
97
  *n=m;
 
98
  while(i<m) ntab[i++]=Cnil;
 
99
   for(i=0 ; i< k; i++)
 
100
        for (l = tab[i];  type_of(l) == t_cons;)
 
101
          {int j =pack_hash(l->c.c_car)%m;
 
102
           ll=l->c.c_cdr;
 
103
           l->c.c_cdr = ntab[j];
 
104
           ntab[j]=l;
 
105
           l=ll;
 
106
         }
 
107
   END_NO_INTERRUPT;}
 
108
}
 
109
 
 
110
/* some prime numbers suitable for package sizes */
 
111
 
 
112
static int package_sizes[]={
 
113
  97,251, 509, 1021, 2039, 4093, 8191, 16381,
 
114
  32749, 65521, 131071, 262139,   524287, 1048573};
 
115
 
 
116
static int
 
117
suitable_package_size(n)
 
118
{int *i=package_sizes;
 
119
 if (n>= 1000000) return 1048573;
 
120
 while(*i < n) { i++;}
 
121
 return *i;}
 
122
   
 
123
/*
 
124
        Make_package(n, ns, ul, isize , esize) makes a package with name n,
 
125
        which must be a string or a symbol,
 
126
        and nicknames ns, which must be a list of strings or symbols,
 
127
        and uses packages in list ul, which must be a list of packages
 
128
        or package names i.e. strings or symbols.
 
129
*/
 
130
static void
 
131
package_already(object);
 
132
static void
 
133
no_package(object);
 
134
 
 
135
static object
 
136
make_package(n, ns, ul,isize,esize)
 
137
object n, ns, ul;
 
138
int isize,esize;
 
139
{
 
140
 
 
141
        object x, y;
 
142
        int i;
 
143
        vs_mark;
 
144
        { BEGIN_NO_INTERRUPT;
 
145
        if (type_of(n) == t_symbol) {
 
146
                vs_push(alloc_simple_string(n->s.s_fillp));
 
147
                vs_head->st.st_self = n->s.s_self;
 
148
                n = vs_head;
 
149
        }
 
150
        if (type_of(n)==t_character) 
 
151
          n=coerce_to_string(n);
 
152
        if (find_package(n) != Cnil)
 
153
                package_already(n);
 
154
        x = alloc_object(t_package);
 
155
        x->p.p_name = n;
 
156
        x->p.p_nicknames = Cnil;
 
157
        x->p.p_shadowings = Cnil;
 
158
        x->p.p_uselist = Cnil;
 
159
        x->p.p_usedbylist = Cnil;
 
160
        x->p.p_internal = NULL;
 
161
        x->p.p_external = NULL;
 
162
        x->p.p_internal_size = (isize ? isize : suitable_package_size(200));
 
163
        x->p.p_external_size = (esize ? esize : suitable_package_size(60));
 
164
        x->p.p_internal_fp =0;   
 
165
        x->p.p_external_fp =0;
 
166
        
 
167
        vs_push(x);
 
168
        for (;  !endp(ns);  ns = ns->c.c_cdr) {
 
169
                n = ns->c.c_car;
 
170
                if (type_of(n) == t_symbol) {
 
171
                        vs_push(alloc_simple_string(n->s.s_fillp));
 
172
                        vs_head->st.st_self = n->s.s_self;
 
173
                        n = vs_head;
 
174
                }
 
175
                if (type_of(n)==t_character)
 
176
                  n=coerce_to_string(n);
 
177
                if (find_package(n) != Cnil) {
 
178
                        vs_reset;
 
179
                        package_already(n);
 
180
                }
 
181
                x->p.p_nicknames = make_cons(n, x->p.p_nicknames);
 
182
        }
 
183
        for (;  !endp(ul);  ul = ul->c.c_cdr) {
 
184
                if (type_of(ul->c.c_car) == t_package)
 
185
                        y = ul->c.c_car;
 
186
                else {
 
187
                        y = find_package(ul->c.c_car);
 
188
                        if (y == Cnil)
 
189
                                no_package(ul->c.c_car);
 
190
                }
 
191
                x->p.p_uselist = make_cons(y, x->p.p_uselist);
 
192
                y->p.p_usedbylist = make_cons(x, y->p.p_usedbylist);
 
193
        }
 
194
        x->p.p_internal
 
195
        = AR_ALLOC(alloc_contblock,x->p.p_internal_size,object);
 
196
        for (i = 0;  i < x->p.p_internal_size;  i++)
 
197
                x->p.p_internal[i] = Cnil;
 
198
        x->p.p_external
 
199
        = AR_ALLOC(alloc_contblock,x->p.p_external_size,object);
 
200
        for (i = 0;  i < x->p.p_external_size;  i++)
 
201
                x->p.p_external[i] = Cnil;
 
202
        x->p.p_link = pack_pointer;
 
203
        pack_pointer = &(x->p);
 
204
        vs_reset;
 
205
        END_NO_INTERRUPT;}      
 
206
        return(x);
 
207
}
 
208
 
 
209
static void
 
210
use_package(object,object);
 
211
 
 
212
static object
 
213
in_package(n, ns, ul,isize,esize)
 
214
object n, ns, ul;
 
215
int isize,esize;
 
216
{
 
217
 
 
218
        object x, y;
 
219
        vs_mark;
 
220
 
 
221
        x = find_package(n);
 
222
        if (x == Cnil) {
 
223
#ifdef ANSI_COMMON_LISP
 
224
                FEpackage_error(n,"No such package");  
 
225
                return Cnil; 
 
226
#else
 
227
                x = make_package(n, ns, ul,isize,esize);
 
228
                goto L;
 
229
#endif
 
230
        }
 
231
        if (isize) rehash_pack(&(x->p.p_internal),
 
232
                &x->p.p_internal_size,isize);
 
233
        for (;  !endp(ns);  ns = ns->c.c_cdr) {
 
234
                n = ns->c.c_car;
 
235
                if (type_of(n) == t_symbol) {
 
236
                        vs_push(alloc_simple_string(n->s.s_fillp));
 
237
                        vs_head->st.st_self = n->s.s_self;
 
238
                        n = vs_head;
 
239
                }
 
240
                y = find_package(n);
 
241
                if (x == y)
 
242
                        continue;
 
243
                if (y != Cnil)
 
244
                        package_already(n);
 
245
                x->p.p_nicknames = make_cons(n, x->p.p_nicknames);
 
246
        }
 
247
        for (;  !endp(ul);  ul = ul->c.c_cdr)
 
248
                use_package(ul->c.c_car, x);
 
249
#ifndef ANSI_COMMON_LISP
 
250
L:
 
251
#endif
 
252
        sLApackageA->s.s_dbind = x;
 
253
        vs_reset;
 
254
        return(x);
 
255
}
 
256
 
 
257
static object
 
258
rename_package(x, n, ns)
 
259
object x, n, ns;
 
260
{
 
261
 
 
262
        object y;
 
263
        vs_mark;
 
264
 
 
265
        if (type_of(n) == t_symbol) {
 
266
                vs_push(alloc_simple_string(n->s.s_fillp));
 
267
                vs_head->st.st_self = n->s.s_self;
 
268
                n = vs_head;
 
269
        }
 
270
        if (type_of(n)==t_character)
 
271
          n=coerce_to_string(n);
 
272
        if (!(equal(x->p.p_name,n)) &&
 
273
            find_package(n) != Cnil)
 
274
                package_already(n);
 
275
        x->p.p_name = n;
 
276
        x->p.p_nicknames = Cnil;
 
277
        for (;  !endp(ns);  ns = ns->c.c_cdr) {
 
278
                n = ns->c.c_car;
 
279
                if (type_of(n) == t_symbol) {
 
280
                        vs_push(alloc_simple_string(n->s.s_fillp));
 
281
                        vs_head->st.st_self = n->s.s_self;
 
282
                        n = vs_head;
 
283
                }
 
284
                if (type_of(n)==t_character)
 
285
                  n=coerce_to_string(n);
 
286
                y = find_package(n);
 
287
                if (x == y)
 
288
                        continue;
 
289
                if (y != Cnil)
 
290
                        package_already(n);
 
291
                x->p.p_nicknames = make_cons(n, x->p.p_nicknames);
 
292
        }
 
293
        vs_reset;
 
294
        return(x);
 
295
}
 
296
 
 
297
 
 
298
/*
 
299
        Find_package(n) seaches for a package with name n,
 
300
        which is a string or a symbol.
 
301
        If not so, an error is signaled.
 
302
*/
 
303
object
 
304
find_package(n)
 
305
object n;
 
306
{
 
307
        struct package *p;
 
308
 
 
309
        check_package_designator(n);
 
310
        for (p = pack_pointer;  p != NULL;  p = p->p_link) 
 
311
          if (designate_package(n,p))
 
312
            return ((object)p);
 
313
        return(Cnil);
 
314
}
 
315
 
 
316
static object
 
317
coerce_to_package(p)
 
318
object p;
 
319
{
 
320
        object pp;
 
321
 
 
322
        if (type_of(p) == t_package)
 
323
                return(p);
 
324
        pp = find_package(p);
 
325
        if (pp == Cnil)
 
326
                no_package(p);
 
327
        return(pp);
 
328
}
 
329
 
 
330
object
 
331
current_package()
 
332
{
 
333
        object x;
 
334
 
 
335
        x = symbol_value(sLApackageA);
 
336
        if (type_of(x) != t_package) {
 
337
                sLApackageA->s.s_dbind = user_package;
 
338
                FEerror("The value of *PACKAGE*, ~S, was not a package.",
 
339
                        1, x);
 
340
        }
 
341
        return(x);
 
342
}
 
343
 
 
344
/*
 
345
        Pack_hash(st) hashes string st
 
346
        and returns the index for a hash table of a package.
 
347
*/
 
348
 
 
349
int
 
350
pack_hash(x)
 
351
object x;
 
352
{unsigned int h=0;
 
353
 {int len=x->st.st_fillp;
 
354
  char *s;
 
355
#define HADD(i,j,k,l) (h+=s[i],h+=s[j]<<8,h+=s[k]<<13,h+=s[l]<<23)
 
356
#define HADD2(i,j) (h+=s[i]<<5,h+=s[j]<<15)
 
357
  s=x->st.st_self;
 
358
  switch(len) {
 
359
  case 0: break;
 
360
  case 10: 
 
361
  case 9: HADD(1,4,6,8); HADD2(5,7); goto END;
 
362
  case 8: HADD(1,3,5,7); HADD2(2,4); goto END;
 
363
  case 7: HADD(1,3,4,5); HADD2(6,2); goto END;
 
364
  case 6: HADD(1,3,4,5); HADD2(0,2); goto END;
 
365
  case 5: h+= s[4] << 13;
 
366
  case 4: h+= s[3] << 24;
 
367
  case 3: h+= s[2]<< 16;
 
368
  case 2: h+= s[1] << 8;
 
369
  case 1: h+= s[0] ;
 
370
    break;
 
371
  default:
 
372
    HADD(3,6,len-2,len-4); HADD2(1,len-1);
 
373
    if (len > 15) {HADD2(7,10);            
 
374
                 }
 
375
  }
 
376
 END:
 
377
  h &= 0x7fffffff; 
 
378
  return(h);
 
379
}}
 
380
 
 
381
 
 
382
 
 
383
/*
 
384
        Intern(st, p) interns string st in package p.
 
385
*/
 
386
object
 
387
intern(st, p)
 
388
object st, p;
 
389
{
 
390
        int j;
 
391
        object x, *ip, *ep, l, ul;
 
392
        vs_mark;
 
393
 
 
394
        {BEGIN_NO_INTERRUPT;
 
395
 
 
396
        if (st->st.st_fillp==4 && !strncmp(st->st.st_self,"INFO",4) && p->p.p_name->st.st_fillp==4 && !strncmp(p->p.p_name->st.st_self,"LISP",4))
 
397
                printf("hello\n");
 
398
        j = pack_hash(st);
 
399
        ip = &P_INTERNAL(p ,j);
 
400
#define string_eq(a,b) \
 
401
   ((a)->st.st_fillp==(b)->st.st_fillp && \
 
402
         bcmp((a)->st.st_self,(b)->st.st_self,(a)->st.st_fillp)==0)
 
403
 
 
404
        for (l = *ip;  type_of(l) == t_cons;  l = l->c.c_cdr)
 
405
                if (string_eq(l->c.c_car, st)) {
 
406
                        intern_flag = INTERNAL;
 
407
                        END_NO_INTERRUPT;return(l->c.c_car);
 
408
                }
 
409
        ep = &P_EXTERNAL(p,j);
 
410
        for (l = *ep;  type_of(l) == t_cons;  l = l->c.c_cdr)
 
411
                if (string_eq(l->c.c_car, st)) {
 
412
                        intern_flag = EXTERNAL;
 
413
                        END_NO_INTERRUPT;return(l->c.c_car);
 
414
                }
 
415
        for (ul=p->p.p_uselist; type_of(ul)==t_cons; ul=ul->c.c_cdr)
 
416
                for (l = P_EXTERNAL(ul->c.c_car,j);
 
417
                     type_of(l) == t_cons;
 
418
                     l = l->c.c_cdr)
 
419
                        if (string_eq(l->c.c_car, st)) {
 
420
                                intern_flag = INHERITED;
 
421
                                END_NO_INTERRUPT;return(l->c.c_car);
 
422
                        }
 
423
        x = make_symbol(st);
 
424
        vs_push(x);
 
425
        if (p == keyword_package) {
 
426
                x->s.s_stype = (short)stp_constant;
 
427
                x->s.s_dbind = x;
 
428
                *ep = make_cons(x, *ep);
 
429
                keyword_package->p.p_external_fp ++;
 
430
                intern_flag = 0;
 
431
        } else {
 
432
                *ip = make_cons(x, *ip);
 
433
                if (p->p.p_internal_fp++>(p->p.p_internal_size << 1))
 
434
                        rehash_pack(&(p->p.p_internal),&p->p.p_internal_size,
 
435
                                    suitable_package_size(p->p.p_internal_fp));
 
436
                intern_flag = 0;
 
437
        }
 
438
        if (x->s.s_hpack == Cnil)
 
439
                x->s.s_hpack = p;
 
440
        vs_reset;
 
441
        END_NO_INTERRUPT;return(x);
 
442
}}
 
443
 
 
444
/*
 
445
        Find_symbol(st, p) searches for string st in package p.
 
446
*/
 
447
object
 
448
find_symbol(st, p)
 
449
object st, p;
 
450
{
 
451
        int j;
 
452
        object *ip, *ep, l, ul;
 
453
        {BEGIN_NO_INTERRUPT;
 
454
        if (type_of(st)==t_character) st=coerce_to_string(st);
 
455
        j = pack_hash(st);
 
456
        ip = &P_INTERNAL(p ,j);
 
457
        for (l = *ip;  type_of(l) == t_cons;  l = l->c.c_cdr)
 
458
                if (string_eq(l->c.c_car, st)) {
 
459
                        intern_flag = INTERNAL;
 
460
                        END_NO_INTERRUPT;return(l->c.c_car);
 
461
                }
 
462
        ep = &P_EXTERNAL(p,j);
 
463
        for (l = *ep;  type_of(l) == t_cons;  l = l->c.c_cdr)
 
464
                if (string_eq(l->c.c_car, st)) {
 
465
                        intern_flag = EXTERNAL;
 
466
                        END_NO_INTERRUPT;return(l->c.c_car);
 
467
                }
 
468
        for (ul=p->p.p_uselist; type_of(ul)==t_cons; ul=ul->c.c_cdr)
 
469
                for (l = P_EXTERNAL(ul->c.c_car,j);
 
470
                     type_of(l) == t_cons;
 
471
                     l = l->c.c_cdr)
 
472
                        if (string_eq(l->c.c_car, st)) {
 
473
                                intern_flag = INHERITED;
 
474
                                END_NO_INTERRUPT;return(l->c.c_car);
 
475
                        }
 
476
        intern_flag = 0;
 
477
        END_NO_INTERRUPT;return(Cnil);
 
478
}}
 
479
 
 
480
static bool
 
481
unintern(s, p)
 
482
object s, p;
 
483
{
 
484
        object x, y, l, *lp;
 
485
        int j;
 
486
        {BEGIN_NO_INTERRUPT;
 
487
        j = pack_hash(s);
 
488
        x = find_symbol(s, p);
 
489
        if (intern_flag == INTERNAL && s == x) {
 
490
                lp = &P_INTERNAL(p ,j);
 
491
                if (member_eq(s, p->p.p_shadowings))
 
492
                        goto L;
 
493
                goto UNINTERN;
 
494
        }
 
495
        if (intern_flag == EXTERNAL && s == x) {
 
496
                lp = &P_EXTERNAL(p,j);
 
497
                if (member_eq(s, p->p.p_shadowings))
 
498
                        goto L;
 
499
                goto UNINTERN;
 
500
        }
 
501
        END_NO_INTERRUPT;return(FALSE);
 
502
 
 
503
L:
 
504
        x = OBJNULL;
 
505
        for (l = p->p.p_uselist; type_of(l) == t_cons; l = l->c.c_cdr) {
 
506
                y = find_symbol(s, l->c.c_car);
 
507
                if (intern_flag == EXTERNAL) {
 
508
                        if (x == OBJNULL)
 
509
                                x = y;
 
510
                        else if (x != y)
 
511
                          FEpackage_error(p,"Cannot unintern the shadowing symbol"\
 
512
                                          "as it will produce a name conflict");
 
513
                }
 
514
        }
 
515
        delete_eq(s, &p->p.p_shadowings);
 
516
 
 
517
UNINTERN:
 
518
        delete_eq(s, lp);
 
519
        if (s->s.s_hpack == p)
 
520
                s->s.s_hpack = Cnil;
 
521
        if ((enum stype)s->s.s_stype != stp_ordinary)
 
522
                uninterned_list = make_cons(s, uninterned_list);
 
523
        END_NO_INTERRUPT;return(TRUE);
 
524
}}
 
525
 
 
526
void
 
527
export(s, p)
 
528
object s, p;
 
529
{
 
530
        object x;
 
531
        int j;
 
532
        object *ep, *ip, l;
 
533
 
 
534
BEGIN:
 
535
        ip = NULL;
 
536
        j = pack_hash(s);
 
537
        x = find_symbol(s, p);
 
538
        if (intern_flag) {
 
539
                if (x != s) {
 
540
                        import(s, p);   /*  signals an error  */
 
541
                        goto BEGIN;
 
542
                }
 
543
                if (intern_flag == INTERNAL)
 
544
                        ip = &P_INTERNAL(p ,j);
 
545
                else if (intern_flag == EXTERNAL)
 
546
                        return;
 
547
        } else
 
548
                FEpackage_error(p,"Symbol not accessible.");
 
549
        for (l = p->p.p_usedbylist;
 
550
             type_of(l) == t_cons;
 
551
             l = l->c.c_cdr) {
 
552
                x = find_symbol(s, l->c.c_car);
 
553
                if (intern_flag && s != x &&
 
554
                    !member_eq(x, l->c.c_car->p.p_shadowings))
 
555
                  FEpackage_error(p,"Cannot export symbol as it will produce a name conflict.");
 
556
        }
 
557
        if (ip != NULL)
 
558
                {delete_eq(s, ip);
 
559
                 p->p.p_internal_fp--;}
 
560
        ep = &P_EXTERNAL(p,j);
 
561
        p->p.p_external_fp++;
 
562
        *ep = make_cons(s, *ep);
 
563
}
 
564
 
 
565
static void
 
566
unexport(s, p)
 
567
object s, p;
 
568
{
 
569
        object x, *ep, *ip;
 
570
        int j;
 
571
 
 
572
        if (p == keyword_package)
 
573
                FEpackage_error(p,"Cannot unexport a symbol from the keyword.");
 
574
        x = find_symbol(s, p);
 
575
        if (/* intern_flag != EXTERNAL || */ x != s)
 
576
          FEpackage_error(p,"Symbol not in package.");
 
577
/* "Cannot unexport the symbol ~S~%\ */
 
578
/* from ~S,~%\ */
 
579
/* because the symbol is not an external symbol~%\ */
 
580
/* of the package.", 2, s, p); */
 
581
        j = pack_hash(s);
 
582
        ep = &P_EXTERNAL(p,j);
 
583
        delete_eq(s, ep);
 
584
        ip = &P_INTERNAL(p ,j);
 
585
        p->p.p_internal_fp++;
 
586
        *ip = make_cons(s, *ip);
 
587
}
 
588
 
 
589
void
 
590
import(s, p)
 
591
object s, p;
 
592
{
 
593
        object x;
 
594
        int j;
 
595
        object *ip;
 
596
 
 
597
        x = find_symbol(s, p);
 
598
        if (intern_flag) {
 
599
                if (x != s)
 
600
                  FEpackage_error(p,"Cannot import symbol as it will produce a name conflict");
 
601
                if (intern_flag == INTERNAL || intern_flag == EXTERNAL)
 
602
                        return;
 
603
        }
 
604
        j = pack_hash(s);
 
605
        ip = &P_INTERNAL(p ,j);
 
606
        p->p.p_internal_fp++;
 
607
        *ip = make_cons(s, *ip);
 
608
}
 
609
 
 
610
static void
 
611
shadowing_import(s, p)
 
612
object s, p;
 
613
{
 
614
        object x, *ip;
 
615
 
 
616
        x = find_symbol(s, p);
 
617
        if (intern_flag && intern_flag != INHERITED) {
 
618
                if (x == s) {
 
619
                        if (!member_eq(x, p->p.p_shadowings))
 
620
                                p->p.p_shadowings
 
621
                                = make_cons(x, p->p.p_shadowings);
 
622
                        return;
 
623
                }
 
624
                if(member_eq(x, p->p.p_shadowings))
 
625
                        delete_eq(x, &p->p.p_shadowings);
 
626
                if (intern_flag == INTERNAL)
 
627
                        delete_eq(x, &P_INTERNAL(p,pack_hash(x)));
 
628
                else
 
629
                        delete_eq(x, &P_EXTERNAL(p ,pack_hash(x)));
 
630
                if (x->s.s_hpack == p)
 
631
                        x->s.s_hpack = Cnil;
 
632
                if ((enum stype)x->s.s_stype != stp_ordinary)
 
633
                        uninterned_list = make_cons(x, uninterned_list);
 
634
        }
 
635
        ip = &P_INTERNAL(p ,pack_hash(s));
 
636
        *ip = make_cons(s, *ip);
 
637
        p->p.p_internal_fp++;   
 
638
        p->p.p_shadowings = make_cons(s, p->p.p_shadowings);
 
639
}
 
640
 
 
641
static void
 
642
shadow(s, p)
 
643
object s, p;
 
644
{
 
645
        int j;
 
646
        object *ip;
 
647
 
 
648
        if (type_of(s)==t_character) s=coerce_to_string(s);
 
649
        find_symbol(s, p);
 
650
        if (intern_flag == INTERNAL || intern_flag == EXTERNAL) {
 
651
                p->p.p_shadowings = make_cons(s, p->p.p_shadowings);
 
652
                return;
 
653
        }
 
654
        j = pack_hash(s);
 
655
        ip = &P_INTERNAL(p ,j);
 
656
        vs_push(make_symbol(s));
 
657
        vs_head->s.s_hpack = p;
 
658
        *ip = make_cons(vs_head, *ip);
 
659
        p->p.p_internal_fp++;
 
660
        p->p.p_shadowings = make_cons(vs_head, p->p.p_shadowings);
 
661
        vs_popp;
 
662
}
 
663
 
 
664
static void
 
665
use_package(x0, p)
 
666
object x0, p;
 
667
{
 
668
        object x = x0;
 
669
        int i;
 
670
        object y, l;
 
671
 
 
672
        if (type_of(x) != t_package) {
 
673
                x = find_package(x);
 
674
                if (x == Cnil)
 
675
                        no_package(x0);
 
676
        }
 
677
        if (x == keyword_package)
 
678
                FEpackage_error(x,"Cannot use keyword package.");
 
679
        if (p == x)
 
680
                return;
 
681
        if (member_eq(x, p->p.p_uselist))
 
682
                return;
 
683
        for (i = 0;  i < x->p.p_external_size;  i++)
 
684
                for (l = P_EXTERNAL(x ,i);
 
685
                     type_of(l) == t_cons;
 
686
                     l = l->c.c_cdr) {
 
687
                        y = find_symbol(l->c.c_car, p);
 
688
                        if (intern_flag && l->c.c_car != y
 
689
                            && ! member_eq(y,p->p.p_shadowings)
 
690
                            )
 
691
                          FEpackage_error(p,"Cannot use package as it will produce"
 
692
                                          " a name conflict");
 
693
                }
 
694
        p->p.p_uselist = make_cons(x, p->p.p_uselist);
 
695
        x->p.p_usedbylist = make_cons(p, x->p.p_usedbylist);
 
696
}
 
697
 
 
698
static void
 
699
unuse_package(x0, p)
 
700
object x0, p;
 
701
{
 
702
        object x = x0;
 
703
 
 
704
        if (type_of(x) != t_package) {
 
705
                x = find_package(x);
 
706
                if (x == Cnil)
 
707
                        no_package(x0);
 
708
        }
 
709
        delete_eq(x, &p->p.p_uselist);
 
710
        delete_eq(p, &x->p.p_usedbylist);
 
711
}
 
712
 
 
713
 
 
714
 
 
715
static object
 
716
delete_package(object n) {
 
717
 
 
718
  struct package *p,*pp;
 
719
  object t;
 
720
 
 
721
  for (p = pack_pointer,pp=NULL;  p != NULL;  pp=p,p = p->p_link) 
 
722
    
 
723
    if (designate_package(n,p)) {
 
724
      
 
725
      if (p->p_usedbylist!=Cnil) {
 
726
        
 
727
        FEpackage_error((object)p,"Package used by other packages.");
 
728
        for (t=p->p_usedbylist;!endp(t);t=t->c.c_cdr)
 
729
          unuse_package((object)p,t->c.c_car);
 
730
      }
 
731
 
 
732
      if (p->p_uselist!=Cnil) {
 
733
        for (t=p->p_uselist;!endp(t);t=t->c.c_cdr)
 
734
          unuse_package(t->c.c_car,(object)p);
 
735
      }
 
736
 
 
737
      p->p_name=Cnil;
 
738
 
 
739
      if (pp) 
 
740
        pp->p_link=p->p_link;
 
741
      else
 
742
        pack_pointer=p->p_link;
 
743
        
 
744
      return(Ct);
 
745
      
 
746
    }
 
747
  
 
748
    if (type_of(n)!=t_package)  
 
749
       FEpackage_error(n,"No such pachage.");
 
750
 
 
751
  return(Cnil);
 
752
  
 
753
}
 
754
  
 
755
/*                         (use `make_cons(lisp_package, Cnil)`) */
 
756
 
 
757
 
 
758
@(defun make_package (pack_name
 
759
                      &key nicknames
 
760
                           (use Cnil)
 
761
                      (internal `small_fixnum(0)`)
 
762
                      (external `small_fixnum(0)`)
 
763
                      )
 
764
@
 
765
        if (type_of(pack_name)==t_character) pack_name=coerce_to_string(pack_name);
 
766
        check_type_or_string_symbol(&pack_name);
 
767
        @(return `make_package(pack_name, nicknames, use,
 
768
                               fix(internal),fix(external))`)
 
769
@)
 
770
 
 
771
@(defun in_package (pack_name &key nicknames (use Cnil use_sp)
 
772
                      (internal `small_fixnum(0)`)
 
773
                      (external `small_fixnum(0)`)
 
774
                    )
 
775
@
 
776
        if (type_of(pack_name)==t_character) pack_name=coerce_to_string(pack_name);
 
777
        check_type_or_string_symbol(&pack_name);
 
778
        if (find_package(pack_name) == Cnil && !(use_sp))
 
779
                use = make_cons(lisp_package, Cnil);
 
780
        @(return `in_package(pack_name, nicknames, use,fix(internal),fix(external))`)
 
781
@)
 
782
 
 
783
LFD(Lfind_package)()
 
784
{
 
785
        check_arg(1);
 
786
 
 
787
        vs_base[0] = find_package(vs_base[0]);
 
788
}
 
789
 
 
790
LFD(Ldelete_package)()
 
791
{
 
792
        check_arg(1);
 
793
 
 
794
        vs_base[0] = delete_package(vs_base[0]);
 
795
}
 
796
 
 
797
LFD(Lpackage_name)()
 
798
{
 
799
  object t;
 
800
 
 
801
  check_arg(1);
 
802
 
 
803
  check_package_designator(vs_base[0]);
 
804
  t=coerce_to_package(vs_base[0]);
 
805
  vs_base[0]=t==Cnil ? t : t->p.p_name;
 
806
 
 
807
}
 
808
 
 
809
LFD(Lpackage_nicknames)()
 
810
{
 
811
        check_arg(1);
 
812
 
 
813
        check_package_designator(vs_base[0]);
 
814
        vs_base[0] = coerce_to_package(vs_base[0]);
 
815
        vs_base[0] = vs_base[0]->p.p_nicknames;
 
816
}
 
817
 
 
818
@(defun rename_package (pack new_name &o new_nicknames)
 
819
@
 
820
        check_package_designator(pack);
 
821
        pack = coerce_to_package(pack);
 
822
        if (type_of(new_name)==t_character) new_name=coerce_to_string(new_name);
 
823
        check_type_or_string_symbol(&new_name);
 
824
        @(return `rename_package(pack, new_name, new_nicknames)`)
 
825
@)
 
826
 
 
827
LFD(Lpackage_use_list)()
 
828
{
 
829
        check_arg(1);
 
830
 
 
831
        check_package_designator(vs_base[0]);
 
832
        vs_base[0] = coerce_to_package(vs_base[0]);
 
833
        vs_base[0] = vs_base[0]->p.p_uselist;
 
834
}
 
835
 
 
836
LFD(Lpackage_used_by_list)()
 
837
{
 
838
        check_arg(1);
 
839
 
 
840
        check_package_designator(vs_base[0]);
 
841
        vs_base[0] = coerce_to_package(vs_base[0]);
 
842
        vs_base[0] = vs_base[0]->p.p_usedbylist;
 
843
}
 
844
 
 
845
static void
 
846
FFN(Lpackage_shadowing_symbols)()
 
847
{
 
848
        check_arg(1);
 
849
 
 
850
        check_package_designator(vs_base[0]);
 
851
        vs_base[0] = coerce_to_package(vs_base[0]);
 
852
        vs_base[0] = vs_base[0]->p.p_shadowings;
 
853
}
 
854
 
 
855
LFD(Llist_all_packages)()
 
856
{
 
857
        struct package *p;
 
858
        int i;
 
859
 
 
860
        check_arg(0);
 
861
        for (p = pack_pointer, i = 0;  p != NULL;  p = p->p_link, i++)
 
862
                vs_push((object)p);
 
863
        vs_push(Cnil);
 
864
        while (i-- > 0)
 
865
                stack_cons();
 
866
}
 
867
 
 
868
@(defun intern (strng &optional (p `current_package()`) &aux sym)
 
869
@
 
870
        check_type_string(&strng);
 
871
        check_package_designator(p);
 
872
        p = coerce_to_package(p);
 
873
        sym = intern(strng, p);
 
874
        if (intern_flag == INTERNAL)
 
875
                @(return sym sKinternal)
 
876
        if (intern_flag == EXTERNAL)
 
877
                @(return sym sKexternal)
 
878
        if (intern_flag == INHERITED)
 
879
                @(return sym sKinherited)
 
880
        @(return sym Cnil)
 
881
@)
 
882
 
 
883
@(defun find_symbol (strng &optional (p `current_package()`))
 
884
        object x;
 
885
@
 
886
        check_type_string(&strng);
 
887
        check_package_designator(p);
 
888
        p = coerce_to_package(p);
 
889
        x = find_symbol(strng, p);
 
890
        if (intern_flag == INTERNAL)
 
891
                @(return x sKinternal)
 
892
        if (intern_flag == EXTERNAL)
 
893
                @(return x sKexternal)
 
894
        if (intern_flag == INHERITED)
 
895
                @(return x sKinherited)
 
896
        @(return Cnil Cnil)
 
897
@)
 
898
 
 
899
@(defun unintern (symbl &optional (p `current_package()`))
 
900
@
 
901
        check_type_symbol(&symbl);
 
902
        check_package_designator(p);
 
903
        p = coerce_to_package(p);
 
904
        if (unintern(symbl, p))
 
905
                @(return Ct)
 
906
        else
 
907
                @(return Cnil)
 
908
@)
 
909
 
 
910
@(defun export (symbols &o (pack `current_package()`))
 
911
        object l;
 
912
 
 
913
@
 
914
        check_package_designator(pack);
 
915
        pack = coerce_to_package(pack);
 
916
BEGIN:
 
917
        switch (type_of(symbols)) {
 
918
        case t_symbol:
 
919
                if (symbols == Cnil)
 
920
                        break;
 
921
                export(symbols, pack);
 
922
                break;
 
923
 
 
924
        case t_cons:
 
925
                for (l = symbols;  !endp(l);  l = l->c.c_cdr)
 
926
                        export(l->c.c_car, pack);
 
927
                break;
 
928
 
 
929
        default:
 
930
                check_type_symbol(&symbols);
 
931
                goto BEGIN;
 
932
        }
 
933
        @(return Ct)
 
934
@)
 
935
 
 
936
@(defun unexport (symbols &o (pack `current_package()`))
 
937
        object l;
 
938
 
 
939
@
 
940
        check_package_designator(pack);
 
941
        pack = coerce_to_package(pack);
 
942
BEGIN:
 
943
        switch (type_of(symbols)) {
 
944
        case t_symbol:
 
945
                if (symbols == Cnil)
 
946
                        break;
 
947
                unexport(symbols, pack);
 
948
                break;
 
949
 
 
950
        case t_cons:
 
951
                for (l = symbols;  !endp(l);  l = l->c.c_cdr)
 
952
                        unexport(l->c.c_car, pack);
 
953
                break;
 
954
 
 
955
        default:
 
956
                check_type_symbol(&symbols);
 
957
                goto BEGIN;
 
958
        }
 
959
        @(return Ct)
 
960
@)
 
961
 
 
962
@(defun import (symbols &o (pack `current_package()`))
 
963
        object l;
 
964
@
 
965
        check_package_designator(pack);
 
966
        pack = coerce_to_package(pack);
 
967
BEGIN:
 
968
        switch (type_of(symbols)) {
 
969
        case t_symbol:
 
970
                if (symbols == Cnil)
 
971
                        break;
 
972
                import(symbols, pack);
 
973
                break;
 
974
 
 
975
        case t_cons:
 
976
                for (l = symbols;  !endp(l);  l = l->c.c_cdr)
 
977
                        import(l->c.c_car, pack);
 
978
                break;
 
979
 
 
980
        default:
 
981
                check_type_symbol(&symbols);
 
982
                goto BEGIN;
 
983
        }
 
984
        @(return Ct)
 
985
@)
 
986
 
 
987
@(defun shadowing_import (symbols &o (pack `current_package()`))
 
988
        object l;
 
989
@
 
990
        check_package_designator(pack);
 
991
        pack = coerce_to_package(pack);
 
992
BEGIN:
 
993
        switch (type_of(symbols)) {
 
994
        case t_symbol:
 
995
                if (symbols == Cnil)
 
996
                        break;
 
997
                shadowing_import(symbols, pack);
 
998
                break;
 
999
 
 
1000
        case t_cons:
 
1001
                for (l = symbols;  !endp(l);  l = l->c.c_cdr)
 
1002
                        shadowing_import(l->c.c_car, pack);
 
1003
                break;
 
1004
 
 
1005
        default:
 
1006
                check_type_symbol(&symbols);
 
1007
                goto BEGIN;
 
1008
        }
 
1009
        @(return Ct)
 
1010
@)
 
1011
 
 
1012
@(defun shadow (symbols &o (pack `current_package()`))
 
1013
        object l;
 
1014
@
 
1015
        check_package_designator(pack);
 
1016
        pack = coerce_to_package(pack);
 
1017
BEGIN:
 
1018
        switch (type_of(symbols)) {
 
1019
        case t_symbol: 
 
1020
        case t_string: 
 
1021
        case t_character:
 
1022
                if (symbols == Cnil)
 
1023
                        break;
 
1024
                shadow(symbols, pack);
 
1025
                break;
 
1026
 
 
1027
        case t_cons:
 
1028
                for (l = symbols;  !endp(l);  l = l->c.c_cdr)
 
1029
                        shadow(l->c.c_car, pack);
 
1030
                break;
 
1031
 
 
1032
        default:
 
1033
                check_type_or_symbol_string(&symbols);
 
1034
                goto BEGIN;
 
1035
        }
 
1036
        @(return Ct)
 
1037
@)
 
1038
 
 
1039
@(defun use_package (pack &o (pa `current_package()`))
 
1040
        object l;
 
1041
@
 
1042
        check_package_designator(pa);
 
1043
        pa = coerce_to_package(pa);
 
1044
BEGIN:
 
1045
        switch (type_of(pack)) {
 
1046
        case t_symbol:
 
1047
                if (pack == Cnil)
 
1048
                        break;
 
1049
 
 
1050
        case t_string:
 
1051
        case t_package:
 
1052
        case t_character:
 
1053
                use_package(pack, pa);
 
1054
                break;
 
1055
 
 
1056
        case t_cons:
 
1057
                for (l = pack;  !endp(l);  l = l->c.c_cdr)
 
1058
                        use_package(l->c.c_car, pa);
 
1059
                break;
 
1060
 
 
1061
        default:
 
1062
                check_type_package(&pack);
 
1063
                goto BEGIN;
 
1064
        }
 
1065
        @(return Ct)
 
1066
@)
 
1067
 
 
1068
@(defun unuse_package (pack &o (pa `current_package()`))
 
1069
        object l;
 
1070
@
 
1071
        check_package_designator(pa);
 
1072
        pa = coerce_to_package(pa);
 
1073
BEGIN:
 
1074
        switch (type_of(pack)) {
 
1075
        case t_symbol:
 
1076
                if (pack == Cnil)
 
1077
                        break;
 
1078
 
 
1079
        case t_string:
 
1080
        case t_package:
 
1081
        case t_character:
 
1082
                unuse_package(pack, pa);
 
1083
                break;
 
1084
 
 
1085
        case t_cons:
 
1086
                for (l = pack;  !endp(l);  l = l->c.c_cdr)
 
1087
                        unuse_package(l->c.c_car, pa);
 
1088
                break;
 
1089
 
 
1090
        default:
 
1091
                check_type_package(&pack);
 
1092
                goto BEGIN;
 
1093
        }
 
1094
        @(return Ct)
 
1095
@)
 
1096
 
 
1097
LFD(siLpackage_internal)()
 
1098
{
 
1099
 
 
1100
        int j=0;
 
1101
 
 
1102
        check_arg(2);
 
1103
        check_type_package(&vs_base[0]);
 
1104
        if (type_of(vs_base[1]) != t_fixnum ||
 
1105
            (j = fix(vs_base[1])) < 0 || j >= vs_base[0]->p.p_internal_size)
 
1106
                FEerror("~S is an illegal index to a package hashtable.",
 
1107
                        1, vs_base[1]);
 
1108
        vs_base[0] = P_INTERNAL(vs_base[0],j);
 
1109
        vs_popp;
 
1110
}
 
1111
 
 
1112
LFD(siLpackage_external)()
 
1113
{
 
1114
        int j=0;
 
1115
 
 
1116
        check_arg(2);
 
1117
        check_type_package(&vs_base[0]);
 
1118
        if (type_of(vs_base[1]) != t_fixnum ||
 
1119
            (j = fix(vs_base[1])) < 0 || j >= vs_base[0]->p.p_external_size)
 
1120
                FEerror("~S is an illegal index to a package hashtable.",
 
1121
                        1, vs_base[1]);
 
1122
        vs_base[0] = P_EXTERNAL(vs_base[0],j);
 
1123
        vs_popp;
 
1124
}
 
1125
 
 
1126
static void
 
1127
no_package(n)
 
1128
object n;
 
1129
{
 
1130
        FEwrong_type_argument(TSor_symbol_string_package,n);
 
1131
}
 
1132
 
 
1133
static void
 
1134
package_already(n)
 
1135
object n;
 
1136
{
 
1137
  FEpackage_error(n,"A package with this name already exists.");
 
1138
}
 
1139
 
 
1140
static void
 
1141
FFN(siLpackage_size)()
 
1142
{object p;
 
1143
 p=vs_base[0];
 
1144
 check_type_package(&p);
 
1145
 check_arg(1);
 
1146
 vs_base[0]=make_fixnum(p->p.p_external_size);
 
1147
 vs_base[1]=make_fixnum(p->p.p_internal_size);
 
1148
 vs_top=vs_base+2;
 
1149
 return;
 
1150
}
 
1151
 
 
1152
DEF_ORDINARY("EXTERNAL",sKexternal,KEYWORD,"");
 
1153
DEF_ORDINARY("INHERITED",sKinherited,KEYWORD,"");
 
1154
DEF_ORDINARY("INTERNAL",sKinternal,KEYWORD,"");
 
1155
DEF_ORDINARY("NICKNAMES",sKnicknames,KEYWORD,"");
 
1156
DEF_ORDINARY("USE",sKuse,KEYWORD,"");
 
1157
DEFVAR("*PACKAGE*",sLApackageA,LISP,lisp_package,"");
 
1158
 
 
1159
 
 
1160
void
 
1161
gcl_init_package()
 
1162
{
 
1163
 
 
1164
        lisp_package
 
1165
        = make_package(make_simple_string("LISP"),
 
1166
                       Cnil, Cnil,47,509);
 
1167
        user_package
 
1168
        = make_package(make_simple_string("USER"),
 
1169
                       Cnil,
 
1170
                       make_cons(lisp_package, Cnil),509,97);
 
1171
#ifdef ANSI_COMMON_LISP
 
1172
        common_lisp_package
 
1173
        = make_package(make_simple_string("COMMON-LISP"),
 
1174
                       Cnil, Cnil,47,509);
 
1175
#endif
 
1176
        keyword_package
 
1177
        = make_package(make_simple_string("KEYWORD"),
 
1178
                       Cnil, Cnil,11,509);
 
1179
        system_package
 
1180
        = make_package(make_simple_string("SYSTEM"),
 
1181
                       make_cons(make_simple_string("SI"),
 
1182
                                 make_cons(make_simple_string("SYS"),
 
1183
                                           Cnil)),
 
1184
                       make_cons(lisp_package, Cnil),251,157);
 
1185
 
 
1186
        /*  There is no need to enter a package as a mark origin.  */
 
1187
 
 
1188
        uninterned_list = Cnil;
 
1189
        enter_mark_origin(&uninterned_list);
 
1190
}
 
1191
 
 
1192
void
 
1193
gcl_init_package_function()
 
1194
{
 
1195
        make_function("MAKE-PACKAGE", Lmake_package);
 
1196
        make_function("DELETE-PACKAGE", Ldelete_package);
 
1197
        make_function("IN-PACKAGE", Lin_package);
 
1198
        make_function("FIND-PACKAGE", Lfind_package);
 
1199
        make_function("PACKAGE-NAME", Lpackage_name);
 
1200
        make_function("PACKAGE-NICKNAMES", Lpackage_nicknames);
 
1201
        make_function("RENAME-PACKAGE", Lrename_package);
 
1202
        make_function("PACKAGE-USE-LIST", Lpackage_use_list);
 
1203
        make_function("PACKAGE-USED-BY-LIST", Lpackage_used_by_list);
 
1204
        make_function("PACKAGE-SHADOWING-SYMBOLS",Lpackage_shadowing_symbols);
 
1205
        make_function("LIST-ALL-PACKAGES", Llist_all_packages);
 
1206
        make_function("INTERN", Lintern);
 
1207
        make_function("FIND-SYMBOL", Lfind_symbol);
 
1208
        make_function("UNINTERN", Lunintern);
 
1209
        make_function("EXPORT", Lexport);
 
1210
        make_function("UNEXPORT", Lunexport);
 
1211
        make_function("IMPORT", Limport);
 
1212
        make_function("SHADOWING-IMPORT", Lshadowing_import);
 
1213
        make_function("SHADOW", Lshadow);
 
1214
        make_function("USE-PACKAGE", Luse_package);
 
1215
        make_function("UNUSE-PACKAGE", Lunuse_package);
 
1216
 
 
1217
        make_si_function("PACKAGE-SIZE",siLpackage_size);
 
1218
        make_si_function("PACKAGE-INTERNAL", siLpackage_internal);
 
1219
        make_si_function("PACKAGE-EXTERNAL", siLpackage_external);
 
1220
}