-
Notifications
You must be signed in to change notification settings - Fork 8
/
data.c
1307 lines (1234 loc) · 40.7 KB
/
data.c
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
/* MIRANDA DATA REPRESENTATIONS */
/**************************************************************************
* Copyright (C) Research Software Limited 1985-90. All rights reserved. *
* The Miranda system is distributed as free software under the terms in *
* the file "COPYING" which is included in the distribution. *
* *
* Revised to C11 standard and made 64bit compatible, January 2020 *
*------------------------------------------------------------------------*/
#include "data.h"
#include "big.h"
#include "lex.h"
#define INITSPACE 1250000
word SPACE=INITSPACE; /* false ceiling in heap to improve paging behaviour
during compilation */
extern word SPACELIMIT; /* see steer.c for default value */
/* SPACELIMIT controls the size of the heap (i.e. the number of list
cells available) - the minimum survivable number given the need to
compile the prelude etc is probably about 6000 */
/* Note: the size of a list cell is 2 ints + 1 char */
#define BIGTOP (SPACELIMIT + ATOMLIMIT)
word listp=ATOMLIMIT-1;
word *hdspace,*tlspace;
long long cellcount=0;
long claims=0;
long nogcs=0;
extern int atgc,loading; /* flags, set in steer.c */
word *dstack=0,*stackp,*dlim;
/* stackp=dstack; // if load_script made interruptible, add to reset */
#define poschar(c) !(negchar((c)-1))
#define negchar(c) (c&128)
/* safest to test for -ve chars this way, since not all m/c's do sign
extension - DT Jan 84 */
static void bases(void);
static void bindparams(word,word);
static void dsetup(void);
static void dump_defs(word,FILE *);
static void dump_ob(word,FILE *);
static word hdsort(word);
static word load_defs(FILE *);
static void mark(word);
static void unscramble(word);
word trueheapsize()
{ return(nogcs==0?listp-ATOMLIMIT+1:SPACE); }
void setupheap()
{ hdspace=(word *)malloc(SPACELIMIT*sizeof(word));
tlspace=(word *)malloc(SPACELIMIT*sizeof(word));
hd=hdspace-ATOMLIMIT; tl=tlspace-ATOMLIMIT;
if(SPACE>SPACELIMIT)SPACE=SPACELIMIT;
tag=(char *)calloc(BIGTOP+1,sizeof(char));
/* NB use calloc because it sets contents to zero */
/* tag[TOP] must be zero and exists as a sentinel */
if(hdspace==NULL||tlspace==NULL||tag==NULL)mallocfail("heap");
}
void resetheap() /* warning - cannot do this dynamically, because both the
compiler and the reducer hold onto absolute heap addresses
during certain space consuming computations */
{ if(SPACELIMIT<trueheapsize())
fprintf(stderr,"impossible event in resetheap\n"),exit(1);
hdspace=(word *)realloc((char *)hdspace,SPACELIMIT*sizeof(word));
if(hdspace==NULL)mallocfail("heap");
tlspace=(word *)realloc((char *)tlspace,SPACELIMIT*sizeof(word));
if(tlspace==NULL)mallocfail("heap");
hd=hdspace-ATOMLIMIT; tl=tlspace-ATOMLIMIT;
tag=(char *)realloc(tag,BIGTOP+1);
if(tag==NULL)mallocfail("heap");
tag[BIGTOP]=0;
if(SPACE>SPACELIMIT)SPACE=SPACELIMIT;
if(SPACE<INITSPACE&&INITSPACE<=SPACELIMIT)SPACE=INITSPACE,tag[TOP]=0;
/* tag[TOP] is always zero and exists as a sentinel */
}
void mallocfail(x)
char *x;
{ fprintf(stderr,"panic: cannot find enough free space for %s\n",x);
exit(1);
}
void resetgcstats()
{ cellcount= -claims;
nogcs = 0;
initclock();
}
word make(t,x,y) /* creates a new cell with "tag" t, "hd" x and "tl" y */
unsigned char t; word x,y;
{ while(poschar(tag[++listp]));
/* find next cell with zero or negative tag (=unwanted) */
if(listp==TOP)
{ if(SPACE!=SPACELIMIT){
if(!compiling)SPACE=SPACELIMIT; else
if(claims<=SPACE/4&&nogcs>1)
{ /* during compilation we raise false ceiling whenever residency
reaches 75% on 2 successive gc's */
static word wait=0;
word sp=SPACE;
if(wait)wait--; else
SPACE+= SPACE/2,wait=2,
SPACE=5000*(1+(SPACE-1)/5000); /* round upwards */
if(SPACE>SPACELIMIT)SPACE=SPACELIMIT;
if(atgc&&SPACE>sp)
printf( "\n<<increase heap from %ld to %ld>>\n",sp,SPACE);
}}
if(listp==TOP)
{
#if defined ORION105
asm("savew6");
gc();
asm("restw6");
#elif defined sparc
asm("ta 0x03"); /* see /usr/include/sun4/trap.h */
/* asm("ta ST_FLUSH_WINDOWS"); */
gc();
#else
gc();
#endif
if(t>STRCONS)mark(x);
if(t>=INT)mark(y);
return(make(t,x,y)); }
}
claims++;
tag[listp]= t;
hd[listp]= x;
tl[listp]= y;
return(listp); }
int collecting=0; /* flag for reset(), in case interrupt strikes in gc */
void gc() /* the "garbage collector" */
{ char *p1;
extern word making;
collecting=1;
p1= &(tag[ATOMLIMIT]);
if(atgc)
printf("\n<<gc after %ld claims>>\n",claims);
if(claims<=SPACE/10 && nogcs>1 && SPACE==SPACELIMIT)
{ /* if heap utilisation exceeds 90% on 2 successive gc's, give up */
static word hnogcs=0;
if(nogcs==hnogcs)
{ extern int ideep;
extern char *current_script;
fprintf(stderr,"<<not enough heap space -- task abandoned>>\n");
if(!compiling)outstats();
if(compiling&&ideep==0)
fprintf(stderr,"not enough heap to compile current script\n"),
fprintf(stderr,"script = \"%s\", heap = %ld\n",current_script,SPACE);
exit(1); } /* if compiling should reset() instead - FIX LATER */
else hnogcs=nogcs+1; }
nogcs++;
while((*p1= -*p1))p1++; /* make all tags -ve (= unwanted) */
bases();
/*if(atgc)printf("bases() done\n"); // DEBUG */
listp= ATOMLIMIT - 1;
cellcount+= claims;
claims= 0;
collecting=0;
}
/* int Icount; // DEBUG */
void gcpatch() /* called when gc interrupted - see reset in steer.c */
/* must not allocate any cells between calling this and next gc() */
{ char *p1;
for(p1= &(tag[ATOMLIMIT]);*p1;p1++)if(negchar(*p1))*p1= -*p1;
/* otherwise mutator crashes on funny tags */
}
void bases() /* marks everthing that must be saved */
{ word *p;
extern YYSTYPE yyval;
extern word *cstack;
extern word fileq,primenv;
extern word cook_stdin,common_stdin,common_stdinb,rv_expr,rv_script;
extern word margstack,vergstack,litstack,linostack,prefixstack;
extern word idsused,suppressids,lastname,
eprodnts,nonterminals,ntmap,ihlist,ntspecmap,gvars,lexvar;
extern word R,TABSTRS,SGC,ND,SBND,NT,current_id,meta_pending;
extern word showchain,newtyps,algshfns,errs,speclocs;
extern word SUBST[],tvmap,localtvmap;
extern word tfnum,tfbool,tfbool2,tfnum2,tfstrstr,
tfnumnum,ltchar,bnf_t,tstep,tstepuntil;
extern word exec_t,read_t,filestat_t;
extern word big_one;
extern word nill,standardout;
extern word lexstates,lexdefs,oldfiles,includees,embargoes,exportfiles,
exports,internals, freeids,tlost,detrop,rfl,bereaved,ld_stuff;
extern word CLASHES,ALIASES,SUPPRESSED,TSUPPRESSED,DETROP,MISSING,fnts,FBS;
extern word outfilq,waiting;
/* Icount=0; // DEBUG */
p= (word *)&p;
/* we follow everything on the C stack that looks like a pointer into
list space. This is failsafe in that the worst that can happen,if e.g. a
stray integer happens to point into list space, is that the garbage
collector will collect less garbage than it could have done */
if(p<cstack) /* which way does stack grow? */
while(++p!=cstack)mark(*p);/* for machines with stack growing downwards */
else
while(--p!=cstack)mark(*p);/* for machines with stack growing upwards */
mark(*cstack);
/* now follow all pointer-containing external variables */
mark(outfilq);
mark(waiting);
if(compiling||rv_expr||rv_script) /* rv flags indicate `readvals' in use */
{ extern YYSTYPE *yyvs, *yyvsp;
extern word namebucket[];
extern word *pnvec,nextpn; /* private name vector */
extern word make_status;
word i;
mark(make_status);
mark(primenv);
mark(fileq);
mark(idsused);
mark(eprodnts);
mark(nonterminals);
mark(ntmap);
mark(ihlist);
mark(ntspecmap);
mark(gvars);
mark(lexvar);
mark(common_stdin);
mark(common_stdinb);
mark(cook_stdin);
mark(margstack);
mark(vergstack);
mark(litstack);
mark(linostack);
mark(prefixstack);
mark(files);
mark(oldfiles);
mark(includees);
mark(freeids);
mark(exports);
mark(internals);
mark(CLASHES);
mark(ALIASES);
mark(SUPPRESSED);
mark(TSUPPRESSED);
mark(DETROP);
mark(MISSING);
mark(FBS);
mark(lexstates);
mark(lexdefs);
for(i=0;i<128;i++)
if(namebucket[i])mark(namebucket[i]);
for(p=dstack;p<stackp;p++)mark(*p);
if(loading)
{ mark(algshfns);
mark(speclocs);
mark(exportfiles);
mark(embargoes);
mark(rfl);
mark(detrop);
mark(bereaved);
mark(ld_stuff);
mark(tlost);
for(i=0;i<nextpn;i++)mark(pnvec[i]); }
mark(lastname);
mark(suppressids);
mark(lastexp);
mark(nill);
mark(standardout);
mark(big_one);
mark(yyval);
/* for(vp= yyvs;vp<=yyvsp;vp++)mark(*vp); */
mark(yylval);
mark(R);
mark(TABSTRS);
mark(SGC);
mark(ND);
mark(SBND);
mark(NT);
mark(current_id);
mark(meta_pending);
mark(newtyps);
mark(showchain);
mark(errs);
mark(tfnum);
mark(tfbool);
mark(tfbool2);
mark(tfnum2);
mark(tfstrstr);
mark(tfnumnum);
mark(ltchar);
mark(bnf_t);
mark(exec_t);
mark(read_t);
mark(filestat_t);
mark(tstep);
mark(tstepuntil);
mark(tvmap);
mark(localtvmap);
for(i=0;i<hashsize;i++)mark(SUBST[i]); }
/* if(atgc)printf("<<%d I-nodes>>\n",Icount); // DEBUG */
}
void mark(x) /* a marked cell is distinguished by having a +ve "tag" */
word x;
{ x&= ~tlptrbits; /* x may be a `reversed pointer' (see reduce.c) */
while(isptr(x)&&negchar(tag[x]))
{ /*if(hd[x]==I)Icount++; // DEBUG */
if((tag[x]= -tag[x])<INT)return;
if(tag[x]>STRCONS)mark(hd[x]);
x= tl[x]&~tlptrbits; }
}
/* test added Jan 2020 - DT */
#define wordsize (__WORDSIZE)
#if wordsize==32
#define splitdouble
union fpdatum {double real; struct{word left;word right;} bits;};
#elif wordsize==64
union fpdatum {double real; word bits;};
#else
#error "platform has unknown word size"
#endif
double get_dbl(x)
word x;
{ union fpdatum r;
#ifdef splitdouble
r.bits.left= hd[x];
r.bits.right= tl[x];
#else
r.bits= hd[x];
#endif
return(r.real); }
/* Miranda's arithmetic model requires fp overflow trapped. On sparc this
can be done by setting a trap with ieee_handler (see steer.c) otherwise
we test for overflow with isfinite() */
word sto_dbl(R)
double R;
{ union fpdatum r;
#if !defined sparc /* */
if(!isfinite(R))fpe_error(); /* see note on arithmetic model above */
#endif
r.real=R;
#ifdef splitdouble
return(make(DOUBLE,r.bits.left,r.bits.right));
#else
return(make(DOUBLE,r.bits,0));
#endif
}
void setdbl(x,R)
word x;
double R;
{ union fpdatum r;
#if !defined sparc /* */
if(!isfinite(R))fpe_error(); /* see note on arithmetic model above */
#endif
r.real=R;
tag[x]=DOUBLE;
#ifdef splitdouble
hd[x]=r.bits.left; tl[x]=r.bits.right;
#else
hd[x]=r.bits; tl[x]=0;
#endif
}
word sto_char(c) /* assumes 0<=c<=UMAX */
int c;
{ return c<256?c:make(UNICODE,c,0); }
word get_char(x)
word x;
{ if(x<256)return x;
if(tag[x]==UNICODE)return hd[x];
fprintf(stderr,"impossible event in get_char(x), tag[x]==%d\n",tag[x]);
exit(1);
}
int is_char(x)
word x;
{ return (0<=x && x<256) || tag[x]==UNICODE; }
word sto_id(p1)
char *p1;
{ return(make(ID,cons(strcons(p1,NIL),undef_t),UNDEF)); }
/* the hd of an ID contains cons(strcons(name,who),type) and
the tl has the value */
/* who is NIL, hereinfo, or cons(aka,hereinfo) where aka
is of the form datapair(oldname,0) oldname being a string */
/* hereinfo is fileinfo(script,line_no) */
/* hereafter is stuff for dumping and undumping compiled scripts
w means (sizeof(word)) in bytes
(internal heap object) (external file rep - char sequence)
---------------------- -----------------------------------
0..127 self
128..383 CHAR_X (self-128)
384..ATOMLIMIT-1 (self-256)
integer (-127..127) SHORT_X <byte>
integer INT_X <4n bytes> (-1)
double DBL_X <8 bytes>
unicode_char UNICODE_X <4 bytes>
typevar TVAR_X <byte>
ap(x,y) [x] [y] AP_X
cons(x,y) [y] [x] CONS_X
id (=occurrence) ID_X <string terminated by '\0'>
pname (=occurrence) PN_X <2 bytes>
PN1_X <4 bytes>
datapair(string,0) AKA_X <string...\0>
fileinfo(script,line_no) HERE_X <string...\0> <2 bytes> (**)
constructor(n,x) [x] CONSTRUCT_X <2 bytes>
readvals(h,t) [t] RV_X
definition [val] [type] [who] [id] DEF_X
[val] [pname] DEF_X
definition-list [definition*] DEF_X
filename <string terminated by '\0'>
mtime <w bytes>
complete script __WORDSIZE
XVERSION
[ [filename]
[mtime]
[shareable] (=0 or 1)
[definition-list] ]+
'\0'
[definition-list] (algshfns)
[ND] or [True] (see below)
DEF_X
[SGC]
DEF_X
[freeids]
DEF_X
[definition-list] (internals)
type-error script __WORDSIZE
XVERSION
'\1'
<w bytes> (=errline)
... (rest as normal script)
syntax-error script __WORDSIZE
XVERSION
`\0'
<w bytes> (=errline)
[ [filename]
[mtime] ]+
Notes
-----
first filename in dump must be that of `current_script' (ie the
main source file). All pathnames in dump are correct wrt the
directory of the main source.
(**) empty string is abbreviation for current filename in hereinfo
True in ND position indicates an otherwise correct dump whose exports
include type orphans
Pending:
--------
could have abbreviation for iterated ap and cons
remaining issue - external format should be machine and version
independent - not clear how to do this
*/
#define XBASE ATOMLIMIT-256
#define CHAR_X (XBASE)
#define SHORT_X (XBASE+1)
#define INT_X (XBASE+2)
#define DBL_X (XBASE+3)
#define ID_X (XBASE+4)
#define AKA_X (XBASE+5)
#define HERE_X (XBASE+6)
#define CONSTRUCT_X (XBASE+7)
#define RV_X (XBASE+8)
#define PN_X (XBASE+9)
#define PN1_X (XBASE+10)
#define DEF_X (XBASE+11)
#define AP_X (XBASE+12)
#define CONS_X (XBASE+13)
#define TVAR_X (XBASE+14)
#define UNICODE_X (XBASE+15)
#define XLIMIT (XBASE+16)
#if XLIMIT>512
#error "coding scheme breaks down: XLIMIT>512"
#endif
void putword(x,f)
word x;
FILE *f;
{ int i=sizeof(word);
putc(x&255,f);
while(--i)x>>=8,putc(x&255,f);
}
word getword(f)
FILE *f;
{ int s=0, i=sizeof(word);
word x=getc(f);
while(--i)s += 8, x |= getc(f)<<s;
return x;
}
void putint(int n,FILE *f)
{ fwrite(&n,sizeof(int),1,f); }
int getint(FILE *f)
{ int r;
fread(&r,sizeof(int),1,f);
return r; }
void putdbl(word x,FILE *f)
{ double d = get_dbl(x);
fwrite(&d,sizeof(double),1,f); }
word getdbl(FILE *f)
{ double d;
fread(&d,sizeof(double),1,f);
return sto_dbl(d);
}
static char prefix[pnlim];
word preflen;
void setprefix(p) /* to that of pathname p */
char *p;
{ char *g;
(void)strcpy(prefix,p);
g=rindex(prefix,'/');
if(g)g[1]='\0';
else *prefix='\0';
preflen = strlen(prefix);
} /* before calling dump_script or load_script must setprefix() to that
of current pathname of file being dumped/loaded - to get correct
translation between internal pathnames (relative to dump script)
and external pathnames */
char *mkrel(p) /* makes pathname p correct relative to prefix */
char *p; /* must use when writing pathnames to dump */
{ if(strncmp(prefix,p,preflen)==0)return(p+preflen);
if(p[0]=='/')return(p);
fprintf(stderr,"impossible event in mkrelative\n"); /* or use getwd */
/* not possible because all relative pathnames in files were computed
wrt current script */
return(p); /* proforma only */
}
#define bits_15 0177777
char *CFN;
void dump_script(files,f) /* write compiled script files to file f */
word files;
FILE *f;
{ extern word ND,bereaved,errline,algshfns,internals,freeids,SGC;
putc(wordsize,f);
putc(XVERSION,f); /* identifies dump format */
if(files==NIL){ /* source contains syntax or metatype error */
extern word oldfiles;
word x;
putc(0,f);
putword(errline,f);
for(x=oldfiles;x!=NIL;x=tl[x])
fprintf(f,"%s",mkrel(get_fil(hd[x]))),putc(0,f),
/*filename*/
putword(fil_time(hd[x]),f); /* mtime */
return; }
if(ND!=NIL)putc(1,f),putword(errline,f);
for(;files!=NIL;files=tl[files])
{ fprintf(f,"%s",mkrel(CFN=get_fil(hd[files]))); /* filename */
putc(0,f);
putword(fil_time(hd[files]),f);
putc(fil_share(hd[files]),f);
dump_defs(fil_defs(hd[files]),f);
}
putc(0,f); /* header - not a possible filename */
dump_defs(algshfns,f);
if(ND==NIL&&bereaved!=NIL)dump_ob(True,f); /* special flag */
else dump_ob(ND,f);
putc(DEF_X,f);
dump_ob(SGC,f);
putc(DEF_X,f);
dump_ob(freeids,f);
putc(DEF_X,f);
dump_defs(internals,f);
}
void dump_defs(defs,f) /* write list of defs to file f */
word defs;
FILE *f;
{ while(defs!=NIL)
if(tag[hd[defs]]==STRCONS) /* pname */
{ word v=get_pn(hd[defs]);
dump_ob(pn_val(hd[defs]),f);
if(v>bits_15)
putc(PN1_X,f),
putint(v,f);
else
putc(PN_X,f),
putc(v&255,f),
putc(v >> 8,f);
putc(DEF_X,f);
defs=tl[defs]; }
else
{ dump_ob(id_val(hd[defs]),f);
dump_ob(id_type(hd[defs]),f);
dump_ob(id_who(hd[defs]),f);
putc(ID_X,f);
fprintf(f,"%s",(char *)get_id(hd[defs]));
putc(0,f);
putc(DEF_X,f);
defs=tl[defs]; }
putc(DEF_X,f); /* delimiter */
}
void dump_ob(x,f) /* write combinatory expression x to file f */
word x;
FILE *f;
{ /* printob("dumping: ",x); // DEBUG */
switch(tag[x])
{ case ATOM: if(x<128)putc(x,f); else
if(x>=384)putc(x-256,f); else
putc(CHAR_X,f),putc(x-128,f);
return;
case TVAR: putc(TVAR_X,f), putc(gettvar(x),f);
if(gettvar(x)>255)
fprintf(stderr,"panic, tvar too large\n");
return;
case INT: { word d=digit(x);
if(rest(x)==0&&(d&MAXDIGIT)<=127)
{ if(d&SIGNBIT)d= -(d&MAXDIGIT);
putc(SHORT_X,f); putc(d,f); return; }
putc(INT_X,f);
putint(d,f);
x=rest(x);
while(x)
putint(digit(x),f),x=rest(x);
putint(-1,f);
return; }
/* 4 bytes per digit wasteful at current value of IBASE */
case DOUBLE: putc(DBL_X,f);
putdbl(x,f);
/*
putword(hd[x],f);
#ifdef splitdouble
putword(tl[x],f);
#endif
*/
return;
case UNICODE: putc(UNICODE_X,f);
putint(hd[x],f);
return;
case DATAPAIR: fprintf(f,"%c%s",AKA_X,(char *)hd[x]);
putc(0,f);
return;
case FILEINFO: { word line=tl[x];
if((char *)hd[x]==CFN)putc(HERE_X,f);
else fprintf(f,"%c%s",HERE_X,mkrel(hd[x]));
putc(0,f);
putc(line&255,f);
putc((line >>= 8)&255,f);
if(line>255)fprintf(stderr,
"impossible line number %ld in dump_ob\n",tl[x]);
return; }
case CONSTRUCTOR: dump_ob(tl[x],f);
putc(CONSTRUCT_X,f);
putc(hd[x]&255,f);
putc(hd[x]>>8,f);
return;
case STARTREADVALS: dump_ob(tl[x],f);
putc(RV_X,f);
return;
case ID: fprintf(f,"%c%s",ID_X,get_id(x));
putc(0,f);
return;
case STRCONS: { word v=get_pn(x); /* private name */
if(v>bits_15)
putc(PN1_X,f),
putint(v,f);
else
putc(PN_X,f),
putc(v&255,f),
putc(v >> 8,f);
return; }
case AP: dump_ob(hd[x],f);
dump_ob(tl[x],f);
putc(AP_X,f);
return;
case CONS: dump_ob(tl[x],f);
dump_ob(hd[x],f);
putc(CONS_X,f);
return;
default: fprintf(stderr,"impossible tag %d in dump_ob\n",tag[x]);
}
}
#define ovflocheck if(dicq-dic>DICSPACE)dicovflo()
extern char *dic; extern word DICSPACE;
word BAD_DUMP=0,CLASHES=NIL,ALIASES=NIL,PNBASE=0,SUPPRESSED=NIL,
TSUPPRESSED=NIL,TORPHANS=0;
word load_script(f,src,aliases,params,main)
/* loads a compiled script from file f for source src */
/* main=1 if is being loaded as main script, 0 otherwise */
FILE *f;
char *src;
word aliases,params,main;
{ extern word nextpn,ND,errline,algshfns,internals,freeids,includees,SGC;
extern char *dicp, *dicq;
word ch,files=NIL;
TORPHANS=BAD_DUMP=0;
CLASHES=NIL;
dsetup();
setprefix(src);
if(getc(f)!= wordsize || getc(f)!=XVERSION)
{ BAD_DUMP= -1; return(NIL); }
if(aliases!=NIL)
{ /* for each `old' install diversion to `new' */
/* if alias is of form -old `new' is a pname */
word a,hold;
ALIASES=aliases;
for(a=aliases;a!=NIL;a=tl[a])
{ word old=tl[hd[a]],new=hd[hd[a]];
hold=cons(id_who(old),cons(id_type(old),id_val(old)));
id_type(old)=alias_t;
id_val(old)=new;
if(tag[new]==ID)
if((id_type(new)!=undef_t||id_val(new)!=UNDEF)
&&id_type(new)!=alias_t)
CLASHES=add1(new,CLASHES);
hd[hd[a]]=hold;
}
if(CLASHES!=NIL){ BAD_DUMP= -2; unscramble(aliases); return(NIL); }
for(a=aliases;a!=NIL;a=tl[a]) /* FIX1 */
if(tag[ch=id_val(tl[hd[a]])]==ID) /* FIX1 */
if(id_type(ch)!=alias_t) /* FIX1 */
id_type(ch)=new_t; /* FIX1 */
}
PNBASE=nextpn; /* base for relocation of internal names in dump */
SUPPRESSED=NIL; /* list of `-id' aliases successfully obeyed */
TSUPPRESSED=NIL; /* list of -typename aliases (illegal just now) */
while((ch=getc(f))!=0&&ch!=EOF&&!BAD_DUMP)
{ word s,holde=0;
dicq=dicp;
if(files==NIL&&ch==1) /* type error script */
{ holde=getword(f),ch=getc(f);
if(main)errline=holde; }
if(ch!='/')(void)strcpy(dicp,prefix),dicq+=preflen;
/* locate wrt current posn */
*dicq++ = ch;
while((*dicq++ =ch=getc(f))&&ch!=EOF); /* filename */
ovflocheck;
ch=getword(f); /* mtime */
s=getc(f); /* share bit */
/*printf("loading: %s(%d)\n",dicp,ch); // DEBUG */
if(files==NIL) /* is this the right dump? */
if(strcmp(dicp,src))
{ BAD_DUMP=1;
if(aliases!=NIL)unscramble(aliases);
return(NIL); }
CFN=get_id(name()); /* wasteful way to share filename */
files = cons(make_fil(CFN,ch,s,load_defs(f)),
files);
}
/* warning: load_defs side effects id's in namebuckets, cannot be undone by
unload until attached to global `files', so interrupts are disabled during
load_script - see steer.c */ /* for big dumps this may be too coarse - FIX */
if(ch==EOF||BAD_DUMP){ if(!BAD_DUMP)BAD_DUMP=2;
if(aliases!=NIL)unscramble(aliases);
return(files); }
if(files==NIL){ /* dump of syntax error state */
extern word oldfiles;
ch=getword(f);
if(main)errline=ch;
while((ch=getc(f))!=EOF)
{ dicq=dicp;
if(ch!='/')(void)strcpy(dicp,prefix),dicq+=preflen;
/* locate wrt current posn */
*dicq++ = ch;
while((*dicq++ =ch=getc(f))&&ch!=EOF); /* filename */
ovflocheck;
ch=getword(f); /* mtime */
if(oldfiles==NIL) /* is this the right dump? */
if(strcmp(dicp,src))
{ BAD_DUMP=1;
if(aliases!=NIL)unscramble(aliases);
return(NIL); }
oldfiles = cons(make_fil(get_id(name()),ch,0,NIL),
oldfiles);
}
if(aliases!=NIL)unscramble(aliases);
return(NIL); }
algshfns=append1(algshfns,load_defs(f));
ND=load_defs(f);
if(ND==True)ND=NIL,TORPHANS=1;
SGC=append1(SGC,load_defs(f));
if(main||includees==NIL)freeids=load_defs(f);
else bindparams(load_defs(f),hdsort(params));
if(aliases!=NIL)unscramble(aliases);
if(main)internals=load_defs(f);
return(reverse(files));
}/* was it necessary to unscramble aliases before error returns?
check this later */
/* actions labelled FIX1 were inserted to deal with the pathological case
that the destination of an alias (not part of a cyclic alias) has a direct
definition in the file and the aliasee is missing from the file
- this is both nameclash and missing aliasee, but without fix the two
errors cancel each other out and are unreported */
word DETROP=NIL,MISSING=NIL;
void bindparams(formal,actual) /* process bindings of free ids */
/* formal is list of cons(id,cons(original_name,type)) */
/* actual is list of cons(name,value) | ap(name,typevalue)) */
/* both in alpha order of original name */
word formal,actual;
{ extern word FBS; word badkind=NIL;
DETROP=MISSING=NIL;
FBS=cons(formal,FBS);
/* FBS is list of list of formals bound in current script */
for(;;)
{ word a; char *f;
while(formal!=NIL && (actual==NIL ||
strcmp((f=(char *)hd[hd[tl[hd[formal]]]]),get_id(a=hd[hd[actual]]))<0))
/* the_val(hd[hd[formal]])=findid((char *)hd[hd[tl[hd[formal]]]]),
above line picks up identifier of that name in current scope */
MISSING=cons(hd[tl[hd[formal]]],MISSING),
formal=tl[formal];
if(actual==NIL)break;
if(formal==NIL||strcmp(f,get_id(a)))DETROP=cons(a,DETROP);
else { word fa=tl[tl[hd[formal]]]==type_t?t_arity(hd[hd[formal]]):-1;
word ta=tag[hd[actual]]==AP?t_arity(hd[actual]):-1;
if(fa!=ta)
badkind=cons(cons(hd[hd[actual]],datapair(fa,ta)),badkind);
the_val(hd[hd[formal]])=tl[hd[actual]];
formal=tl[formal]; }
actual=tl[actual];
}
for(;badkind!=NIL;badkind=tl[badkind])
DETROP=cons(hd[badkind],DETROP);
}
void unscramble(aliases) /* remove old to new diversions installed above */
word aliases;
{ word a=NIL;
for(;aliases!=NIL;aliases=tl[aliases])
{ word old=tl[hd[aliases]],hold=hd[hd[aliases]];
word new=id_val(old);
hd[hd[aliases]]=new; /* put back for missing check, see below */
id_who(old)=hd[hold]; hold=tl[hold];
id_type(old)=hd[hold];
id_val(old)=tl[hold]; }
for(;ALIASES!=NIL;ALIASES=tl[ALIASES])
{ word new=hd[hd[ALIASES]];
word old=tl[hd[ALIASES]];
if(tag[new]!=ID)
{ if(!member(SUPPRESSED,new))a=cons(old,a);
continue; } /* aka stuff irrelevant to pnames */
if(id_type(new)==new_t)id_type(new)=undef_t; /* FIX1 */
if(id_type(new)==undef_t)a=cons(old,a); else
if(!member(CLASHES,new))
/* install aka info in new */
if(tag[id_who(new)]!=CONS)
id_who(new)=cons(datapair(get_id(old),0),id_who(new)); }
ALIASES=a; /* transmits info about missing aliasees */
}
char *getaka(x) /* returns original name of x (as a string) */
word x;
{ word y=id_who(x);
return(tag[y]!=CONS?get_id(x):(char *)hd[hd[y]]);
}
word get_here(x) /* here info for id x */
word x;
{ word y=id_who(x);
return(tag[y]==CONS?tl[y]:y);
}
void dsetup()
{ if(!dstack)
{ dstack=(word *)malloc(1000*sizeof(word));
if(dstack==NULL)mallocfail("dstack");
dlim=dstack+1000; }
stackp=dstack;
}
void dgrow()
{ word *hold=dstack;
dstack=(word *)realloc(dstack,2*(dlim-dstack)*sizeof(word));
if(dstack==NULL)mallocfail("dstack");
dlim=dstack+2*(dlim-hold);
stackp += dstack-hold;
/*printf("dsize=%d\n",dlim-dstack); // DEBUG */
}
word load_defs(f) /* load a sequence of definitions from file f, terminated
by DEF_X, or a single object terminated by DEF_X */
FILE *f;
{ extern char *dicp, *dicq;
extern word *pnvec,common_stdin,common_stdinb,nextpn,rv_script;
word ch, defs=NIL;
while((ch=getc(f))!=EOF)
{ if(stackp==dlim)dgrow();
switch(ch)
{ case CHAR_X: *stackp++ = getc(f)+128;
continue;
case TVAR_X: *stackp++ = mktvar(getc(f));
continue;
case SHORT_X: ch = getc(f);
if(ch&128)ch= ch|(~127); /*force a sign extension*/
*stackp++ = stosmallint(ch);
continue;
case INT_X: { word *x;
ch = getint(f);
*stackp++ = make(INT,ch,0);
x = &rest(stackp[-1]);
ch = getint(f);
while(ch!= -1)
*x=make(INT,ch,0),ch=getint(f),x= &rest(*x);
continue; }
case DBL_X: *stackp++ = getdbl(f);
/*
#ifdef splitdouble
*stackp++ = make(DOUBLE,ch,getword(f));
#else
*stackp++ = make(DOUBLE,ch,0);
#endif
*/
continue;
case UNICODE_X: *stackp++ = make(UNICODE,getint(f),0);
continue;
case PN_X: ch = getc(f);
ch = PNBASE+(ch|(getc(f)<<8));
*stackp++ = ch<nextpn?pnvec[ch]:sto_pn(ch);
/* efficiency hack for *stackp++ = sto_pn(ch); */
continue;
case PN1_X: ch=PNBASE+getint(f);
*stackp++ = ch<nextpn?pnvec[ch]:sto_pn(ch);
/* efficiency hack for *stackp++ = sto_pn(ch); */
continue;
case CONSTRUCT_X: ch = getc(f);
ch = ch|(getc(f)<<8);
stackp[-1] = constructor(ch,stackp[-1]);
continue;
case RV_X: stackp[-1] = readvals(0,stackp[-1]);
rv_script=1;
continue;
case ID_X: dicq=dicp;
while((*dicq++ =ch=getc(f))&&ch!=EOF);
ovflocheck;
*stackp++=name(); /* see lex.c */
if(id_type(stackp[-1])==new_t) /* FIX1 (& next 2 lines) */
CLASHES=add1(stackp[-1],CLASHES),stackp[-1]=NIL;
else
if(id_type(stackp[-1])==alias_t) /* follow alias */
stackp[-1]=id_val(stackp[-1]);
continue;
case AKA_X: dicq=dicp;
while((*dicq++ =ch=getc(f))&&ch!=EOF);
ovflocheck;
*stackp++=datapair(get_id(name()),0);
/* wasteful, to share string */
continue;
case HERE_X: dicq=dicp;
ch=getc(f);
if(!ch){ /* coding hack, 0 means current file name */
ch = getc(f);
ch = ch|getc(f)<<8;
*stackp++ = fileinfo(CFN,ch);
continue; }
/* next line locates wrt current posn */
if(ch!='/')(void)strcpy(dicp,prefix),dicq+=preflen;
*dicq++ = ch;
while((*dicq++ =ch=getc(f))&&ch!=EOF);
ovflocheck;
ch = getc(f);
ch = ch|getc(f)<<8;
*stackp++ = fileinfo(get_id(name()),ch); /* wasteful */
continue;
case DEF_X: switch(stackp-dstack){
case 0: /* defs delimiter */
{ /*printlist("contents: ",defs); // DEBUG */
return(reverse(defs)); }
case 1: /* ob delimiter */
{ return(*--stackp); }
case 2: /* pname defn */
{ ch = *--stackp;
pn_val(ch)= *--stackp;
defs=cons(ch,defs); /* NB defs now includes pnames */
continue; }
case 4:
if(tag[stackp[-1]]!=ID){
if(stackp[-1]==NIL){ stackp -= 4; continue; } /* FIX1 */
else { /* id aliased to pname */
word akap;
ch= *--stackp;
SUPPRESSED=cons(ch,SUPPRESSED);
stackp--; /* who */