← Back to branch summary

~ubuntu-branches/ubuntu/vivid/gcl/vivid

« back to all changes in this revision

Viewing changes to o/alloc.c

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2002-03-04 14:29:59 UTC
  • Revision ID: james.westby@ubuntu.com-20020304142959-dey14w08kr7lldu3
Tags: upstream-2.5.0.cvs20020219
Import upstream version 2.5.0.cvs20020219

Show diffs side-by-side

added added

removed removed

Lines of Context:
o/alloc.c
 
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
/*
 
23
        alloc.c
 
24
        IMPLEMENTATION-DEPENDENT
 
25
*/
 
26
 
 
27
#include "include.h"
 
28
#include "page.h"
 
29
 
 
30
DEFVAR("*AFTER-GBC-HOOK*",sSAafter_gbc_hookA,SI,sLnil,"");
 
31
DEFVAR("*IGNORE-MAXIMUM-PAGES*",sSAignore_maximum_pagesA,SI,sLt,"");
 
32
#define IGNORE_MAX_PAGES (sSAignore_maximum_pagesA ==0 || sSAignore_maximum_pagesA->s.s_dbind !=sLnil) 
 
33
 
 
34
void call_after_gbc_hook();
 
35
 
 
36
#ifdef DEBUG_SBRK
 
37
int debug;
 
38
char *
 
39
sbrk1(n)
 
40
     int n;
 
41
{char *ans;
 
42
 if (debug){
 
43
   printf("\n{sbrk(%d)",n);
 
44
   fflush(stdout);}
 
45
 ans= (char *)sbrk(n);
 
46
 if (debug){
 
47
   printf("->[0x%x]", ans);
 
48
   fflush(stdout);
 
49
   printf("core_end=0x%x,sbrk(0)=0x%x}",core_end,sbrk(0));
 
50
   fflush(stdout);}
 
51
 return ans;
 
52
}
 
53
#define sbrk sbrk1
 
54
#endif /* DEBUG_SBRK */
 
55
 
 
56
int real_maxpage = MAXPAGE;
 
57
int new_holepage;
 
58
 
 
59
#define available_pages \
 
60
        (real_maxpage-page(heap_end)-new_holepage-2*nrbpage-real_maxpage/32)
 
61
 
 
62
 
 
63
#ifdef UNIX
 
64
extern char *sbrk();
 
65
#endif
 
66
 
 
67
#ifdef BSD
 
68
#include <sys/time.h>
 
69
#include <sys/resource.h>
 
70
#ifdef RLIMIT_STACK
 
71
struct rlimit data_rlimit;
 
72
#endif
 
73
/* extern char etext; */
 
74
#endif
 
75
 
 
76
int reserve_pages_for_signal_handler =30;
 
77
 
 
78
/* If  (n >= 0 ) return pointer to n pages starting at heap end,
 
79
   These must come from the hole, so if that is exhausted you have
 
80
   to gc and move the hole.
 
81
   if  (n < 0) return pointer to n pages starting at heap end,
 
82
   but don't worry about the hole.   Basically just make sure
 
83
   the space is available from the Operating system.
 
84
   If not in_signal_handler then try to keep a minimum of
 
85
   reserve_pages_for_signal_handler pages on hand in the hole
 
86
 */
 
87
char *
 
88
alloc_page(n)
 
89
int n;
 
90
{
 
91
        char *e;
 
92
        int m;
 
93
        e = heap_end;
 
94
        if (n >= 0) {
 
95
                if (n >=
 
96
                    (holepage - (in_signal_handler? 0 :
 
97
                                 reserve_pages_for_signal_handler
 
98
                                )))
 
99
                    {
 
100
                        holepage = new_holepage + n;
 
101
 
 
102
                        {int in_sgc=sgc_enabled;
 
103
                         if (in_sgc) sgc_quit();
 
104
                        if(in_signal_handler)
 
105
                          {fprintf(stderr,
 
106
                                   "Cant do relocatable gc in signal handler. \
 
107
Try to allocate more space to save for allocation during signals: \
 
108
eg to add 20 more do (si::set-hole-size %d %d)\n...start over ", new_holepage, 20+ reserve_pages_for_signal_handler); fflush(stderr); exit(1);}
 
109
 
 
110
                        GBC(t_relocatable);
 
111
                        if (in_sgc)
 
112
                          {sgc_start();
 
113
                           /* starting sgc can use up some pages
 
114
                              and may move heap end, so start over
 
115
                            */
 
116
                           return alloc_page(n);}
 
117
                       }
 
118
                }
 
119
                holepage -= n;
 
120
                if (heap_end == core_end)
 
121
                  /* can happen when mallocs occur before rel block set up..*/
 
122
                  { sbrk(PAGESIZE*n) ;
 
123
                    core_end += PAGESIZE*n;
 
124
                  }
 
125
                heap_end += PAGESIZE*n;
 
126
                return(e);
 
127
        }
 
128
     else
 
129
       /* n < 0 , then this says ensure there are -n pages
 
130
          starting at heap_end, and return pointer to heap_end */
 
131
      {
 
132
        n = -n;
 
133
        m = (core_end - heap_end)/PAGESIZE;
 
134
        if (n <= m)
 
135
                return(e);
 
136
 
 
137
        IF_ALLOCATE_ERR error("Can't allocate.  Good-bye!");
 
138
#ifdef SGC
 
139
        if (sgc_enabled)
 
140
          make_writable(page(core_end),page(core_end)+n-m);
 
141
 
 
142
#endif  
 
143
        core_end += PAGESIZE*(n - m);
 
144
        return(e);}
 
145
}
 
146
 
 
147
void
 
148
add_page_to_freelist(p,tm)
 
149
     char *p;
 
150
     struct typemanager *tm;
 
151
{short t,size;
 
152
 int i=tm->tm_nppage,fw;
 
153
 int nn;
 
154
 object x,f;
 
155
 t=tm->tm_type;
 
156
#ifdef SGC
 
157
 nn=page(p);
 
158
 if (sgc_enabled)
 
159
   { if (!WRITABLE_PAGE_P(nn)) make_writable(nn,nn+1);}
 
160
#endif
 
161
 type_map[page(p)]= t;
 
162
 size=tm->tm_size;
 
163
 f=tm->tm_free;
 
164
 x= (object)p;
 
165
 x->d.t=t;
 
166
 x->d.m=FREE;
 
167
#ifdef SGC
 
168
 if (sgc_enabled && tm->tm_sgc)
 
169
   {x->d.s=SGC_RECENT;
 
170
    sgc_type_map[page(x)] = (SGC_PAGE_FLAG | SGC_TEMP_WRITABLE);}
 
171
 else x->d.s = SGC_NORMAL;
 
172
 
 
173
 /* array headers must be always writable, since a write to the
 
174
    body does not touch the header.   It may be desirable if there
 
175
    are many arrays in a system to make the headers not writable,
 
176
    but just SGC_TOUCH the header each time you write to it.   this
 
177
    is what is done with t_structure */
 
178
  if (t== (tm_of(t_array)->tm_type))
 
179
   sgc_type_map[page(x)] |= SGC_PERM_WRITABLE;
 
180
   
 
181
#endif 
 
182
 fw= *(int *)x;
 
183
 while (--i >= 0)
 
184
   { *(int *)x=fw;
 
185
     SET_LINK(x,f);
 
186
     f=x;
 
187
     x= (object) ((char *)x + size);
 
188
   }
 
189
 tm->tm_free=f;
 
190
 tm->tm_nfree += tm->tm_nppage;
 
191
 tm->tm_npage++;
 
192
}
 
193
 
 
194
object
 
195
type_name(t)
 
196
     int t;
 
197
{ return make_simple_string(tm_table[(int)t].tm_name+1);}
 
198
 
 
199
 
 
200
void
 
201
call_after_gbc_hook(t)
 
202
{ if (sSAafter_gbc_hookA && sSAafter_gbc_hookA->s.s_dbind!= Cnil)
 
203
    { set_up_string_register(tm_table[(int)t].tm_name+1);
 
204
      ifuncall1(sSAafter_gbc_hookA->s.s_dbind,intern(string_register,system_package));
 
205
    }
 
206
}
 
207
 
 
208
#define PERCENT_FREE(tm)  ((tm->tm_percent_free ? tm->tm_percent_free : 10)/100.0)
 
209
 
 
210
 
 
211
object
 
212
alloc_object(t)
 
213
enum type t;
 
214
{
 
215
         object obj;
 
216
         struct typemanager *tm;
 
217
         int i;
 
218
         char *p;
 
219
         object x, f;
 
220
 
 
221
ONCE_MORE:
 
222
        tm = tm_of(t);
 
223
 
 
224
        CHECK_INTERRUPT;         
 
225
 
 
226
        obj = tm->tm_free;
 
227
        if (obj == OBJNULL) {
 
228
                if (tm->tm_npage >= tm->tm_maxpage)
 
229
                        goto CALL_GBC;
 
230
                if (available_pages < 1) {
 
231
                  if (sSAignore_maximum_pagesA) {
 
232
                        sSAignore_maximum_pagesA->s.s_dbind = Cnil;
 
233
                        goto CALL_GBC;
 
234
                      }
 
235
                }
 
236
                p = alloc_page(1);
 
237
                add_page_to_freelist(p,tm);
 
238
                obj = tm->tm_free;
 
239
                if (tm->tm_npage >= tm->tm_maxpage)
 
240
                        goto CALL_GBC;
 
241
        }
 
242
        tm->tm_free = OBJ_LINK(obj);
 
243
        --(tm->tm_nfree);
 
244
        (tm->tm_nused)++;
 
245
        obj->d.t = (short)t;
 
246
        obj->d.m = FALSE;
 
247
        return(obj);
 
248
#define TOTAL_THIS_TYPE(tm) \
 
249
        (tm->tm_nppage * (sgc_enabled ? sgc_count_type(tm->tm_type) : tm->tm_npage))
 
250
CALL_GBC:
 
251
        GBC(tm->tm_type);
 
252
        if (tm->tm_nfree == 0 ||
 
253
            ((float)tm->tm_nfree)  <   (PERCENT_FREE(tm) * TOTAL_THIS_TYPE(tm)))
 
254
                goto EXHAUSTED;
 
255
        call_after_gbc_hook(t);
 
256
        goto ONCE_MORE;
 
257
 
 
258
EXHAUSTED:
 
259
        if (IGNORE_MAX_PAGES) {
 
260
                if (tm->tm_maxpage/2 <= 0)
 
261
                        tm->tm_maxpage += 1;
 
262
                else
 
263
                        tm->tm_maxpage += tm->tm_maxpage/2;
 
264
                call_after_gbc_hook(t);
 
265
                goto ONCE_MORE;
 
266
        }
 
267
        GBC_enable = FALSE;
 
268
        vs_push(type_name(t));
 
269
        vs_push(make_fixnum(tm->tm_npage));
 
270
        GBC_enable = TRUE;
 
271
        CEerror("The storage for ~A is exhausted.~%\
 
272
Currently, ~D pages are allocated.~%\
 
273
Use ALLOCATE to expand the space.",
 
274
                "Continues execution.",
 
275
                2, vs_top[-2], vs_top[-1]);
 
276
        vs_pop;
 
277
        vs_pop;
 
278
        call_after_gbc_hook(t);
 
279
        goto ONCE_MORE;
 
280
}
 
281
 
 
282
grow_linear(old,fract,grow_min,grow_max)
 
283
     int old,grow_min,grow_max,fract;
 
284
{int delt;
 
285
 if(fract==0) fract=50;
 
286
 if(grow_min==0) grow_min=1;
 
287
 if(grow_max==0) grow_max=1000;
 
288
 delt=(old*fract)/100;
 
289
 delt= (delt < grow_min ? grow_min:
 
290
        delt > grow_max ? grow_max:
 
291
        delt);
 
292
 return old + delt;}
 
293
 
 
294
object
 
295
make_cons(a, d)
 
296
object a, d;
 
297
{
 
298
         object obj;
 
299
         int i;
 
300
         char *p;
 
301
         object x, f;
 
302
        struct typemanager *tm=(&tm_table[(int)t_cons]);
 
303
/* #define      tm      (&tm_table[(int)t_cons])*/
 
304
 
 
305
ONCE_MORE:
 
306
        CHECK_INTERRUPT;
 
307
        obj = tm->tm_free;
 
308
        if (obj == OBJNULL) {
 
309
                if (tm->tm_npage >= tm->tm_maxpage)
 
310
                        goto CALL_GBC;
 
311
                if (available_pages < 1) {
 
312
                   if(sSAignore_maximum_pagesA) {
 
313
                        sSAignore_maximum_pagesA->s.s_dbind = Cnil;
 
314
                        goto CALL_GBC;
 
315
                      }
 
316
                }
 
317
                p = alloc_page(1);
 
318
                add_page_to_freelist(p,tm);
 
319
                obj = tm->tm_free ;
 
320
                if (tm->tm_npage >= tm->tm_maxpage)
 
321
                        goto CALL_GBC;
 
322
        }
 
323
        tm->tm_free = OBJ_LINK(obj);
 
324
        --(tm->tm_nfree);
 
325
        (tm->tm_nused)++;
 
326
        obj->c.t = (short)t_cons;
 
327
        obj->c.m = FALSE;
 
328
        obj->c.c_car = a;
 
329
        obj->c.c_cdr = d;
 
330
        return(obj);
 
331
 
 
332
CALL_GBC:
 
333
        GBC(t_cons);
 
334
        if (tm->tm_nfree == 0 ||
 
335
            (float)tm->tm_nfree   <  PERCENT_FREE(tm) * TOTAL_THIS_TYPE(tm))
 
336
                goto EXHAUSTED;
 
337
        call_after_gbc_hook(t_cons);
 
338
        goto ONCE_MORE;
 
339
 
 
340
EXHAUSTED:
 
341
        if (IGNORE_MAX_PAGES) {
 
342
          tm->tm_maxpage =
 
343
            grow_linear(tm->tm_maxpage,tm->tm_growth_percent,
 
344
                        tm->tm_min_grow,tm->tm_max_grow);
 
345
          call_after_gbc_hook(t_cons);
 
346
          goto ONCE_MORE;
 
347
        }
 
348
        GBC_enable = FALSE;
 
349
        vs_push(make_fixnum(tm->tm_npage));
 
350
        GBC_enable = TRUE;
 
351
        CEerror("The storage for CONS is exhausted.~%\
 
352
Currently, ~D pages are allocated.~%\
 
353
Use ALLOCATE to expand the space.",
 
354
                "Continues execution.",
 
355
                1, vs_top[-1]);
 
356
        vs_pop;
 
357
        call_after_gbc_hook(t_cons);
 
358
        goto ONCE_MORE;
 
359
#undef  tm
 
360
}
 
361
 
 
362
 
 
363
object on_stack_cons(x,y)
 
364
     object x,y;
 
365
{object p = (object) alloca_val;
 
366
 p->c.t= (short)t_cons;
 
367
 p->c.m=FALSE;
 
368
 p->c.c_car=x;
 
369
 p->c.c_cdr=y;
 
370
 return p;
 
371
}
 
372
 
 
373
 
 
374
DEFUN("ALLOCATED",object,fSallocated,SI
 
375
   ,2,2,NONE,OO,OO,OO,OO,"")(typ)
 
376
object typ;
 
377
{ struct typemanager *tm=(&tm_table[t_from_type(typ)]);
 
378
  tm = & tm_table[tm->tm_type];
 
379
  if (tm->tm_type == t_relocatable)
 
380
    { tm->tm_npage = (rb_end-rb_start)/PAGESIZE;
 
381
      tm->tm_nfree = rb_end -rb_pointer;
 
382
    }
 
383
  else if (tm->tm_type == t_contiguous)
 
384
    { int cbfree =0;
 
385
      struct contblock **cbpp;
 
386
      for(cbpp= &cb_pointer; (*cbpp)!=NULL; cbpp= &(*cbpp)->cb_link)
 
387
          cbfree += (*cbpp)->cb_size ;
 
388
      tm->tm_nfree = cbfree;
 
389
    }
 
390
  
 
391
  RETURN(6,object,make_fixnum(tm->tm_nfree),
 
392
            (RV(make_fixnum(tm->tm_npage)),
 
393
             RV(make_fixnum(tm->tm_maxpage)),
 
394
             RV(make_fixnum(tm->tm_nppage)),
 
395
             RV(make_fixnum(tm->tm_gbccount)),
 
396
             RV(make_fixnum(tm->tm_nused))
 
397
             ));
 
398
}
 
399
 
 
400
DEFUN("RESET-NUMBER-USED",object,fSreset_number_used,SI,0,1,NONE,OO,OO,OO,OO,"")(typ)
 
401
     object typ;
 
402
{int i;
 
403
 if (VFUN_NARGS == 1)
 
404
   { tm_table[t_from_type(typ)].tm_nused = 0;}
 
405
 else
 
406
 for (i=0; i <= t_relocatable ; i++)
 
407
   { tm_table[i].tm_nused = 0;}
 
408
  RETURN1(sLnil);
 
409
}
 
410
 
 
411
 
 
412
char *
 
413
alloc_contblock(n)
 
414
int n;
 
415
{
 
416
         char *p;
 
417
         struct contblock **cbpp;
 
418
         int i;
 
419
         int m;
 
420
         bool g;
 
421
 
 
422
 
 
423
/*
 
424
        printf("allocating %d-byte contiguous block...\n", n);
 
425
*/
 
426
 
 
427
        g = FALSE;
 
428
        n = ROUND_UP_PTR(n);
 
429
 
 
430
ONCE_MORE:
 
431
         CHECK_INTERRUPT;
 
432
        for(cbpp= &cb_pointer; (*cbpp)!=NULL; cbpp= &(*cbpp)->cb_link)
 
433
                if ((*cbpp)->cb_size >= n) {
 
434
                        p = (char *)(*cbpp);
 
435
                        i = (*cbpp)->cb_size - n;
 
436
                        *cbpp = (*cbpp)->cb_link;
 
437
                        --ncb;
 
438
                        insert_contblock(p+n, i);
 
439
                        return(p);
 
440
                }
 
441
        m = (n + PAGESIZE - 1)/PAGESIZE;
 
442
       if(sSAignore_maximum_pagesA) {
 
443
        if (ncbpage + m > maxcbpage || available_pages < m) {
 
444
                if (available_pages < m)
 
445
                        sSAignore_maximum_pagesA->s.s_dbind = Cnil;
 
446
                if (!g) {
 
447
                        GBC(t_contiguous);
 
448
                        g = TRUE;
 
449
                        call_after_gbc_hook(t_contiguous);
 
450
                        goto ONCE_MORE;
 
451
                }
 
452
                if (IGNORE_MAX_PAGES)
 
453
                  {struct typemanager *tm = &tm_table[(int)t_contiguous];
 
454
                   maxcbpage=grow_linear(maxcbpage,tm->tm_growth_percent,
 
455
                              tm->tm_min_grow, tm->tm_max_grow);
 
456
                        g = FALSE;
 
457
                        call_after_gbc_hook(t_contiguous);
 
458
                        goto ONCE_MORE;
 
459
                }
 
460
                vs_push(make_fixnum(ncbpage));
 
461
                CEerror("Contiguous blocks exhausted.~%\
 
462
Currently, ~D pages are allocated.~%\
 
463
Use ALLOCATE-CONTIGUOUS-PAGES to expand the space.",
 
464
                        "Continues execution.", 1, vs_head);
 
465
                vs_pop;
 
466
                g = FALSE;
 
467
                call_after_gbc_hook(t_contiguous);
 
468
                goto ONCE_MORE;
 
469
        }
 
470
      }
 
471
        p = alloc_page(m);
 
472
 
 
473
        for (i = 0;  i < m;  i++)
 
474
                type_map[page(p) + i] = (char)t_contiguous;
 
475
        ncbpage += m;
 
476
        insert_contblock(p+n, PAGESIZE*m - n);
 
477
        return(p);
 
478
}
 
479
 
 
480
 
 
481
insert_contblock(p, s)
 
482
char *p;
 
483
int s;
 
484
{
 
485
        struct contblock **cbpp, *cbp;
 
486
 
 
487
        if (s < CBMINSIZE)
 
488
                return;
 
489
        ncb++;
 
490
        cbp = (struct contblock *)p;
 
491
        cbp->cb_size = s;
 
492
        for (cbpp = &cb_pointer;  *cbpp;  cbpp = &((*cbpp)->cb_link))
 
493
                if ((*cbpp)->cb_size >= s) {
 
494
                        cbp->cb_link = *cbpp;
 
495
                        *cbpp = cbp;
 
496
                        return;
 
497
                }
 
498
        cbp->cb_link = NULL;
 
499
        *cbpp = cbp;
 
500
}
 
501
 
 
502
char *
 
503
alloc_relblock(n)
 
504
int n;
 
505
{
 
506
         char *p;
 
507
         bool g;
 
508
 
 
509
        int i;
 
510
 
 
511
/*
 
512
        printf("allocating %d-byte relocatable block...\n", n);
 
513
*/
 
514
 
 
515
        g = FALSE;
 
516
        n = ROUND_UP_PTR(n);
 
517
 
 
518
ONCE_MORE:
 
519
        CHECK_INTERRUPT;
 
520
 
 
521
        if (rb_limit - rb_pointer < n) {
 
522
                if (!g && in_signal_handler == 0) {
 
523
                        GBC(t_relocatable);
 
524
                        g = TRUE;
 
525
                        { float f1 = (float)(rb_limit - rb_pointer),
 
526
                                f2 = (float)(rb_limit - rb_start);
 
527
 
 
528
                                if ((float)f1 < PERCENT_FREE(tm_of(t_relocatable)) * f2) 
 
529
                                ;
 
530
                        else
 
531
                          {     call_after_gbc_hook(t_relocatable);
 
532
                                goto ONCE_MORE;
 
533
                                              }}
 
534
                }
 
535
                if (IGNORE_MAX_PAGES)
 
536
                  {struct typemanager *tm = &tm_table[(int)t_relocatable];
 
537
                   nrbpage=grow_linear(i=nrbpage,tm->tm_growth_percent,
 
538
                              tm->tm_min_grow, tm->tm_max_grow);
 
539
                   if (available_pages < 0)
 
540
                     nrbpage = i;
 
541
                   else {
 
542
                          rb_end +=  (PAGESIZE* (nrbpage -i));
 
543
                          rb_limit = rb_end - 2*RB_GETA;
 
544
                          if (page(rb_end) - page(heap_end) !=
 
545
                              holepage + nrbpage)
 
546
                            FEerror("bad rb_end",0);
 
547
                          alloc_page(-( nrbpage + holepage));
 
548
                          g = FALSE;
 
549
                          call_after_gbc_hook(t_relocatable);
 
550
                          goto ONCE_MORE;
 
551
                        }
 
552
                }
 
553
                if (rb_limit > rb_end - 2*RB_GETA)
 
554
                        error("relocatable blocks exhausted");
 
555
                rb_limit += RB_GETA;
 
556
                vs_push(make_fixnum(nrbpage));
 
557
                CEerror("Relocatable blocks exhausted.~%\
 
558
Currently, ~D pages are allocated.~%\
 
559
Use ALLOCATE-RELOCATABLE-PAGES to expand the space.",
 
560
                        "Continues execution.", 1, vs_head);
 
561
                vs_pop;
 
562
                g = FALSE;
 
563
                call_after_gbc_hook(t_relocatable);
 
564
                goto ONCE_MORE;
 
565
        }
 
566
        p = rb_pointer;
 
567
        rb_pointer += n;
 
568
        return(p);
 
569
}
 
570
 
 
571
init_tm(t, name, elsize, nelts,sgc)
 
572
enum type t;
 
573
char name[];
 
574
int elsize, nelts;
 
575
{
 
576
        int i, j;
 
577
        int maxpage;
 
578
        /* round up to next number of pages */
 
579
        maxpage = (((nelts * elsize) + PAGESIZE -1)/PAGESIZE);
 
580
        tm_table[(int)t].tm_name = name;
 
581
        for (j = -1, i = 0;  i < (int)t_end;  i++)
 
582
                if (tm_table[i].tm_size != 0 &&
 
583
                    tm_table[i].tm_size >= elsize &&
 
584
                    (j < 0 || tm_table[j].tm_size > tm_table[i].tm_size))
 
585
                        j = i;
 
586
        if (j >= 0) {
 
587
                tm_table[(int)t].tm_type = (enum type)j;
 
588
                tm_table[j].tm_maxpage += maxpage;
 
589
#ifdef SGC              
 
590
                tm_table[j].tm_sgc += sgc;
 
591
#endif
 
592
                return;
 
593
        }
 
594
        tm_table[(int)t].tm_type = t;
 
595
        tm_table[(int)t].tm_size = ROUND_UP_PTR(elsize);
 
596
        tm_table[(int)t].tm_nppage = PAGESIZE/ROUND_UP_PTR(elsize);
 
597
        tm_table[(int)t].tm_free = OBJNULL;
 
598
        tm_table[(int)t].tm_nfree = 0;
 
599
        tm_table[(int)t].tm_nused = 0;
 
600
        /*tm_table[(int)t].tm_npage = 0; */  /* dont zero nrbpage.. */
 
601
        tm_table[(int)t].tm_maxpage = maxpage;
 
602
        tm_table[(int)t].tm_gbccount = 0;
 
603
#ifdef SGC      
 
604
        tm_table[(int)t].tm_sgc = sgc;
 
605
        tm_table[(int)t].tm_sgc_max = 3000;
 
606
        tm_table[(int)t].tm_sgc_minfree = (int)
 
607
          (0.4 * tm_table[(int)t].tm_nppage);
 
608
#endif
 
609
 
 
610
}
 
611
 
 
612
set_maxpage()
 
613
{
 
614
  /* This is run in init.  Various initializations including getting
 
615
     maxpage are here */ 
 
616
#ifdef SGC
 
617
  page_multiple=getpagesize()/PAGESIZE;
 
618
  if (page_multiple==0) error("PAGESIZE must be factor of getpagesize()");
 
619
  if (sgc_enabled)
 
620
    {memory_protect(1);}
 
621
  if (~(-MAXPAGE) != MAXPAGE-1) error("MAXPAGE must be power of 2");
 
622
  if (core_end)
 
623
     bzero(&sgc_type_map[ page(core_end)],MAXPAGE- page(core_end));
 
624
#else
 
625
  page_multiple=1;
 
626
#endif
 
627
  
 
628
SET_REAL_MAXPAGE;
 
629
 
 
630
}
 
631
 
 
632
 
 
633
 
 
634
 
 
635
 
 
636
init_alloc()
 
637
{
 
638
        int i, j;
 
639
        struct typemanager *tm;
 
640
        char *p, *q;
 
641
        enum type t;
 
642
        int c;
 
643
        static initialized;
 
644
 
 
645
        if (initialized) return;
 
646
        initialized=1;
 
647
        
 
648
 
 
649
#ifndef DONT_NEED_MALLOC        
 
650
 
 
651
        {
 
652
                extern object malloc_list;
 
653
                malloc_list = Cnil;
 
654
                enter_mark_origin(&malloc_list);
 
655
        }
 
656
#endif  
 
657
 
 
658
        holepage = INIT_HOLEPAGE;
 
659
        new_holepage = HOLEPAGE;
 
660
        nrbpage = INIT_NRBPAGE;
 
661
 
 
662
        set_maxpage();
 
663
 
 
664
#ifdef __linux__
 
665
        /* Some versions of the Linux startup code are broken.
 
666
           For these, the first call to sbrk() fails, but
 
667
           subsequent calls are o.k.
 
668
           */
 
669
        if ( (int)sbrk(0) == -1 )
 
670
          {
 
671
            if ( (int)sbrk(0) == -1 )
 
672
              {
 
673
                fputs("FATAL Linux sbrk() error\n", stderr);
 
674
                exit(1);
 
675
              }
 
676
            fputs("WARNING: Non-fatal Linux sbrk() error\n", stderr);
 
677
          }
 
678
#endif
 
679
 
 
680
        INIT_ALLOC;
 
681
        
 
682
        alloc_page(-(holepage + nrbpage));
 
683
 
 
684
        rb_start = rb_pointer = heap_end + PAGESIZE*holepage;
 
685
        rb_end = rb_start + PAGESIZE*nrbpage;
 
686
        rb_limit = rb_end - 2*RB_GETA;
 
687
#ifdef SGC      
 
688
        tm_table[(int)t_relocatable].tm_sgc = 50;
 
689
#endif
 
690
        
 
691
        for (i = 0;  i < MAXPAGE;  i++)
 
692
                type_map[i] = (char)t_other;
 
693
 
 
694
        init_tm(t_fixnum, "NFIXNUM",
 
695
                sizeof(struct fixnum_struct), 8192,20);
 
696
        init_tm(t_cons, ".CONS", sizeof(struct cons), 65536 ,50 );
 
697
        init_tm(t_structure, "SSTRUCTURE", sizeof(struct structure), 5461,0 );
 
698
        init_tm(t_cfun, "fCFUN", sizeof(struct cfun), 4096,0  );
 
699
        init_tm(t_sfun, "gSFUN", sizeof(struct sfun),409,0 );
 
700
        init_tm(t_string, "\"STRING", sizeof(struct string), 5461,1  );
 
701
        init_tm(t_array, "aARRAY", sizeof(struct array), 4681,1 );
 
702
        init_tm(t_symbol, "|SYMBOL", sizeof(struct symbol), 3640,1 );
 
703
        init_tm(t_bignum, "BBIGNUM", sizeof(struct bignum), 2730,0 );
 
704
        init_tm(t_ratio, "RRATIONAL", sizeof(struct ratio), 170,0 );
 
705
        init_tm(t_shortfloat, "FSHORT-FLOAT",
 
706
                sizeof(struct shortfloat_struct), 256 ,1);
 
707
        init_tm(t_longfloat, "LLONG-FLOAT",
 
708
                sizeof(struct longfloat_struct), 170 ,0);
 
709
        init_tm(t_complex, "CCOMPLEX", sizeof(struct complex), 170 ,0);
 
710
        init_tm(t_character,"#CHARACTER",sizeof(struct character), 256 ,0);
 
711
        init_tm(t_package, ":PACKAGE", sizeof(struct package), 2*PAGESIZE / sizeof(struct package),0);
 
712
        init_tm(t_hashtable, "hHASH-TABLE", sizeof(struct hashtable), 78,0 );
 
713
        init_tm(t_vector, "vVECTOR", sizeof(struct vector), 146 ,0);
 
714
        init_tm(t_bitvector, "bBIT-VECTOR", sizeof(struct bitvector), 73 ,0);
 
715
        init_tm(t_stream, "sSTREAM", sizeof(struct stream), 78 ,0);
 
716
        init_tm(t_random, "$RANDOM-STATE", sizeof(struct random), 256 ,0);
 
717
        init_tm(t_readtable, "rREADTABLE", sizeof(struct readtable), 256 ,0);
 
718
        init_tm(t_pathname, "pPATHNAME", sizeof(struct pathname), 73 ,0);
 
719
        init_tm(t_cclosure, "cCCLOSURE", sizeof(struct cclosure), 85 ,0);
 
720
        init_tm(t_closure, "cCLOSURE", sizeof(struct cclosure), 85 ,0);
 
721
        init_tm(t_vfun, "VVFUN", sizeof(struct vfun), 102 ,0);
 
722
        init_tm(t_gfun, "gGFUN", sizeof(struct sfun), 0 ,0);
 
723
        init_tm(t_afun, "AAFUN", sizeof(struct sfun), 0 ,0);
 
724
        init_tm(t_cfdata, "cCFDATA", sizeof(struct cfdata), 102 ,0);
 
725
        init_tm(t_spice, "!SPICE", sizeof(struct spice), 4096 ,0);
 
726
        init_tm(t_relocatable, "%RELOCATABLE-BLOCKS", 1000,0,20);
 
727
        init_tm(t_contiguous, "_CONTIGUOUS-BLOCKS", 1001,0,20);
 
728
        tm_table[t_relocatable].tm_nppage = PAGESIZE;
 
729
        tm_table[t_contiguous].tm_nppage = PAGESIZE;
 
730
 
 
731
 
 
732
        ncb = 0;
 
733
        ncbpage = 0;
 
734
        maxcbpage = 512;
 
735
        
 
736
}
 
737
 
 
738
DEFUN("STATICP",object,fSstaticp,SI,1,1,NONE,OO,OO,OO,OO,"Tell if the string or vector is static") (x)
 
739
object x;
 
740
{ RETURN1((inheap(x->ust.ust_self) ? sLt : sLnil));
 
741
}
 
742
 
 
743
cant_get_a_type()
 
744
{
 
745
        FEerror("Can't get a type.", 0);
 
746
}
 
747
 
 
748
DEFUNO("ALLOCATE",object,fSallocate,SI
 
749
   ,2,3,NONE,OO,IO,OO,OO,siLallocate,"")(type,npages,va_alist)
 
750
object type;
 
751
int npages;
 
752
va_dcl
 
753
{       int nargs=VFUN_NARGS;
 
754
        object really_do;
 
755
        va_list ap;
 
756
        struct typemanager *tm;
 
757
        int c, i;
 
758
        char *p, *pp;
 
759
        object f, x;
 
760
        int t;
 
761
 
 
762
        {va_start(ap);
 
763
         if (nargs>=3) really_do=va_arg(ap,object);else goto LDEFAULT3;
 
764
         goto LEND_VARARG;
 
765
       LDEFAULT3: really_do = Cnil;
 
766
       LEND_VARARG: va_end(ap);}
 
767
        
 
768
 
 
769
 
 
770
        CHECK_ARG_RANGE(2,3);
 
771
        t= t_from_type(type);
 
772
        if  (npages <= 0)
 
773
                FEerror("Allocate takes positive argument.", 1,
 
774
                        make_fixnum(npages));
 
775
        tm = tm_of(t);
 
776
        if (tm->tm_npage > npages) {npages=tm->tm_npage;}
 
777
        tm->tm_maxpage = npages;
 
778
        if (really_do != Cnil &&
 
779
            tm->tm_maxpage > tm->tm_npage)
 
780
          goto ALLOCATE;
 
781
        RETURN1(Ct);
 
782
 
 
783
ALLOCATE:
 
784
        if (t == t_contiguous) 
 
785
          FUNCALL(2,fSallocate_contiguous_pages(npages,really_do));
 
786
          
 
787
        else
 
788
          if (t==t_relocatable) 
 
789
            FUNCALL(2,fSallocate_relocatable_pages(npages,really_do));
 
790
        else{
 
791
          
 
792
        if (available_pages < tm->tm_maxpage - tm->tm_npage ||
 
793
            (pp = alloc_page(tm->tm_maxpage - tm->tm_npage)) == NULL) {
 
794
        FEerror("Can't allocate ~D pages for ~A.", 2,
 
795
                make_fixnum(npages), (make_simple_string(tm->tm_name+1)));
 
796
        }
 
797
            for (;  tm->tm_npage < tm->tm_maxpage;  pp += PAGESIZE)
 
798
              add_page_to_freelist(pp,tm);}
 
799
 
 
800
        RETURN1(Ct);
 
801
}
 
802
 
 
803
t_from_type(type)
 
804
     object type;
 
805
{
 
806
 
 
807
 int i;
 
808
 check_type_or_symbol_string(&type);
 
809
 for (i= (int)t_start ; i < (int)t_other ; i++)
 
810
   {struct typemanager *tm = &tm_table[i];
 
811
   if(tm->tm_name &&
 
812
      0==strncmp((tm->tm_name)+1,type->st.st_self,type->st.st_fillp)
 
813
      )
 
814
     return i;}
 
815
 FEerror("Unrecognized type",0);
 
816
}
 
817
/* When sgc is enabled the TYPE should have at least MIN pages of sgc type,
 
818
   and at most MAX of them.   Each page should be FREE_PERCENT free
 
819
   when the sgc is turned on.  FREE_PERCENT is an integer between 0 and 100. 
 
820
   */
 
821
 
 
822
DEFUN("ALLOCATE-SGC",object,fSallocate_sgc,SI
 
823
   ,4,4,NONE,OO,II,II,OO,"")(type,min,max,free_percent)
 
824
     object type;
 
825
     int min,max,free_percent;
 
826
{int m,t=t_from_type(type);
 
827
 struct typemanager *tm;
 
828
 object res;
 
829
 tm=tm_of(t);
 
830
  res= list(3,make_fixnum(tm->tm_sgc),
 
831
           make_fixnum(tm->tm_sgc_max),
 
832
           make_fixnum((100*tm->tm_sgc_minfree)/tm->tm_nppage));
 
833
 
 
834
 if(min<0 || max< min || min > 3000 || free_percent < 0 || free_percent > 100)
 
835
    goto END;
 
836
 tm->tm_sgc_max=max;
 
837
 tm->tm_sgc=min;
 
838
 tm->tm_sgc_minfree= (tm->tm_nppage *free_percent) /100;
 
839
 END:
 
840
 RETURN1(res);
 
841
}
 
842
 
 
843
/* Growth of TYPE will be by at least MIN pages and at most MAX pages.
 
844
   It will try to grow PERCENT of the current pages.
 
845
   */
 
846
DEFUN("ALLOCATE-GROWTH",object,fSallocate_growth,SI,5,5,NONE,OO,II,II,OO,"")
 
847
     (type,min,max,percent,percent_free)
 
848
int min,max,percent,percent_free;
 
849
object type;
 
850
{int  t=t_from_type(type);
 
851
 struct typemanager *tm=tm_of(t);
 
852
 object res;
 
853
 res= list(4,make_fixnum(tm->tm_min_grow),
 
854
           make_fixnum(tm->tm_max_grow),
 
855
           make_fixnum(tm->tm_growth_percent),
 
856
           make_fixnum(tm->tm_percent_free));
 
857
 
 
858
 if(min<0 || max< min || min > 3000 || percent < 0 || percent > 500 
 
859
    || percent_free <0 || percent_free > 100
 
860
    )
 
861
    goto END;
 
862
 tm->tm_max_grow=max;
 
863
 tm->tm_min_grow=min;
 
864
 tm->tm_growth_percent= percent;
 
865
 tm->tm_percent_free= percent_free;
 
866
 END:
 
867
 RETURN1(res);
 
868
}
 
869
 
 
870
 
 
871
 
 
872
DEFUNO("ALLOCATE-CONTIGUOUS-PAGES",object,fSallocate_contiguous_pages,SI
 
873
   ,1,2,NONE,OI,OO,OO,OO,siLalloc_contpage,"")(npages,va_alist)
 
874
int npages;
 
875
va_dcl
 
876
{       int nargs=VFUN_NARGS;
 
877
        object really_do;
 
878
        va_list ap;
 
879
        int m;
 
880
        char *p;
 
881
 
 
882
        { va_start(ap);
 
883
          if (nargs>=2) really_do=va_arg(ap,object);else goto LDEFAULT2;
 
884
          goto LEND_VARARG;
 
885
        LDEFAULT2: really_do = Cnil ;
 
886
        LEND_VARARG: va_end(ap);}
 
887
 
 
888
 
 
889
        CHECK_ARG_RANGE(1,2);
 
890
        if  (npages  < 0)
 
891
                FEerror("Allocate requires positive argument.", 0);
 
892
        if (ncbpage > npages)
 
893
          { printf("Allocate contiguous %d: %d already there pages",npages,ncbpage);
 
894
            npages=ncbpage;}
 
895
        maxcbpage = npages;
 
896
        if (really_do == Cnil) { RETURN1(Ct);}
 
897
        m = maxcbpage - ncbpage;
 
898
        if (available_pages < m || (p = alloc_page(m)) == NULL)
 
899
                FEerror("Can't allocate ~D pages for contiguous blocks.",
 
900
                        1, make_fixnum(npages));
 
901
        {int i ;
 
902
        for (i = 0;  i < m;  i++)
 
903
                type_map[page(p + PAGESIZE*i)] = (char)t_contiguous;
 
904
        }
 
905
        ncbpage += m;
 
906
        insert_contblock(p, PAGESIZE*m);
 
907
        RETURN1(Ct);
 
908
}
 
909
 
 
910
 
 
911
DEFUNO("ALLOCATED-CONTIGUOUS-PAGES",object,fSallocated_contiguous_pages,SI
 
912
   ,0,0,NONE,OO,OO,OO,OO,siLncbpage,"")()
 
913
{
 
914
        /* 0 args */
 
915
        RETURN1((make_fixnum(ncbpage)));
 
916
}
 
917
 
 
918
DEFUNO("MAXIMUM-CONTIGUOUS-PAGES",object,fSmaximum_contiguous_pages,SI
 
919
   ,0,0,NONE,OO,OO,OO,OO,siLmaxcbpage,"")()
 
920
{
 
921
        /* 0 args */
 
922
        RETURN1((make_fixnum(maxcbpage)));
 
923
}
 
924
 
 
925
 
 
926
DEFUNO("ALLOCATE-RELOCATABLE-PAGES",object,fSallocate_relocatable_pages,SI
 
927
   ,1,2,NONE,OI,OO,OO,OO,siLalloc_relpage,"")(npages,va_alist)
 
928
int npages;
 
929
va_dcl
 
930
{       int nargs=VFUN_NARGS;
 
931
        object really_do;
 
932
        va_list ap;
 
933
 
 
934
        char *p;
 
935
 
 
936
        { va_start(ap);
 
937
          if (nargs>=2) really_do=va_arg(ap,object);else goto LDEFAULT2;
 
938
          goto LEND_VARARG;
 
939
        LDEFAULT2: really_do = Cnil ;
 
940
        LEND_VARARG: va_end(ap);}
 
941
 
 
942
        CHECK_ARG_RANGE(1,2);
 
943
        if (npages  <= 0)
 
944
                FEerror("Requires positive arg",0);
 
945
        if (nrbpage > npages && rb_pointer >= rb_start + PAGESIZE*npages - 2*RB_GETA
 
946
         || 2*npages > real_maxpage-page(heap_end)-new_holepage-real_maxpage/32)
 
947
          FEerror("Can't set the limit for relocatable blocks to ~D.",
 
948
                  1, make_fixnum(npages));
 
949
        rb_end += (npages-nrbpage)*PAGESIZE;
 
950
        nrbpage = npages;
 
951
        rb_limit = rb_end - 2*RB_GETA;
 
952
        alloc_page(-(holepage + nrbpage));
 
953
        vs_top = vs_base;
 
954
        vs_push(Ct);
 
955
        RETURN1(make_fixnum(npages));
 
956
}
 
957
 
 
958
DEFUNO("ALLOCATED-RELOCATABLE-PAGES",object,fSallocated_relocatable_pages,SI
 
959
   ,0,0,NONE,OO,OO,OO,OO,siLnrbpage,"")()
 
960
{
 
961
        /* 0 args */
 
962
        RETURN1(make_fixnum(nrbpage));
 
963
}
 
964
 
 
965
DEFUNO("GET-HOLE-SIZE",object,fSget_hole_size,SI
 
966
   ,0,0,NONE,OO,OO,OO,OO,siLget_hole_size,"")()
 
967
{
 
968
        /* 0 args */
 
969
        RETURN1((make_fixnum(new_holepage)));
 
970
}
 
971
 
 
972
DEFUNO("SET-HOLE-SIZE",object,fSset_hole_size,SI
 
973
   ,1,2,NONE,OI,IO,OO,OO,siLset_hole_size,"")(npages,va_alist)
 
974
int npages;
 
975
va_dcl
 
976
{       int nargs=VFUN_NARGS;
 
977
        int reserve;
 
978
        va_list ap;
 
979
        { va_start(ap);
 
980
          if (nargs>=2) reserve=va_arg(ap,int);else goto LDEFAULT2;
 
981
          goto LEND_VARARG;
 
982
        LDEFAULT2: reserve = 30;
 
983
        LEND_VARARG: va_end(ap);}
 
984
 
 
985
        if (npages < 1 ||
 
986
            npages > real_maxpage - page(heap_end)
 
987
            - 2*nrbpage - real_maxpage/32)
 
988
                FEerror("Illegal value for the hole size.", 0);
 
989
        new_holepage = npages;
 
990
        if (VFUN_NARGS ==2)
 
991
          {
 
992
            if (reserve <0 || reserve > new_holepage)
 
993
              FEerror("Illegal value for the hole size.", 0);
 
994
            reserve_pages_for_signal_handler = reserve;}
 
995
 
 
996
        RETURN2(make_fixnum(npages),
 
997
                make_fixnum(reserve_pages_for_signal_handler));
 
998
}
 
999
 
 
1000
 
 
1001
init_alloc_function()
 
1002
{
 
1003
}
 
1004
 
 
1005
object malloc_list;
 
1006
 
 
1007
#ifndef DONT_NEED_MALLOC
 
1008
 
 
1009
/*
 
1010
        UNIX malloc simulator.
 
1011
 
 
1012
        Used by
 
1013
                getwd, popen, etc.
 
1014
*/
 
1015
 
 
1016
 
 
1017
 
 
1018
/*  If this is defined, substitute the fast gnu malloc for the slower
 
1019
    version below.   If you have many calls to malloc this is worth
 
1020
    your while.   I have only tested it slightly under 4.3Bsd.   There
 
1021
    the difference in a test run with 120K mallocs and frees,
 
1022
    was 29 seconds to 1.9 seconds */
 
1023
    
 
1024
#ifdef GNU_MALLOC
 
1025
#include "malloc.c"
 
1026
#else
 
1027
 
 
1028
/* a very young malloc may use this simple baby malloc, for the init
 
1029
 code before we even get to main.c.  If this is not defined, then
 
1030
 malloc will try to run the init code which will work on many machines
 
1031
 but some such as WindowsNT under cygwin need this.
 
1032
 
 
1033
 */
 
1034
#ifdef BABY_MALLOC_SIZE
 
1035
 
 
1036
/* by giving an initialization, make it not be in bss, since
 
1037
   bss may not get loaded until main is reached.  We may
 
1038
   not even know our own name at this stage. */
 
1039
static char baby_malloc_data[BABY_MALLOC_SIZE]={1,0};
 
1040
static char *last_baby= baby_malloc_data;
 
1041
 
 
1042
static char *baby_malloc(n)
 
1043
     int n;
 
1044
{
 
1045
  char *res= last_baby;
 
1046
  int m;
 
1047
  n = ROUND_UP_PTR(n);
 
1048
   m = n+ sizeof(int);
 
1049
  if ((res +m-baby_malloc_data) > sizeof(baby_malloc_data))
 
1050
    {
 
1051
     printf("failed in baby malloc");
 
1052
     exit(1);
 
1053
    }
 
1054
  last_baby += m;
 
1055
  *((int *)res)=n;
 
1056
  return res+sizeof(int);
 
1057
}
 
1058
#endif
 
1059
 
 
1060
#ifdef HAVE_LIBBFD
 
1061
 
 
1062
int in_bfd_init=0;
 
1063
 
 
1064
/* configure size, static init ? */
 
1065
static char bfd_buf[/*  4392 */5000];
 
1066
static char *bfd_buf_p=bfd_buf;
 
1067
 
 
1068
static void *
 
1069
bfd_malloc(int n) {
 
1070
 
 
1071
  char *c;
 
1072
 
 
1073
  c=bfd_buf_p;
 
1074
  n+=7;
 
1075
  n>>=3;
 
1076
  n<<=3;
 
1077
  if (c+n>bfd_buf+sizeof(bfd_buf)) {
 
1078
    fprintf(stderr,"Not enough space in bfd_buf %d %d\n",n,sizeof(bfd_buf)-(bfd_buf_p-bfd_buf));
 
1079
    exit(1);
 
1080
  }
 
1081
  bfd_buf_p+=n;
 
1082
  return (void *)c;
 
1083
 
 
1084
}
 
1085
#endif
 
1086
 
 
1087
char *
 
1088
malloc(size)
 
1089
int size;
 
1090
{
 
1091
        object x;
 
1092
        
 
1093
#ifdef HAVE_LIBBFD
 
1094
        if (in_bfd_init)
 
1095
          return bfd_malloc(size);
 
1096
#endif
 
1097
 
 
1098
#ifdef BABY_MALLOC_SIZE
 
1099
        if (GBC_enable == 0) return baby_malloc(size);
 
1100
#else   
 
1101
        if (GBC_enable==0) {
 
1102
           if ( initflag ==0)
 
1103
             init_alloc();
 
1104
           else {
 
1105
#ifdef       RECREATE_HEAP
 
1106
                RECREATE_HEAP
 
1107
#endif
 
1108
                ;
 
1109
           }
 
1110
        }
 
1111
 
 
1112
#endif  
 
1113
      
 
1114
 
 
1115
        x = alloc_simple_string(size);
 
1116
 
 
1117
        x->st.st_self = alloc_contblock(size);
 
1118
#ifdef SGC
 
1119
        perm_writable(x->st.st_self,size);
 
1120
#endif
 
1121
        malloc_list = make_cons(x, malloc_list);
 
1122
 
 
1123
        return(x->st.st_self);
 
1124
}
 
1125
 
 
1126
 
 
1127
void
 
1128
free(ptr)
 
1129
#ifndef NO_VOID_STAR
 
1130
void *
 
1131
#else
 
1132
char *
 
1133
#endif  
 
1134
  ptr;
 
1135
{
 
1136
        object *p;
 
1137
        object endp_temp;
 
1138
        if (ptr == 0)
 
1139
          return;
 
1140
#ifdef BABY_MALLOC_SIZE
 
1141
        if ((void *)ptr < (void *) &baby_malloc_data[sizeof(baby_malloc_data)])
 
1142
          return;
 
1143
#endif  
 
1144
        for (p = &malloc_list; *p && !endp(*p);  p = &((*p)->c.c_cdr))
 
1145
                if ((*p)->c.c_car->st.st_self == ptr) {
 
1146
                        insert_contblock((*p)->c.c_car->st.st_self,
 
1147
                                         (*p)->c.c_car->st.st_dim);
 
1148
                        (*p)->c.c_car->st.st_self = NULL;
 
1149
                        *p = (*p)->c.c_cdr;
 
1150
                        return ;
 
1151
                }
 
1152
#ifdef NOFREE_ERR
 
1153
        return ;
 
1154
#else   
 
1155
        FEerror("free(3) error.",0);
 
1156
        return;
 
1157
#endif  
 
1158
}
 
1159
 
 
1160
char *
 
1161
realloc(ptr, size)
 
1162
char *ptr;
 
1163
int size;
 
1164
{
 
1165
        object x;
 
1166
        int i, j;
 
1167
        object endp_temp;
 
1168
        /* was allocated by baby_malloc */
 
1169
#ifdef BABY_MALLOC_SIZE 
 
1170
        if (ptr >= baby_malloc_data && ptr -baby_malloc_data <BABY_MALLOC_SIZE)
 
1171
          {
 
1172
            int dim = ((int *)ptr)[-1];
 
1173
            if (dim > size)
 
1174
              return ptr;
 
1175
           else
 
1176
          {  char *new= malloc(size);
 
1177
             bcopy(ptr,new,dim);
 
1178
             return new;
 
1179
          }
 
1180
 
 
1181
          }
 
1182
#endif /*  BABY_MALLOC_SIZE      */
 
1183
 
 
1184
        
 
1185
        if(ptr == NULL) return malloc(size);
 
1186
        for (x = malloc_list;  !endp(x);  x = x->c.c_cdr)
 
1187
                if (x->c.c_car->st.st_self == ptr) {
 
1188
                        x = x->c.c_car;
 
1189
                        if (x->st.st_dim >= size) {
 
1190
                                x->st.st_fillp = size;
 
1191
                                return(ptr);
 
1192
                        } else {
 
1193
                                j = x->st.st_dim;
 
1194
                                x->st.st_self = alloc_contblock(size);
 
1195
                                x->st.st_fillp = x->st.st_dim = size;
 
1196
                                for (i = 0;  i < size;  i++)
 
1197
                                        x->st.st_self[i] = ptr[i];
 
1198
                                insert_contblock(ptr, j);
 
1199
                                return(x->st.st_self);
 
1200
                        }
 
1201
                }
 
1202
        FEerror("realloc(3) error.", 0);
 
1203
}
 
1204
 
 
1205
#endif /* gnumalloc */
 
1206
 
 
1207
 
 
1208
char *
 
1209
calloc(nelem, elsize)
 
1210
int nelem, elsize;
 
1211
{
 
1212
        char *ptr;
 
1213
        int i;
 
1214
 
 
1215
        ptr = malloc(i = nelem*elsize);
 
1216
        while (--i >= 0)
 
1217
                ptr[i] = 0;
 
1218
        return(ptr);
 
1219
}
 
1220
 
 
1221
 
 
1222
cfree(ptr)
 
1223
char *ptr;
 
1224
{
 
1225
        free(ptr);
 
1226
 
 
1227
}
 
1228
 
 
1229
#endif
 
1230
 
 
1231
 
 
1232
#ifndef GNUMALLOC
 
1233
char *
 
1234
memalign(align,size)
 
1235
     int align,size;
 
1236
{ object x = alloc_simple_string(size);
 
1237
  x->st.st_self = ALLOC_ALIGNED(alloc_contblock,size,align);
 
1238
  malloc_list = make_cons(x, malloc_list);
 
1239
  return x->st.st_self;
 
1240
}
 
1241
#ifdef WANT_VALLOC
 
1242
char *
 
1243
valloc(size)
 
1244
int size;     
 
1245
{ return memalign(getpagesize(),size);}
 
1246
#endif
 
1247
 
 
1248
#endif