1 /*  Part of SWI-Prolog
2 
3     Author:        Jan Wielemaker
4     E-mail:        J.Wielemaker@vu.nl
5     WWW:           http://www.swi-prolog.org
6     Copyright (c)  1985-2020, University of Amsterdam
7                               VU University Amsterdam
8 			      CWI, Amsterdam
9     All rights reserved.
10 
11     Redistribution and use in source and binary forms, with or without
12     modification, are permitted provided that the following conditions
13     are met:
14 
15     1. Redistributions of source code must retain the above copyright
16        notice, this list of conditions and the following disclaimer.
17 
18     2. Redistributions in binary form must reproduce the above copyright
19        notice, this list of conditions and the following disclaimer in
20        the documentation and/or other materials provided with the
21        distribution.
22 
23     THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
24     "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
25     LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
26     FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
27     COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
28     INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
29     BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
30     LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
31     CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32     LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
33     ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34     POSSIBILITY OF SUCH DAMAGE.
35 */
36 
37 /*#define O_DEBUG 1*/
38 #include "pl-incl.h"
39 #include "pl-comp.h"
40 #include "pl-arith.h"
41 #include "os/pl-utf8.h"
42 #include "pl-dbref.h"
43 #include "pl-dict.h"
44 #ifdef HAVE_SYS_PARAM_H
45 #include <sys/param.h>
46 #endif
47 #ifdef HAVE_UNISTD_H
48 #include <unistd.h>
49 #endif
50 
51 #ifdef O_DEBUG
52 #define Qgetc(s) Sgetc(s)
53 #define TRACK_POS ""
54 #else
55 #define Qgetc(s) Snpgetc(s)		/* ignore position recording */
56 #define TRACK_POS "r"
57 #endif
58 
59 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
60 SWI-Prolog can compile Prolog source files into intermediate code files,
61 which can be loaded very  fast.   They  can  be  saved  as  stand  alone
62 executables using Unix #! magic number.
63 
64 A wic file consists of the magic code and a version check code.  This is
65 followed by the command line option   defaults.  Then an optional series
66 of `include' statements follow.  Finally   the predicates and directives
67 are  described.   Predicates  are  described    close  to  the  internal
68 representation.  Directives are stored as  binary terms representing the
69 query.
70 
71 The default options and include statements are written incrementally  in
72 each  wic  file.   In  the  normal  boot  cycle  first  the boot file is
73 determined.  Then the option structure is filled with the default option
74 found in this boot file.  Next the command line arguments are scanned to
75 obtain all options.  Then stacks, built  in's,  etc.   are  initialised.
76 The  the  boot  file is read again, but now only scanning for directives
77 and predicates.
78 
79 IF YOU CHANGE ANYTHING TO THIS FILE, SO THAT OLD WIC-FILES CAN NO LONGER
80 BE READ, PLEASE DO NOT FORGET TO INCREMENT THE VERSION NUMBER!
81 
82 Below is an informal description of the format of a `.qlf' file:
83 
84 <wic-file>	::=	<magic code>
85 			<version number>
86 			<bits-per-word>
87 			<home>				% a <string>
88 			{<statement>}
89 			'T'
90 ----------------------------------------------------------------
91 <qlf-file>	::=	<qlf-magic>
92 			<version-number>
93 			<bits-per-word>
94 			'F' <string>			% path of qlf file
95 			{'I' <include>}
96 			'Q' <qlf-part>
97 <qlf-magic>	::=	<string>
98 <qlf-module>	::=	<qlf-header>
99 			<size>				% size in bytes
100 			{<statement>}
101 			'X'
102 <qlf-header>	::=	'M' <XR/modulename>		% module name
103 			<source>			% file + time
104 			<line>
105 			{'S' <XR/supername>}
106 			{<qlf-export>}
107 			'X'
108 		      | <source>			% not a module
109 			<time>
110 <qlf-export>	::=	'E' <XR/functor>
111 <source>	::=	'F' <string> <time> <system>
112 		      | '-'
113 ----------------------------------------------------------------
114 <magic code>	::=	<string>			% normally #!<path>
115 <version number>::=	<num>
116 <statement>	::=	'W' <string>			% include wic file
117 		      | 'P' <XR/functor>		% predicate
118 			    <flags>
119 			    {<clause>} <pattern>
120 		      |	'O' <XR/modulename>		% pred out of module
121 			    <XR/functor>
122 			    <flags>
123 			    {<clause>} <pattern>
124 		      | 'D'
125 		        <lineno>			% source line number
126 			<term>				% directive
127 		      | 'E' <XR/functor>		% export predicate
128 		      | 'I' <XR/procedure> <flags>	% import predicate
129 		      | 'Q' <qlf-module>		% include module
130 		      | 'M' <XR/modulename>		% load-in-module
131 		            {<statement>}
132 			    'X'
133 <flags>		::=	<num>				% Bitwise or of PRED_*
134 <clause>	::=	'C' <#codes>
135 			    <line_no>
136 			    <owner_file>
137 			    <source_file>
138 			    <# prolog vars> <# vars>
139 			    <is_fact>			% 0 or 1
140 			    <#n subclause> <codes>
141 		      | 'X'				% end of list
142 <XR>		::=	XR_REF     <num>		% XR id from table
143 			XR_NIL				% []
144 			XR_CONS				% functor of [_|_]
145 			XR_ATOM    <len><chars>		% atom
146 			XR_BLOB	   <blob><private>	% typed atom (blob)
147 			XR_INT     <num>		% number
148 			XR_FLOAT   <word>*		% float (double)
149 			XR_STRING  <string>		% string
150 			XR_STRING_UTF8  <utf-8 string>	% wide string
151 			XR_FUNCTOR <XR/name> <num>	% functor
152 			XR_PRED    <XR/fdef> <XR/module>% predicate
153 			XR_MODULE  <XR/name>		% module
154 			XR_FILE	   's'|'u' <XR/atom> <time>
155 				   '-'
156 			XR_BLOB_TYPE <len><chars>	% blob type-name
157 <term>		::=	<num>				% # variables in term
158 			<theterm>
159 <theterm>	::=	<XR/atomic>			% atomic data
160 		      | 'v' <num>			% variable
161 		      | 't' <XR/functor> {<theterm>}	% compound
162 <system>	::=	's'				% system source file
163 		      | 'u'				% user source file
164 <time>		::=	<word>				% time file was loaded
165 <line>		::=	<num>
166 <codes>		::=	<num> {<code>}
167 <string>	::=	{<non-zero byte>} <0>
168 <word>		::=	<4 byte entity>
169 <include>	::=	<owner> <parent> <line> <file> <time>
170 
171 Integers are stored in  a  packed  format   to  reduce  the  size of the
172 intermediate code file as  99%  of  them   is  normally  small,  but  in
173 principle not limited (virtual  machine   codes,  arities,  table sizes,
174 etc). We use the "zigzag" encoding to   deal  with negative integers and
175 write the positive value in chunks  of   7  bits, least significant bits
176 first. The last byte has its 0x80 mask set.
177 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
178 
179 #define QLFMAGICNUM 0x716c7374		/* "qlst" on little-endian machine */
180 
181 #define XR_REF		0		/* reference to previous */
182 #define XR_NIL		1		/* [] */
183 #define XR_CONS		2		/* functor of [_|_] */
184 #define XR_ATOM		3		/* atom */
185 #define XR_FUNCTOR	4		/* functor */
186 #define XR_PRED		5		/* procedure */
187 #define XR_INT		6		/* int */
188 #define XR_FLOAT	7		/* float */
189 #define XR_STRING	8		/* string */
190 #define XR_FILE		9		/* source file */
191 #define XR_MODULE      10		/* a module */
192 #define XR_BLOB	       11		/* a typed atom (blob) */
193 #define XR_BLOB_TYPE   12		/* name of atom-type declaration */
194 #define XR_STRING_UTF8 13		/* Wide character string */
195 #define XR_NULL	       14		/* NULL pointer */
196 
197 #define V_LABEL	      256		/* Label pseudo opcode */
198 #define V_H_INTEGER   257		/* Abstract various H_INT variations */
199 #define V_B_INTEGER   258		/* Abstract various B_INT variations */
200 #define V_A_INTEGER   259		/* Abstract various A_INT variations */
201 
202 #define PRED_SYSTEM	 0x01		/* system predicate */
203 #define PRED_HIDE_CHILDS 0x02		/* hide my childs */
204 
205 static char saveMagic[] = "SWI-Prolog state (www.swi-prolog.org)\n";
206 static char qlfMagic[]  = "SWI-Prolog .qlf file\n";
207 
208 typedef struct source_mark
209 { long		file_index;
210   struct source_mark *next;
211 } source_mark, *SourceMark;
212 
213 
214 #define XR_BLOCKS 32
215 typedef struct xr_table
216 { unsigned int	id;			/* next id to give out */
217   struct xr_table* previous;		/* stack */
218   Word	        blocks[XR_BLOCKS];	/* main table */
219   word		preallocated[7];
220 } xr_table, *XrTable;
221 
222 
223 typedef struct path_translated
224 { struct path_translated *next;
225   atom_t from;
226   atom_t to;
227 } path_translated;
228 
229 typedef struct qlf_state
230 { char *save_dir;			/* Directory saved */
231   char *load_dir;			/* Directory loading */
232   int	has_moved;			/* Paths must be translated */
233   path_translated *translated;		/* Translated paths */
234   struct qlf_state *previous;		/* previous saved state (reentrance) */
235 } qlf_state;
236 
237 
238 typedef struct wic_state
239 { char *wicFile;			/* name of output file */
240   char *mkWicFile;			/* Wic file under construction */
241   IOSTREAM *wicFd;			/* file descriptor of wic file */
242 
243   Definition currentPred;		/* current procedure */
244   SourceFile currentSource;		/* current source file */
245 
246   Table idMap;				/* mapped identifiers */
247   Table	savedXRTable;			/* saved XR entries */
248   intptr_t savedXRTableId;		/* next id to hand out */
249 
250   SourceMark source_mark_head;		/* Locations of sources */
251   SourceMark source_mark_tail;
252   int	     has_source_marks;
253 
254   int        saved_version;		/* Version saved */
255   int	     obfuscate;			/* Obfuscate source */
256   int	     load_nesting;		/* Nesting level of loadPart() */
257   qlf_state *load_state;		/* current load-state */
258 
259   xr_table *XR;				/* external references */
260 
261   struct
262   { int		invalid_wide_chars;	/* Cannot represent due to UCS-2 */
263   } errors;
264 
265   struct wic_state *parent;		/* parent state */
266 } wic_state;
267 
268 static char *	getString(IOSTREAM *, size_t *len);
269 static int64_t	getInt64(IOSTREAM *);
270 static int	getInt32(IOSTREAM *s);
271 static int	getInt(IOSTREAM *);
272 static double	getFloat(IOSTREAM *);
273 static bool	loadWicFd(wic_state *state);
274 static bool	loadPredicate(wic_state *state, int skip ARG_LD);
275 static bool	loadImport(wic_state *state, int skip ARG_LD);
276 static void	saveXRBlobType(wic_state *state, PL_blob_t *type);
277 static void	putString(const char *, size_t len, IOSTREAM *);
278 static void	putInt64(int64_t, IOSTREAM *);
279 static void	putFloat(double, IOSTREAM *);
280 static void	saveWicClause(wic_state *state, Clause cl);
281 static void	closePredicateWic(wic_state *state);
282 static word	loadXRc(wic_state *state, int c ARG_LD);
283 static atom_t   getBlob(wic_state *state ARG_LD);
284 static bool	loadStatement(wic_state *state, int c, int skip ARG_LD);
285 static bool	loadPart(wic_state *state, Module *module, int skip ARG_LD);
286 static bool	loadInModule(wic_state *state, int skip ARG_LD);
287 static int	qlfVersion(wic_state *state, const char *magic, int *vp);
288 static atom_t	qlfFixSourcePath(wic_state *state, const char *raw);
289 static int	pushPathTranslation(wic_state *state, const char *loadname, int flags);
290 static void	popPathTranslation(wic_state *state);
291 static int	qlfIsCompatible(wic_state *state, const char *magic);
292 
293 /* Convert CA1_VAR arguments to VM independent and back
294 */
295 #define VAR_OFFSET(i) ((intptr_t)((i) - (ARGOFFSET / (intptr_t) sizeof(word))))
296 #define OFFSET_VAR(i) ((intptr_t)((i) + (ARGOFFSET / (intptr_t) sizeof(word))))
297 
298 #undef LD
299 #define LD LOCAL_LD
300 
301 
302 		 /*******************************
303 		 *     LOADED XR ID HANDLING	*
304 		 *******************************/
305 
306 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
307 XR reference handling during loading. This   uses  a dynamic array using
308 doubling sub arrays as also used for atoms, functors, etc.
309 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
310 
311 static void
pushXrIdTable(wic_state * state)312 pushXrIdTable(wic_state *state)
313 { XrTable t = allocHeapOrHalt(sizeof(*t));
314 
315   memset(t, 0, sizeof(*t));
316   t->id = 0;
317   t->blocks[0] = t->preallocated - 1;
318   t->blocks[1] = t->preallocated - 1;
319   t->blocks[2] = t->preallocated - 1;
320 
321   t->previous = state->XR;
322   state->XR = t;
323 }
324 
325 
326 static void
popXrIdTable(wic_state * state)327 popXrIdTable(wic_state *state)
328 { XrTable t = state->XR;
329   unsigned int id, idx;
330 
331   state->XR = t->previous;		/* pop the stack */
332 
333   for(id=0; id < 7; id++)
334   { word w = t->preallocated[id];
335 
336     if ( isAtom(w) )
337       PL_unregister_atom(w);
338   }
339   for(idx = 3; idx < XR_BLOCKS && t->blocks[idx]; idx++)
340   { size_t bs = (size_t)1<<idx;
341     Word p = t->blocks[idx]+bs;
342     size_t i;
343 
344     for(i=0; i<bs && id < t->id; i++, id++)
345     { word w = p[i];
346 
347       if ( isAtom(w) )
348 	PL_unregister_atom(w);
349     }
350 
351     freeHeap(p, bs*sizeof(word));
352   }
353 
354   freeHeap(t, sizeof(*t));
355 }
356 
357 
358 static word
lookupXrId(wic_state * state,unsigned int id)359 lookupXrId(wic_state *state, unsigned int id)
360 { XrTable t = state->XR;
361   unsigned int idx = MSB(id);
362 
363   DEBUG(CHK_SECURE, assert(t->blocks[idx]));
364   return t->blocks[idx][id];
365 }
366 
367 
368 static void
storeXrId(wic_state * state,unsigned int id,word value)369 storeXrId(wic_state *state, unsigned int id, word value)
370 { XrTable t = state->XR;
371   unsigned int idx = MSB(id);
372 
373   if ( !t->blocks[idx] )
374   { size_t bs = (size_t)1<<idx;
375     Word newblock;
376 
377     newblock = allocHeapOrHalt(bs*sizeof(word));
378     t->blocks[idx] = newblock-bs;
379   }
380 
381   t->blocks[idx][id] = value;
382 }
383 
384 
385 		 /*******************************
386 		 *	 PRIMITIVE LOADING	*
387 		 *******************************/
388 
389 #define PATH_ISDIR	0x1		/* pushPathTranslation() flags */
390 
391 static bool
qlfLoadError_ctx(wic_state * state,char * file,int line)392 qlfLoadError_ctx(wic_state *state, char *file, int line)
393 { fatalError("%s: QLF format error at index = %ld (%s:%d)",
394 	     state->wicFile, Stell(state->wicFd), file, line);
395 
396   fail;
397 }
398 
399 #define qlfLoadError(state) qlfLoadError_ctx(state, __FILE__, __LINE__)
400 
401 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
402 Load a string from the input stream.   There are two cases: 0-terminated
403 short strings (files, etc) have  length  set   to  NULL  and the general
404 Prolog string case has length pointing to  a pointer. The latter is used
405 only for saved (directive) terms and the   result  is thus pushed to the
406 global stack.
407 
408 Returns NULL if the string is too large.
409 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
410 
411 static char *
getString(IOSTREAM * fd,size_t * length)412 getString(IOSTREAM *fd, size_t *length)
413 { GET_LD
414   char *s;
415   size_t len = (size_t)getInt64(fd);
416   size_t i;
417 
418   if ( !length && len > MAXPATHLEN )
419     return NULL;
420   if ( length && len > globalStackLimit() )
421     return NULL;
422 
423   if ( LD->qlf.getstr_buffer_size < len+1 )
424   { size_t size = ((len+1+1023)/1024)*1024;
425 
426     if ( LD->qlf.getstr_buffer )
427       LD->qlf.getstr_buffer = realloc(LD->qlf.getstr_buffer, size);
428     else
429       LD->qlf.getstr_buffer = malloc(size);
430 
431     if ( LD->qlf.getstr_buffer )
432       LD->qlf.getstr_buffer_size = size;
433     else
434       outOfCore();
435   }
436 
437   for( i=0, s = LD->qlf.getstr_buffer; i<len; i++ )
438   { int c = Qgetc(fd);
439 
440     if ( c == EOF )
441       fatalError("Unexpected EOF on QLF file at offset %d",
442 		 Stell(fd));
443 
444     *s++ = c;
445   }
446   *s = EOS;
447 
448   if ( length )
449     *length = (unsigned) len;
450 
451   return LD->qlf.getstr_buffer;
452 }
453 
454 
455 pl_wchar_t *
wicGetStringUTF8(IOSTREAM * fd,size_t * length,pl_wchar_t * buf,size_t bufsize)456 wicGetStringUTF8(IOSTREAM *fd, size_t *length,
457 		 pl_wchar_t *buf, size_t bufsize)
458 { size_t i, len = (size_t)getInt64(fd);
459   IOENC oenc = fd->encoding;
460   pl_wchar_t *tmp, *o;
461 
462   if ( length )
463     *length = len;
464 
465   if ( len < bufsize )
466     tmp = buf;
467   else
468     tmp = PL_malloc(len*sizeof(pl_wchar_t));
469 
470   fd->encoding = ENC_UTF8;
471   for(i=0, o=tmp; i<len; i++)
472   { int c = Sgetcode(fd);
473 
474     if ( c < 0 )
475       fatalError("Unexpected EOF in UCS atom");
476     *o++ = c;
477   }
478   fd->encoding = oenc;
479 
480   return tmp;
481 }
482 
483 
484 
485 static atom_t
getAtom(IOSTREAM * fd,PL_blob_t * type)486 getAtom(IOSTREAM *fd, PL_blob_t *type)
487 { char buf[1024];
488   char *tmp, *s;
489   size_t len = getInt(fd);
490   size_t i;
491   atom_t a;
492 
493   if ( len < sizeof(buf) )
494     tmp = buf;
495   else
496     tmp = allocHeapOrHalt(len);
497 
498   for(s=tmp, i=0; i<len; i++)
499   { int c = Qgetc(fd);
500 
501     if ( c == EOF )
502       fatalError("Unexpected EOF on intermediate code file at offset %d",
503 		 Stell(fd));
504     *s++ = c;
505   }
506   if ( type )
507   { int new;
508 
509     a = lookupBlob(tmp, len, type, &new);
510   } else
511   { a = lookupAtom(tmp, len);
512   }
513 
514   if ( tmp != buf )
515     freeHeap(tmp, len);
516 
517   return a;
518 }
519 
520 
521 static PL_blob_t *
getBlobType(IOSTREAM * fd)522 getBlobType(IOSTREAM *fd)
523 { const char *name;
524 
525   if ( !(name = getString(fd, NULL)) )
526     fatalError("Invalid blob type in QLF");
527 
528   return PL_find_blob_type(name);
529 }
530 
531 
532 static char *
getMagicString(IOSTREAM * fd,char * buf,int maxlen)533 getMagicString(IOSTREAM *fd, char *buf, int maxlen)
534 { char *s;
535   int c;
536 
537   for( s = buf; --maxlen >= 0 && (*s = (c = Sgetc(fd))); s++ )
538   { if ( c == EOF )
539       return NULL;
540   }
541 
542   if ( maxlen > 0 )
543     return buf;
544 
545   return NULL;
546 }
547 
548 
549 static inline uint64_t
zigzag_encode(int64_t n)550 zigzag_encode(int64_t n)
551 { return (n << 1) ^ (n >> 63);
552 }
553 
554 
555 static inline int64_t
zigzag_decode(uint64_t n)556 zigzag_decode(uint64_t n)
557 { return (n >> 1) ^ -(n&1);
558 }
559 
560 
561 static int64_t
getInt64(IOSTREAM * fd)562 getInt64(IOSTREAM *fd)
563 { int c = Qgetc(fd);
564 
565   if ( c&0x80 )
566   { DEBUG(MSG_QLF_INTEGER, Sdprintf("%" PRId64 "\n", zigzag_decode(c&0x7f)));
567     return zigzag_decode(c&0x7f);
568   } else
569   { uint64_t v = c&0x7f;
570     int shift = 7;
571 
572     for(;;)
573     { c = Qgetc(fd);
574 
575       if ( c&0x80 )
576       { uint64_t l = (c&0x7f);
577 	v |= l<<shift;
578 	DEBUG(MSG_QLF_INTEGER, Sdprintf("%" PRId64 "\n", zigzag_decode(v)));
579 	return zigzag_decode(v);
580       } else
581       { uint64_t b = c;
582 	v |= b<<shift;
583 	shift += 7;
584       }
585     }
586   }
587 }
588 
589 
590 static int
getInt(IOSTREAM * fd)591 getInt(IOSTREAM *fd)
592 { int64_t val = getInt64(fd);
593 
594   return (int)val;
595 }
596 
597 
598 static unsigned int
getUInt(IOSTREAM * fd)599 getUInt(IOSTREAM *fd)
600 { unsigned int c = Qgetc(fd);
601 
602   if ( c&0x80 )
603   { DEBUG(MSG_QLF_INTEGER, Sdprintf("%d\n", c&0x7f));
604     return c&0x7f;
605   } else
606   { unsigned int v = c&0x7f;
607     int shift = 7;
608 
609     for(;;)
610     { c = Qgetc(fd);
611 
612       if ( c&0x80 )
613       { unsigned int l = (c&0x7f);
614 	v |= l<<shift;
615 	DEBUG(MSG_QLF_INTEGER, Sdprintf("%d\n", v));
616 	return v;
617       } else
618       { unsigned int b = c;
619 	v |= b<<shift;
620 	shift += 7;
621       }
622     }
623   }
624 }
625 
626 
627 #ifdef WORDS_BIGENDIAN
628 static const int double_byte_order[] = { 7,6,5,4,3,2,1,0 };
629 #else
630 static const int double_byte_order[] = { 0,1,2,3,4,5,6,7 };
631 #endif
632 
633 #define BYTES_PER_DOUBLE (sizeof(double_byte_order)/sizeof(int))
634 
635 static double
getFloat(IOSTREAM * fd)636 getFloat(IOSTREAM *fd)
637 { double f;
638   unsigned char *cl = (unsigned char *)&f;
639   unsigned int i;
640 
641   for(i=0; i<BYTES_PER_DOUBLE; i++)
642   { int c = Qgetc(fd);
643 
644     if ( c == -1 )
645       fatalError("Unexpected end-of-file in QLT file");
646     cl[double_byte_order[i]] = c;
647   }
648 
649   DEBUG(MSG_QLF_FLOAT, Sdprintf("getFloat() --> %f\n", f));
650 
651   return f;
652 }
653 
654 
655 static int
getInt32(IOSTREAM * s)656 getInt32(IOSTREAM *s)
657 { int v;
658 
659   v  = (Sgetc(s) & 0xff) << 24;
660   v |= (Sgetc(s) & 0xff) << 16;
661   v |= (Sgetc(s) & 0xff) << 8;
662   v |= (Sgetc(s) & 0xff);
663 
664   return v;
665 }
666 
667 
668 static inline word
loadXR__LD(wic_state * state ARG_LD)669 loadXR__LD(wic_state *state ARG_LD)
670 { return loadXRc(state, Qgetc(state->wicFd) PASS_LD);
671 }
672 #define loadXR(s) loadXR__LD(s PASS_LD)
673 
674 
675 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
676 loadXRc(int c0, IOSTREAM *fd ARG_LD) loads   a constant from the stream.
677 Note that some constants (integers, floats and  strings) can cause GC or
678 stack-shifts.
679 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
680 
681 static word
loadXRc(wic_state * state,int c ARG_LD)682 loadXRc(wic_state *state, int c ARG_LD)
683 { IOSTREAM *fd = state->wicFd;
684   word xr;
685   int id = 0;				/* make gcc happy! */
686 
687   switch( c )
688   { case XR_REF:
689     { unsigned int xr = getUInt(fd);
690       DEBUG(MSG_QLF_XR, Sdprintf("Reuse XR(%d)\n", (long)xr));
691       word val = lookupXrId(state, xr);
692 
693       return val;
694     }
695     case XR_NIL:
696       return ATOM_nil;
697     case XR_CONS:
698       return ATOM_dot;
699     case XR_ATOM:
700     { id = ++state->XR->id;
701       xr = getAtom(fd, NULL);
702       DEBUG(MSG_QLF_XR, Sdprintf("XR(%d) = '%s'\n", id, stringAtom(xr)));
703       break;
704     }
705     case XR_BLOB:
706     { id = ++state->XR->id;
707       xr = getBlob(state PASS_LD);
708       DEBUG(MSG_QLF_XR, Sdprintf("XR(%d) = <blob>\n", id));
709       break;
710     }
711     case XR_BLOB_TYPE:
712     { id = ++state->XR->id;
713       xr = (word)getBlobType(fd);
714       DEBUG(MSG_QLF_XR,
715 	    Sdprintf("XR(%d) = <blob-type>%s", id, ((PL_blob_t*)xr)->name));
716       break;
717     }
718     case XR_FUNCTOR:
719     { atom_t name;
720       int arity;
721 
722       id = ++state->XR->id;
723       name = loadXR(state);
724       arity = getInt(fd);
725       xr = (word) lookupFunctorDef(name, arity);
726       DEBUG(MSG_QLF_XR,
727 	    Sdprintf("XR(%d) = %s/%d\n", id, stringAtom(name), arity));
728       break;
729     }
730     case XR_PRED:
731     { functor_t f;
732       Module m;
733 
734       id = ++state->XR->id;
735       f = (functor_t) loadXR(state);
736       m = (Module) loadXR(state);
737       xr = (word) lookupProcedure(f, m);
738       DEBUG(MSG_QLF_XR,
739 	    Sdprintf("XR(%d) = proc %s\n", id, procedureName((Procedure)xr)));
740       break;
741     }
742     case XR_MODULE:
743     { GET_LD
744       atom_t name;
745       id = ++state->XR->id;
746       name = loadXR(state);
747       xr = (word) lookupModule(name);
748       DEBUG(MSG_QLF_XR, Sdprintf("XR(%d) = module %s\n", id, stringAtom(name)));
749       break;
750     }
751     case XR_INT:
752     { int64_t i = getInt64(fd);
753       word w;
754       int rc;
755 
756       if ( (rc=put_int64(&w, i, ALLOW_GC PASS_LD)) != TRUE )
757       { raiseStackOverflow(rc);
758 	return 0;
759       }
760 
761       return w;
762     }
763     case XR_FLOAT:
764     { word w;
765       double f = getFloat(fd);
766       int rc;
767 
768       if ( (rc=put_double(&w, f, ALLOW_GC PASS_LD)) != TRUE )
769       { raiseStackOverflow(rc);
770 	return 0;
771       }
772 
773       return w;
774     }
775 #if O_STRING
776     case XR_STRING:
777     { char *s;
778       size_t len;
779 
780       if ( (s = getString(fd, &len)) )
781       { return globalString(len, s);
782       } else
783       { raiseStackOverflow(GLOBAL_OVERFLOW);
784 	return 0;
785       }
786     }
787     case XR_STRING_UTF8:
788     { pl_wchar_t *w;
789       size_t len;
790       pl_wchar_t buf[256];
791       word s;
792 
793       w = wicGetStringUTF8(fd, &len, buf, sizeof(buf)/sizeof(pl_wchar_t));
794       s = globalWString(len, w);
795       if ( w != buf )
796 	PL_free(w);
797 
798       return s;
799     }
800 #endif
801     case XR_FILE:
802     { int c;
803 
804       id = ++state->XR->id;
805 
806       switch( (c=Qgetc(fd)) )
807       { case 'u':
808 	case 's':
809 	{ atom_t name   = loadXR(state);
810 	  double time   = getFloat(fd);
811 	  PL_chars_t text;
812 	  SourceFile sf;
813 
814 	  PL_STRINGS_MARK();
815 	  get_atom_text(name, &text);
816 	  PL_mb_text(&text, REP_UTF8);
817 	  sf = lookupSourceFile(qlfFixSourcePath(state, text.text.t), TRUE);
818 	  PL_STRINGS_RELEASE();
819 
820 	  if ( sf->mtime == 0.0 )
821 	  { sf->mtime   = time;
822 	    sf->system = (c == 's' ? TRUE : FALSE);
823 	  }
824 	  sf->count++;
825 	  xr = (word)sf;
826 	  /* do not release sf; part of state */
827 	  break;
828 	}
829 	case '-':
830 	  xr = 0;
831 	  break;
832 	default:
833 	  xr = 0;			/* make gcc happy */
834 	  fatalError("Illegal XR file index %d: %c", Stell(fd)-1, c);
835       }
836 
837       break;
838     }
839     case XR_NULL:
840       return 0;
841     default:
842     { xr = 0;				/* make gcc happy */
843       fatalError("Illegal XR entry at index %ld: %d", Stell(fd)-1, c);
844     }
845   }
846 
847   storeXrId(state, id, xr);
848 
849   return xr;
850 }
851 
852 
853 static atom_t
getBlob(wic_state * state ARG_LD)854 getBlob(wic_state *state ARG_LD)
855 { PL_blob_t *type = (PL_blob_t*)loadXR(state);
856 
857   if ( type->load )
858   { return (*type->load)(state->wicFd);
859   } else
860   { return getAtom(state->wicFd, type);
861   }
862 }
863 
864 
865 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
866 Returns FALSE while leaving a resource exception if the term cannot be
867 allocated.
868 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
869 
870 static int
do_load_qlf_term(wic_state * state,term_t vars[],term_t term ARG_LD)871 do_load_qlf_term(wic_state *state, term_t vars[], term_t term ARG_LD)
872 { IOSTREAM *fd = state->wicFd;
873   int c = Qgetc(fd);
874 
875   if ( c == 'v' )
876   { int id = getInt(fd);
877 
878     if ( vars[id] )
879     { return PL_unify(term, vars[id]);
880     } else
881     { if ( (vars[id] = PL_new_term_ref()) )
882       { PL_put_term(vars[id], term);
883 	return TRUE;
884       }
885       return FALSE;
886     }
887   } else if ( c == 't' )
888   { functor_t f;
889     term_t c2;
890 
891     if ( (f = (functor_t) loadXR(state)) &&
892 	 (c2 = PL_new_term_ref()) &&
893 	 PL_unify_functor(term, f) )
894     { int arity = arityFunctor(f);
895       int n;
896 
897       for(n=0; n < arity; n++)
898       { _PL_get_arg(n+1, term, c2);
899 	if ( !do_load_qlf_term(state, vars, c2 PASS_LD) )
900 	  return FALSE;
901       }
902 
903       return TRUE;
904     }
905 
906     return FALSE;
907   } else
908   { word w;
909 
910     if ( (w=loadXRc(state, c PASS_LD)) )
911       return _PL_unify_atomic(term, w);
912 
913     return FALSE;
914   }
915 }
916 
917 
918 static int
loadQlfTerm(wic_state * state,term_t term ARG_LD)919 loadQlfTerm(wic_state *state, term_t term ARG_LD)
920 { IOSTREAM *fd = state->wicFd;
921   int nvars;
922   Word vars;
923   int rc;
924 
925   DEBUG(MSG_QLF_TERM, Sdprintf("Loading from %ld ...", (long)Stell(fd)));
926 
927   if ( (nvars = getInt(fd)) )
928   { term_t *v;
929     int n;
930 
931     vars = alloca(nvars * sizeof(term_t));
932     for(n=nvars, v=vars; n>0; n--, v++)
933       *v = 0L;
934   } else
935     vars = NULL;
936 
937   PL_put_variable(term);
938   rc = do_load_qlf_term(state, vars, term PASS_LD);
939   if ( rc )
940     resortDictsInTerm(term);
941   DEBUG(MSG_QLF_TERM,
942 	Sdprintf("Loaded ");
943 	PL_write_term(Serror, term, 1200, 0);
944 	Sdprintf(" to %ld\n", (long)Stell(fd)));
945   return rc;
946 }
947 
948 
949 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
950 Load intermediate code state from the  specified stream. rcpath contains
951 the ZIP file name.
952 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
953 
954 int
loadWicFromStream(const char * rcpath,IOSTREAM * fd)955 loadWicFromStream(const char *rcpath, IOSTREAM *fd)
956 { wic_state state;
957   int rval;
958 
959   memset(&state, 0, sizeof(state));
960   state.wicFd = fd;
961   state.wicFile = (char*)rcpath;
962 
963   pushXrIdTable(&state);
964   rval = loadWicFd(&state);
965   popXrIdTable(&state);
966 
967   return rval;
968 }
969 
970 
971 static int
loadWicFile(const char * file)972 loadWicFile(const char *file)
973 { IOSTREAM *fd;
974   int rval;
975 
976   if ( !(fd = Sopen_file(file, "rb" TRACK_POS)) )
977   { warning("Cannot open Quick Load File %s: %s", file, OsError());
978     return FALSE;
979   }
980 
981   rval = loadWicFromStream(file, fd);
982   Sclose(fd);
983 
984   return rval;
985 }
986 
987 
988 static bool
loadWicFd(wic_state * state)989 loadWicFd(wic_state *state)
990 { GET_LD
991   IOSTREAM *fd = state->wicFd;
992 
993   if ( !qlfIsCompatible(state, saveMagic) ||
994        !pushPathTranslation(state, systemDefaults.home, PATH_ISDIR) )
995     return FALSE;
996 
997   for(;;)
998   { int c = Qgetc(fd);
999 
1000     switch( c )
1001     { case EOF:
1002       case 'T':				/* trailer */
1003 	popPathTranslation(state);
1004 	succeed;
1005       case 'W':
1006 	{ char *name = store_string(getString(fd, NULL) );
1007 
1008 	  if ( (name=getString(fd, NULL)) )
1009 	  { name = store_string(name);
1010 	    loadWicFile(name);
1011 	    continue;
1012 	  } else
1013 	  { fatalError("Invalid QLF: bad string");
1014 	    return FALSE;
1015 	  }
1016 	}
1017       case 'X':
1018         break;
1019       default:
1020         { loadStatement(state, c, FALSE PASS_LD);
1021 	  continue;
1022 	}
1023     }
1024   }
1025 }
1026 
1027 
1028 static bool
loadStatement(wic_state * state,int c,int skip ARG_LD)1029 loadStatement(wic_state *state, int c, int skip ARG_LD)
1030 { IOSTREAM *fd = state->wicFd;
1031 
1032   switch(c)
1033   { case 'P':
1034       return loadPredicate(state, skip PASS_LD);
1035 
1036     case 'O':
1037     { word mname = loadXR(state);
1038       Module om = LD->modules.source;
1039       bool rval;
1040 
1041       LD->modules.source = lookupModule(mname);
1042       rval = loadPredicate(state, skip PASS_LD);
1043       LD->modules.source = om;
1044 
1045       return rval;
1046     }
1047     case 'I':
1048       return loadImport(state, skip PASS_LD);
1049 
1050     case 'D':
1051     { fid_t cid;
1052 
1053       if ( (cid=PL_open_foreign_frame()) )
1054       { term_t goal = PL_new_term_ref();
1055 	atom_t  osf = source_file_name;
1056 	int     oln = source_line_no;
1057 
1058 	source_file_name = (state->currentSource ? state->currentSource->name
1059 						 : NULL_ATOM);
1060 	source_line_no   = getInt(fd);
1061 
1062 	if ( !loadQlfTerm(state, goal PASS_LD) )
1063 	  return FALSE;
1064 	DEBUG(MSG_QLF_DIRECTIVE,
1065 	      if ( source_file_name )
1066 	      { Sdprintf("%s:%d: Directive: ",
1067 			  PL_atom_chars(source_file_name), source_line_no);
1068 	      } else
1069 	      { Sdprintf("Directive: ");
1070 	      }
1071 	      PL_write_term(Serror, goal, 1200, PL_WRT_NEWLINE));
1072 	if ( !skip )
1073 	{ if ( !callProlog(MODULE_user, goal, PL_Q_NODEBUG, NULL) )
1074 	  { if ( !printMessage(ATOM_warning,
1075 			       PL_FUNCTOR_CHARS, "goal_failed", 2,
1076 			         PL_CHARS, "directive",
1077 			         PL_TERM, goal) )
1078 	      PL_clear_exception();
1079 	  }
1080 	}
1081 	PL_discard_foreign_frame(cid);
1082 
1083 	source_file_name = osf;
1084 	source_line_no   = oln;
1085 
1086 	succeed;
1087       }
1088 
1089       return FALSE;
1090     }
1091 
1092     case 'Q':
1093     { bool rc;
1094 
1095       state->load_nesting++;
1096       rc = loadPart(state, NULL, skip PASS_LD);
1097       state->load_nesting--;
1098 
1099       return rc;
1100     }
1101     case 'M':
1102       return loadInModule(state, skip PASS_LD);
1103 
1104     default:
1105       return qlfLoadError(state);
1106   }
1107 }
1108 
1109 
1110 static void
loadPredicateFlags(wic_state * state,Definition def,int skip)1111 loadPredicateFlags(wic_state *state, Definition def, int skip)
1112 { unsigned int flags = getUInt(state->wicFd);
1113 
1114   if ( !skip )
1115   { unsigned long lflags = 0L;
1116 
1117     if ( flags & PRED_SYSTEM )
1118       lflags |= P_LOCKED;
1119     if ( flags & PRED_HIDE_CHILDS )
1120       lflags |= HIDE_CHILDS;
1121 
1122     set(def, lflags);
1123   }
1124 }
1125 
1126 #ifdef O_GMP
1127 
1128 static int
mp_cpsign(ssize_t hdrsize,int mpsize)1129 mp_cpsign(ssize_t hdrsize, int mpsize)
1130 { return hdrsize >= 0 ? mpsize : -mpsize;
1131 }
1132 
1133 static void
mpz_hdr_size(ssize_t hdrsize,mpz_t mpz,size_t * wszp)1134 mpz_hdr_size(ssize_t hdrsize, mpz_t mpz, size_t *wszp)
1135 { size_t size     = hdrsize >= 0 ? hdrsize : -hdrsize;
1136   size_t limpsize = (size+sizeof(mp_limb_t)-1)/sizeof(mp_limb_t);
1137   size_t wsize    = (limpsize*sizeof(mp_limb_t)+sizeof(word)-1)/sizeof(word);
1138 
1139   mpz->_mp_size  = limpsize;
1140   mpz->_mp_alloc = limpsize;
1141 
1142   *wszp = wsize;
1143 }
1144 
1145 
1146 static void
mpz_load_bits(IOSTREAM * fd,Word p,mpz_t mpz,size_t bytes)1147 mpz_load_bits(IOSTREAM *fd, Word p, mpz_t mpz, size_t bytes)
1148 { char fast[1024];
1149   char *cbuf;
1150   size_t i;
1151 
1152   if ( bytes < sizeof(fast) )
1153     cbuf = fast;
1154   else
1155     cbuf = PL_malloc(bytes);
1156 
1157   for(i=0; i<bytes; i++)
1158     cbuf[i] = Qgetc(fd);
1159 
1160   mpz->_mp_d = (mp_limb_t*)p;
1161   mpz_import(mpz, bytes, 1, 1, 1, 0, cbuf);
1162   assert((Word)mpz->_mp_d == p);	/* check no (re-)allocation is done */
1163   if ( cbuf != fast )
1164     PL_free(cbuf);
1165 }
1166 
1167 
1168 #endif
1169 
1170 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1171 Label handling
1172 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1173 
1174 typedef struct vm_rlabel
1175 { size_t        offset;			/* location of jump */
1176   size_t	soi;			/* start of instruction */
1177   unsigned int	id;			/* label id */
1178 } vm_rlabel;
1179 
1180 typedef struct vm_rlabel_state
1181 { size_t	soi;			/* offset for start of instruction */
1182   tmp_buffer	buf;			/* buffer labels */
1183 } vm_rlabel_state;
1184 
1185 static void
init_rlabels(vm_rlabel_state * state)1186 init_rlabels(vm_rlabel_state *state)
1187 { initBuffer(&state->buf);
1188 }
1189 
1190 static void
exit_rlabels(vm_rlabel_state * state)1191 exit_rlabels(vm_rlabel_state *state)
1192 { discardBuffer(&state->buf);
1193 }
1194 
1195 static void
push_rlabel(vm_rlabel_state * state,unsigned int id,size_t offset)1196 push_rlabel(vm_rlabel_state *state, unsigned int id, size_t offset)
1197 { vm_rlabel *top    = allocFromBuffer(&state->buf, sizeof(*top));
1198   vm_rlabel *bottom = baseBuffer(&state->buf, vm_rlabel);
1199   vm_rlabel *prev   = top;
1200 
1201   while(prev > bottom && id > prev[-1].id)
1202     prev--;
1203   memmove(prev+1, prev, (char*)top - (char*)prev);
1204   prev->id     = id;
1205   prev->soi    = state->soi;
1206   prev->offset = offset;
1207 }
1208 
1209 static void
resolve_rlabel(vm_rlabel_state * state,unsigned int id,Code base,Clause clause)1210 resolve_rlabel(vm_rlabel_state *state, unsigned int id, Code base, Clause clause)
1211 { vm_rlabel *top    = topBuffer(&state->buf, vm_rlabel);
1212   vm_rlabel *bottom = baseBuffer(&state->buf, vm_rlabel);
1213   size_t copy = 0;
1214 
1215   DEBUG(MSG_QLF_LABEL,
1216 	Sdprintf("%s: V_LABEL %d\n", predicateName(clause->predicate), id));
1217 
1218   for(--top; top >= bottom; top--)
1219   { if ( top->id < id )
1220     { copy++;
1221       continue;
1222     }
1223 
1224     if ( top->id == id )
1225     { Code pc = &base[top->soi];
1226       size_t jmp;
1227 
1228       pc = stepPC(pc);				/* end of instruction */
1229       assert(base[top->offset] == (code)id);
1230       jmp = &base[state->soi] - pc;
1231       base[top->offset] = jmp;
1232       DEBUG(MSG_QLF_LABEL,
1233 	    Sdprintf("  Put %d at %zd\n", (int)jmp, top->offset));
1234       continue;
1235     }
1236 
1237     if ( top->id > id )
1238     { top++;
1239 
1240       if ( copy	)
1241       { vm_rlabel *cptop  = topBuffer(&state->buf, vm_rlabel);
1242 	size_t     cpsize = copy*sizeof(*cptop);
1243 
1244 	memmove(top, cptop - copy, cpsize);
1245 	state->buf.top = (char*)(top+copy);
1246       } else
1247       { state->buf.top = (char*)top;
1248       }
1249 
1250       break;
1251     }
1252   }
1253 }
1254 
1255 
1256 static bool
loadPredicate(wic_state * state,int skip ARG_LD)1257 loadPredicate(wic_state *state, int skip ARG_LD)
1258 { IOSTREAM *fd = state->wicFd;
1259   Procedure proc;
1260   Definition def;
1261   Clause clause;
1262   functor_t f = (functor_t) loadXR(state);
1263   SourceFile csf = NULL;
1264 
1265   proc = lookupProcedureToDefine(f, LD->modules.source);
1266   DEBUG(MSG_QLF_PREDICATE, Sdprintf("Loading %s%s",
1267 				    procedureName(proc),
1268 				    skip ? " (skip)" : ""));
1269 
1270   def = proc->definition;
1271   if ( !skip && state->currentSource )
1272   { if ( def->impl.any.defined )
1273     { if ( !redefineProcedure(proc, state->currentSource, DISCONTIGUOUS_STYLE) )
1274       { int rc = printMessage(ATOM_error, exception_term);
1275 	(void)rc;
1276 	PL_clear_exception();
1277 	skip = TRUE;
1278       }
1279     }
1280     addProcedureSourceFile(state->currentSource, proc);
1281   }
1282   loadPredicateFlags(state, def, skip);
1283 
1284   for(;;)
1285   { switch(Qgetc(fd) )
1286     { case 'X':
1287       { DEBUG(MSG_QLF_PREDICATE, Sdprintf("ok\n"));
1288 	succeed;
1289       }
1290       case 'C':
1291       { int has_dicts = 0;
1292 	tmp_buffer buf;
1293 	vm_rlabel_state lstate;
1294 
1295 	DEBUG(MSG_QLF_PREDICATE, Sdprintf("."));
1296 	initBuffer(&buf);
1297 	init_rlabels(&lstate);
1298 	clause = (Clause)allocFromBuffer(&buf, sizeofClause(0));
1299 	clause->references = 0;
1300 	clause->line_no    = getUInt(fd);
1301 
1302 	{ SourceFile of = (void *) loadXR(state);
1303 	  SourceFile sf = (void *) loadXR(state);
1304 	  unsigned int ono = (of ? of->index : 0);
1305 	  unsigned int sno = (sf ? sf->index : 0);
1306 	  if ( sf )
1307 	  { acquireSourceFile(sf);
1308 	    if ( of != sf )
1309 	      acquireSourceFile(of);
1310 	  }
1311 	  clause->owner_no = ono;
1312 	  clause->source_no = sno;
1313 	  if ( of && of != csf )
1314 	  { addProcedureSourceFile(sf, proc);
1315 	    csf = of;
1316 	  }
1317 	}
1318 
1319 	clearFlags(clause);
1320 	clause->prolog_vars = (unsigned short) getUInt(fd);
1321 	clause->variables   = (unsigned short) getUInt(fd);
1322 	if ( getUInt(fd) == 0 )		/* 0: fact */
1323 	  set(clause, UNIT_CLAUSE);
1324 	clause->predicate = def;
1325 
1326 #define addCode(c) addBuffer(&buf, (c), code)
1327 
1328 	for(;;)
1329 	{ code op = getUInt(fd);
1330 	  const char *ats;
1331 	  int n = 0;
1332 
1333 	  lstate.soi = entriesBuffer(&buf, code);
1334 	  switch(op)
1335 	  { case V_LABEL:
1336 	    { unsigned lbl = getUInt(fd);
1337 	      resolve_rlabel(&lstate, lbl, baseBuffer(&buf, code),
1338 			     baseBuffer(&buf, struct clause));
1339 	      continue;
1340 	    }
1341 	    case V_H_INTEGER:
1342 	    case V_B_INTEGER:
1343 	    { int64_t val = getInt64(fd);
1344 	      word w = consInt(val);
1345 
1346 	      if ( valInt(w) == val )
1347 	      { addCode(encode(op==V_H_INTEGER ? H_SMALLINT : B_SMALLINT));
1348 		addCode(w);
1349 #if SIZEOF_VOIDP == 8
1350 	      } else
1351 	      { addCode(encode(op==V_H_INTEGER ? H_INTEGER : B_INTEGER));
1352 		addCode((intptr_t)val);
1353 	      }
1354 #else
1355 	      } else if ( val >= INTPTR_MIN && val <= INTPTR_MAX )
1356 	      { addCode(encode(op==V_H_INTEGER ? H_INTEGER : B_INTEGER));
1357 		addCode((intptr_t)val);
1358 	      } else
1359 	      { addCode(encode(op==V_H_INTEGER ? H_INT64 : B_INT64));
1360 		addMultipleBuffer(&buf, (char*)&val, sizeof(int64_t), char);
1361 	      }
1362 #endif
1363 
1364 	      continue;
1365 	    }
1366 	    case V_A_INTEGER:
1367 	    { int64_t val = getInt64(fd);
1368 
1369 #if SIZEOF_VOIDP == 8
1370 	      addCode(encode(A_INTEGER));
1371 	      addCode((intptr_t)val);
1372 #else
1373 	      if ( val >= INTPTR_MIN && val <= INTPTR_MAX )
1374 	      { addCode(encode(A_INTEGER));
1375 		addCode((intptr_t)val);
1376 	      } else
1377 	      { addCode(encode(A_INT64));
1378 		addMultipleBuffer(&buf, (char*)&val, sizeof(int64_t), char);
1379 	      }
1380 #endif
1381 	      continue;
1382 	    }
1383 	  }
1384 
1385 	  if ( op >= I_HIGHEST )
1386 	    fatalError("Illegal op-code (%d) at %ld", op, Stell(fd));
1387 
1388 	  ats = codeTable[op].argtype;
1389 	  DEBUG(MSG_QLF_VMI,
1390 		Sdprintf("\t%s from %ld\n", codeTable[op].name, Stell(fd)));
1391 	  if ( op == I_CONTEXT )
1392 	  { clause = baseBuffer(&buf, struct clause);
1393 	    set(clause, CL_BODY_CONTEXT);
1394 	    set(def, P_MFCONTEXT);
1395 	  }
1396 	  addCode(encode(op));
1397 	  DEBUG(0,
1398 		{ const char ca1_float[2] = {CA1_FLOAT};
1399 		  const char ca1_int64[2] = {CA1_INT64};
1400 		  assert(codeTable[op].arguments == VM_DYNARGC ||
1401 			 (size_t)codeTable[op].arguments == strlen(ats) ||
1402 			 (streq(ats, ca1_float) &&
1403 			  codeTable[op].arguments == WORDS_PER_DOUBLE) ||
1404 			 (streq(ats, ca1_int64) &&
1405 			  codeTable[op].arguments == WORDS_PER_INT64));
1406 		});
1407 
1408 	  for(n=0; ats[n]; n++)
1409 	  { switch(ats[n])
1410 	    { case CA1_PROC:
1411 	      { addCode(loadXR(state));
1412 		break;
1413 	      }
1414 	      case CA1_FUNC:
1415 	      { word w = loadXR(state);
1416 		FunctorDef fd = valueFunctor(w);
1417 		if ( fd->name == ATOM_dict )
1418 		  has_dicts++;
1419 
1420 		addCode(w);
1421 		break;
1422 	      }
1423 	      case CA1_DATA:
1424 	      { word w = loadXR(state);
1425 		if ( isAtom(w) )
1426 		  PL_register_atom(w);
1427 		addCode(w);
1428 		break;
1429 	      }
1430 	      case CA1_AFUNC:
1431 	      { word f = loadXR(state);
1432 		int  i = indexArithFunction(f);
1433 		assert(i>0);
1434 		addCode(i);
1435 		break;
1436 	      }
1437 	      case CA1_MODULE:
1438 		addCode(loadXR(state));
1439 		break;
1440 	      case CA1_JUMP:
1441 	      { unsigned lbl = getUInt(fd);
1442 		size_t off = entriesBuffer(&buf, code);
1443 		addCode(lbl);
1444 		push_rlabel(&lstate, lbl, off);
1445 		break;
1446 	      }
1447 	      case CA1_INTEGER:
1448 		addCode((code)getInt64(fd));
1449 		break;
1450 	      case CA1_VAR:
1451 	      case CA1_FVAR:
1452 	      case CA1_CHP:
1453 		addCode((code)OFFSET_VAR(getInt64(fd)));
1454 		break;
1455 	      case CA1_INT64:
1456 	      { int64_t val = getInt64(fd);
1457 
1458 		addMultipleBuffer(&buf, (char*)&val, sizeof(int64_t), char);
1459 		break;
1460 	      }
1461 	      case CA1_FLOAT:
1462 	      { double f = getFloat(fd);
1463 
1464 		addMultipleBuffer(&buf, (char*)&f, sizeof(double), char);
1465 		break;
1466 	      }
1467 	      case CA1_STRING:		/* <n> chars */
1468 	      { size_t l = getInt(fd);
1469 		int   c0 = Qgetc(fd);
1470 
1471 		if ( c0 == 'B' )
1472 		{ int lw = (l+sizeof(word))/sizeof(word);
1473 		  int pad = (lw*sizeof(word) - l);
1474 		  Code bp;
1475 		  char *s;
1476 
1477 		  DEBUG(MSG_QLF_VMI, Sdprintf("String of %ld bytes\n", l));
1478 		  bp = allocFromBuffer(&buf, sizeof(word)*(lw+1));
1479 		  s = (char *)&bp[1];
1480 		  *bp = mkStrHdr(lw, pad);
1481 		  bp += lw;
1482 		  *bp++ = 0L;
1483 		  *s++ = 'B';
1484 		  l--;
1485 		  while(l-- > 0)
1486 		    *s++ = Qgetc(fd);
1487 		} else
1488 		{ size_t i;
1489 		  size_t  bs = (l+1)*sizeof(pl_wchar_t);
1490 		  size_t  lw = (bs+sizeof(word))/sizeof(word);
1491 		  int    pad = (lw*sizeof(word) - bs);
1492 		  word	   m = mkStrHdr(lw, pad);
1493 		  IOENC oenc = fd->encoding;
1494 
1495 		  DEBUG(MSG_QLF_VMI,
1496 			Sdprintf("Wide string of %zd chars; lw=%zd; pad=%d\n",
1497 				 l, lw, pad));
1498 
1499 		  assert(c0 == 'W');
1500 
1501 		  addCode(m);		/* The header */
1502 		  addBuffer(&buf, 'W', char);
1503 		  for(i=1; i<sizeof(pl_wchar_t); i++)
1504 		    addBuffer(&buf, 0, char);
1505 
1506 		  fd->encoding = ENC_UTF8;
1507 		  for(i=0; i<l; i++)
1508 		  { int code = Sgetcode(fd);
1509 		    pl_wchar_t c = code;
1510 
1511 		    if ( (int)c != code )
1512 		    { state->errors.invalid_wide_chars++;
1513 		      c = UTF8_MALFORMED_REPLACEMENT;
1514 		    }
1515 
1516 		    addBuffer(&buf, c, pl_wchar_t);
1517 		  }
1518 		  fd->encoding = oenc;
1519 
1520 		  for(i=0; i<pad; i++)
1521 		    addBuffer(&buf, 0, char);
1522 		}
1523 		break;
1524 	      }
1525 	      case CA1_MPZ:
1526 #ifdef O_GMP
1527 #define ABS(x) ((x) >= 0 ? (x) : -(x))
1528 	      DEBUG(MSG_QLF_VMI, Sdprintf("Loading MPZ from %ld\n", Stell(fd)));
1529 	      { ssize_t hdrsize = getInt64(fd);
1530 		size_t wsize;
1531 		mpz_t mpz;
1532 		word m;
1533 		Word p;
1534 
1535 		mpz_hdr_size(hdrsize, mpz, &wsize);
1536 		m = mkIndHdr(wsize+1, TAG_INTEGER);
1537 		p = allocFromBuffer(&buf, sizeof(word)*(wsize+2));
1538 
1539 		*p++ = m;
1540 		p[wsize] = 0;
1541 		*p++ = mpz_size_stack(mp_cpsign(hdrsize, mpz->_mp_size));
1542 		p[wsize] = 0;
1543 		mpz_load_bits(fd, p, mpz, ABS(hdrsize));
1544 
1545 		DEBUG(MSG_QLF_VMI, Sdprintf("Loaded MPZ to %ld\n", Stell(fd)));
1546 		break;
1547 	      }
1548 	      case CA1_MPQ:
1549 	      DEBUG(MSG_QLF_VMI, Sdprintf("Loading MPQ from %ld\n", Stell(fd)));
1550 	      { ssize_t num_hdrsize = getInt64(fd);
1551 		ssize_t den_hdrsize = getInt64(fd);
1552 		size_t wsize, num_wsize, den_wsize;
1553 		mpz_t num;
1554 		mpz_t den;
1555 		word m;
1556 		Word p;
1557 
1558 		mpz_hdr_size(num_hdrsize, num, &num_wsize);
1559 		mpz_hdr_size(den_hdrsize, den, &den_wsize);
1560 		wsize = num_wsize + den_wsize;
1561 		m     = mkIndHdr(wsize+2, TAG_INTEGER);
1562 		p     = allocFromBuffer(&buf, sizeof(word)*(wsize+3));
1563 
1564 		*p++ = m;
1565 		*p++ = mpq_size_stack(mp_cpsign(num_hdrsize, num->_mp_size));
1566 		*p++ = mpq_size_stack(mp_cpsign(den_hdrsize, den->_mp_size));
1567 		p[num_wsize] = 0;
1568 		mpz_load_bits(fd, p, num, ABS(num_hdrsize));
1569 		p += num_wsize;
1570 		p[den_wsize] = 0;
1571 		mpz_load_bits(fd, p, den, ABS(den_hdrsize));
1572 
1573 		DEBUG(MSG_QLF_VMI, Sdprintf("Loaded MPQ to %ld\n", Stell(fd)));
1574 		break;
1575 	      }
1576 #else
1577 		fatalError("No support for MPZ numbers");
1578 #endif
1579 	      default:
1580 		fatalError("No support for VM argtype %d (arg %d of %s)",
1581 			   ats[n], n, codeTable[op].name);
1582 	    }
1583 	  }
1584 	  switch(op)
1585 	  { case I_EXITFACT:
1586 	    case I_EXIT:			/* fact */
1587 	      goto done;
1588 	  }
1589 	}
1590 
1591       done:
1592 	exit_rlabels(&lstate);
1593 
1594 	if ( !skip )
1595 	{ size_t csize  = sizeOfBuffer(&buf);
1596 	  size_t ncodes = (csize-sizeofClause(0))/sizeof(code);
1597 	  Clause bcl    = baseBuffer(&buf, struct clause);
1598 
1599 	  bcl->code_size = ncodes;
1600 	  clause = (Clause)PL_malloc_atomic(csize);
1601 	  memcpy(clause, bcl, csize);
1602 
1603 	  if ( has_dicts )
1604 	  { if ( !resortDictsInClause(clause) )
1605 	    { outOfCore();
1606 	      exit(1);
1607 	    }
1608 	  }
1609 	  if ( csf )
1610 	    csf->current_procedure = proc;
1611 
1612 	  GD->statistics.codes += clause->code_size;
1613 	  assertProcedureSource(csf, proc, clause PASS_LD);
1614 	}
1615 
1616         discardBuffer(&buf);
1617       }
1618     }
1619   }
1620 }
1621 
1622 
1623 static bool
runInitialization(SourceFile sf)1624 runInitialization(SourceFile sf)
1625 { int rc = FALSE;
1626 
1627   if ( sf )
1628   { GET_LD
1629     fid_t fid = PL_open_foreign_frame();
1630     term_t av = PL_new_term_refs(2);
1631     static predicate_t pred = NULL;
1632 
1633     if ( !pred )
1634       pred = PL_predicate("$run_initialization", 2, "system");
1635 
1636     PL_put_atom(av+0, sf->name);
1637     PL_put_nil( av+1);
1638     rc = PL_call_predicate(MODULE_system, PL_Q_NORMAL, pred, av);
1639 
1640     PL_discard_foreign_frame(fid);
1641   }
1642 
1643   return rc;
1644 }
1645 
1646 
1647 static bool
loadImport(wic_state * state,int skip ARG_LD)1648 loadImport(wic_state *state, int skip ARG_LD)
1649 { Procedure proc = (Procedure) loadXR(state);
1650   int flags = getInt(state->wicFd);
1651 
1652   if ( !skip )
1653     return importDefinitionModule(LD->modules.source, proc->definition, flags);
1654 
1655   succeed;
1656 }
1657 
1658 
1659 static atom_t
qlfFixSourcePath(wic_state * state,const char * raw)1660 qlfFixSourcePath(wic_state *state, const char *raw)
1661 { char buf[MAXPATHLEN];
1662   char *canonical;
1663 
1664   if ( state->load_state->has_moved &&
1665        strprefix(raw, state->load_state->save_dir) )
1666   { char *s;
1667     size_t lensave = strlen(state->load_state->save_dir);
1668     const char *tail = &raw[lensave];
1669 
1670     if ( strlen(state->load_state->load_dir)+1+strlen(tail)+1 > MAXPATHLEN )
1671       fatalError("Path name too long: %s", raw);
1672 
1673     strcpy(buf, state->load_state->load_dir);
1674     s = &buf[strlen(buf)];
1675     strcpy(s, tail);
1676   } else
1677   { if ( strlen(raw)+1 > MAXPATHLEN )
1678     { fatalError("Path name too long: %s", raw);
1679       return NULL_ATOM;
1680     }
1681     strcpy(buf, raw);
1682   }
1683 
1684   if ( (canonical=canonicalisePath(buf)) )
1685   { atom_t translated = file_name_to_atom(canonical);
1686 
1687     if ( strcmp(raw, canonical) )
1688     { path_translated *tr = PL_malloc(sizeof(*tr));
1689 
1690       tr->from = file_name_to_atom(raw);
1691       tr->to   = translated;
1692       tr->next = state->load_state->translated;
1693       state->load_state->translated = tr;
1694     }
1695 
1696     return translated;
1697   } else
1698   { fatalError("Path name too long: %s", buf);
1699     return NULL_ATOM;
1700   }
1701 }
1702 
1703 
1704 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1705 (**) Note. When loading a qlf  file   we  must do the possible reconsult
1706 stuff associated with loading sourcefiles. If we are loading a state all
1707 is nice and fresh, so we can skip that. Actually, we *must* skip that as
1708 a state is  created  based  on   modules  rather  than  files. Multifile
1709 predicates are stored with the module. If   we  take no measures loading
1710 the file from which a clause originates  will remove the one loaded with
1711 the module where it is a multifile one.
1712 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1713 
1714 static bool
qlfLoadSource(wic_state * state)1715 qlfLoadSource(wic_state *state)
1716 { IOSTREAM *fd = state->wicFd;
1717   char *str = getString(fd, NULL);
1718   double time = getFloat(fd);
1719   int issys = (Qgetc(fd) == 's') ? TRUE : FALSE;
1720   atom_t fname;
1721 
1722   if ( !str )
1723   { fatalError("Invalid QLF: illegal string");
1724     return FALSE;
1725   }
1726   fname = qlfFixSourcePath(state, str);
1727 
1728   DEBUG(MSG_QLF_PATH,
1729 	if ( !streq(stringAtom(fname), str) )
1730 	  Sdprintf("Replaced path %s --> %s\n", str, stringAtom(fname)));
1731 
1732   state->currentSource = lookupSourceFile(fname, TRUE);
1733   PL_unregister_atom(fname);		/* locked with sourceFile */
1734   state->currentSource->mtime = time;
1735   state->currentSource->system = issys;
1736   if ( GD->bootsession )		/* (**) */
1737     state->currentSource->count++;
1738   else
1739     startConsult(state->currentSource);
1740 
1741   succeed;
1742 }
1743 
1744 
1745 static bool
loadModuleProperties(wic_state * state,Module m,int skip ARG_LD)1746 loadModuleProperties(wic_state *state, Module m, int skip ARG_LD)
1747 { IOSTREAM *fd = state->wicFd;
1748 
1749   if ( !skip )
1750     clearSupersModule(m);
1751 
1752   for(;;)
1753   { switch(Qgetc(fd))
1754     { case 'C':
1755       { atom_t cname = loadXR(state);
1756 
1757 	if ( !skip )
1758 	  m->class = cname;
1759 
1760 	continue;
1761       }
1762       case 'S':
1763       { atom_t sname = loadXR(state);
1764 	Module s = lookupModule(sname);
1765 
1766 	if ( !skip )
1767 	  addSuperModule(m, s, 'Z');
1768 
1769 	continue;
1770       }
1771       case 'E':
1772       { functor_t f = (functor_t) loadXR(state);
1773 
1774 	if ( !skip )
1775 	{ Procedure proc = lookupProcedure(f, LD->modules.source);
1776 
1777 	  addNewHTable(LD->modules.source->public, (void *)f, proc);
1778           if ( state->currentSource )
1779             exportProcedureSource(state->currentSource, m, proc);
1780 	} else
1781 	{ if ( !lookupHTable(m->public, (void *)f) )
1782 	  { FunctorDef fd = valueFunctor(f);
1783 
1784 	    warning("%s: skipped module \"%s\" lacks %s/%d",
1785 		    state->wicFile,
1786 		    stringAtom(m->name),
1787 		    stringAtom(fd->name),
1788 		    fd->arity);
1789 	  }
1790 	}
1791 
1792 	continue;
1793       }
1794       case 'X':
1795 	break;
1796       default:
1797 	return qlfLoadError(state);
1798     }
1799     break;
1800   }
1801 
1802   succeed;
1803 }
1804 
1805 
1806 static bool
loadPart(wic_state * state,Module * module,int skip ARG_LD)1807 loadPart(wic_state *state, Module *module, int skip ARG_LD)
1808 { IOSTREAM *fd		= state->wicFd;
1809   Module om		= LD->modules.source;
1810   SourceFile of		= state->currentSource;
1811   int stchk		= debugstatus.styleCheck;
1812   access_level_t alevel = LD->prolog_flag.access_level;
1813 
1814   switch(Qgetc(fd))
1815   { case 'M':
1816     { atom_t mname = loadXR(state);
1817       int c = Qgetc(fd);
1818 
1819       DEBUG(MSG_QLF_SECTION,
1820 	    Sdprintf("Loading module %s\n", PL_atom_chars(mname)));
1821 
1822       switch( c )
1823       { case '-':
1824 	{ LD->modules.source = lookupModule(mname);
1825 					/* TBD: clear module? */
1826 	  DEBUG(MSG_QLF_SECTION, Sdprintf("\tNo source\n"));
1827 	  break;
1828 	}
1829 	case 'F':
1830 	{ Module m;
1831 	  int line;
1832 
1833 	  qlfLoadSource(state);
1834 	  line = getInt(fd);
1835 	  DEBUG(MSG_QLF_SECTION,
1836 		Sdprintf("\tSource = %s:%d\n",
1837 			 PL_atom_chars(state->currentSource->name), line));
1838 
1839 	  m = lookupModule(mname);
1840 	  if ( m->file && m->file != state->currentSource )
1841 	  { warning("%s:\n\tmodule \"%s\" already loaded from \"%s\" (skipped)",
1842 		    state->wicFile, stringAtom(m->name), stringAtom(m->file->name));
1843 	    skip = TRUE;
1844 	    LD->modules.source = m;
1845 	  } else
1846 	  { if ( !declareModule(mname, NULL_ATOM, NULL_ATOM,
1847 				state->currentSource, line, FALSE) )
1848 	      fail;
1849 	  }
1850 
1851 	  if ( module )
1852 	    *module = LD->modules.source;
1853 
1854 	  break;
1855 	}
1856 	default:
1857 	  qlfLoadError(state);
1858 	  break;
1859       }
1860 
1861       if ( !loadModuleProperties(state, LD->modules.source, skip PASS_LD) )
1862 	fail;
1863 
1864       break;
1865     }
1866     case 'F':
1867     { qlfLoadSource(state);
1868 
1869       if ( module )
1870 	*module = NULL;
1871 
1872       break;
1873     }
1874     default:
1875       return qlfLoadError(state);
1876   }
1877 
1878   for(;;)
1879   { int c = Qgetc(fd);
1880 
1881     switch(c)
1882     { case 'X':
1883       { if ( !GD->bootsession  )
1884 	{ runInitialization(state->currentSource);
1885 	  if ( state->currentSource )
1886 	    endConsult(state->currentSource);
1887         }
1888 	LD->modules.source = om;
1889 	state->currentSource  = of;
1890 	debugstatus.styleCheck = stchk;
1891 	setAccessLevel(alevel);
1892 
1893 	succeed;
1894       }
1895       default:
1896 	loadStatement(state, c, skip PASS_LD);
1897     }
1898   }
1899 }
1900 
1901 
1902 static bool
loadInModule(wic_state * state,int skip ARG_LD)1903 loadInModule(wic_state *state, int skip ARG_LD)
1904 { IOSTREAM *fd = state->wicFd;
1905   word mname = loadXR(state);
1906   Module om = LD->modules.source;
1907 
1908   LD->modules.source = lookupModule(mname);
1909 
1910   for(;;)
1911   { int c = Qgetc(fd);
1912 
1913     switch(c)
1914     { case 'X':
1915       { LD->modules.source = om;
1916 	succeed;
1917       }
1918       default:
1919 	loadStatement(state, c, skip PASS_LD);
1920     }
1921   }
1922 }
1923 
1924 
1925 static bool
loadInclude(wic_state * state ARG_LD)1926 loadInclude(wic_state *state ARG_LD)
1927 { IOSTREAM *fd = state->wicFd;
1928   atom_t owner, pn, fn;
1929   int line;
1930   double time;
1931   fid_t fid = PL_open_foreign_frame();
1932   term_t t = PL_new_term_ref();
1933   sourceloc loc;
1934 
1935   owner = loadXR(state);
1936   pn    = loadXR(state);
1937   line  = getInt(fd);
1938   fn    = loadXR(state);
1939   time  = getFloat(fd);
1940 
1941   if ( !PL_unify_term(t,
1942 		      PL_FUNCTOR, FUNCTOR_colon2,
1943 			PL_ATOM, ATOM_system,
1944 			PL_FUNCTOR_CHARS, "$included", 4,
1945 			  PL_ATOM, pn,
1946 			  PL_INT, line,
1947 			  PL_ATOM, fn,
1948 			  PL_FLOAT, time) )
1949     return FALSE;
1950 
1951   loc.file = pn;
1952   loc.line = line;
1953 
1954   assert_term(t, NULL, CL_END, owner, &loc, 0 PASS_LD);
1955 
1956   PL_discard_foreign_frame(fid);
1957   return TRUE;
1958 }
1959 
1960 
1961 		 /*******************************
1962 		 *	WRITING .QLF FILES	*
1963 		 *******************************/
1964 
1965 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1966 The code below handles the creation of `wic' files.  It offers a  number
1967 of  predicates  which  enables  us  to write the compilation toplevel in
1968 Prolog.
1969 
1970 Note that we keep track of the `current procedure' to keep  all  clauses
1971 of a predicate together.
1972 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1973 
1974 #define STR_NOLEN ((size_t)-1)
1975 
1976 static void
putString(const char * s,size_t len,IOSTREAM * fd)1977 putString(const char *s, size_t len, IOSTREAM *fd)
1978 { const char *e;
1979 
1980   if ( len == STR_NOLEN )
1981     len = strlen(s);
1982   e = &s[len];
1983 
1984   putInt64(len, fd);
1985   while(s<e)
1986   { Sputc(*s, fd);
1987     s++;
1988   }
1989 }
1990 
1991 
1992 static void
putStringW(const pl_wchar_t * s,size_t len,IOSTREAM * fd)1993 putStringW(const pl_wchar_t *s, size_t len, IOSTREAM *fd)
1994 { const pl_wchar_t *e;
1995   IOENC oenc = fd->encoding;
1996 
1997   if ( len == STR_NOLEN )
1998     len = wcslen(s);
1999   e = &s[len];
2000 
2001   putInt64(len, fd);
2002   fd->encoding = ENC_UTF8;
2003   while(s<e)
2004   { Sputcode(*s, fd);
2005     s++;
2006   }
2007   fd->encoding = oenc;
2008 }
2009 
2010 
2011 static void
putAtom(wic_state * state,atom_t w)2012 putAtom(wic_state *state, atom_t w)
2013 { GET_LD
2014   IOSTREAM *fd = state->wicFd;
2015   atom_t mapped;
2016   Atom a;
2017   static PL_blob_t *text_blob;
2018 
2019   if ( state->idMap &&
2020        (mapped = (atom_t)lookupHTable(state->idMap, (void*)w)) )
2021   { assert(isAtom(mapped));
2022     w = mapped;
2023   }
2024 
2025   if ( !text_blob )
2026     text_blob = PL_find_blob_type("text");
2027 
2028   a = atomValue(w);
2029   if ( a->type != text_blob )
2030   { Sputc(XR_BLOB, fd);
2031     saveXRBlobType(state, a->type);
2032     if ( a->type->save )
2033     { (*a->type->save)(a->atom, fd);
2034     } else
2035     { putString(a->name, a->length, fd);
2036     }
2037   } else
2038   { Sputc(XR_ATOM, fd);
2039     putString(a->name, a->length, fd);
2040   }
2041 }
2042 
2043 
2044 static void
putInt64(int64_t n,IOSTREAM * fd)2045 putInt64(int64_t n, IOSTREAM *fd)
2046 { uint64_t i = zigzag_encode(n);
2047 
2048   do
2049   { int b = i&0x7f;
2050 
2051     i >>= 7;
2052     if ( !i )
2053       b |= 0x80;
2054     Sputc(b, fd);
2055   } while ( i );
2056 }
2057 
2058 
2059 static void
putUInt(unsigned int i,IOSTREAM * fd)2060 putUInt(unsigned int i, IOSTREAM *fd)
2061 { do
2062   { int b = i&0x7f;
2063 
2064     i >>= 7;
2065     if ( !i )
2066       b |= 0x80;
2067     Sputc(b, fd);
2068   } while ( i );
2069 }
2070 
2071 static void
putFloat(double f,IOSTREAM * fd)2072 putFloat(double f, IOSTREAM *fd)
2073 { unsigned char *cl = (unsigned char *)&f;
2074   unsigned int i;
2075 
2076   DEBUG(MSG_QLF_FLOAT, Sdprintf("putFloat(%f)\n", f));
2077 
2078   for(i=0; i<BYTES_PER_DOUBLE; i++)
2079     Sputc(cl[double_byte_order[i]], fd);
2080 }
2081 
2082 
2083 static void
putInt32(int v,IOSTREAM * fd)2084 putInt32(int v, IOSTREAM *fd)
2085 { Sputc((v>>24)&0xff, fd);
2086   Sputc((v>>16)&0xff, fd);
2087   Sputc((v>>8)&0xff, fd);
2088   Sputc(v&0xff, fd);
2089 }
2090 
2091 
2092 static void
freeXRSymbol(void * name,void * value)2093 freeXRSymbol(void *name, void *value)
2094 { word w = (word)name;
2095 
2096   if ( w&0x1 )
2097   { w &= ~0x1;
2098     if ( isAtom(w) )
2099     { PL_unregister_atom(w);
2100       DEBUG(5, Sdprintf("UNREG: %s\n", stringAtom(w)));
2101     }
2102   }
2103 }
2104 
2105 
2106 void
initXR(wic_state * state)2107 initXR(wic_state *state)
2108 { state->currentPred		   = NULL;
2109   state->currentSource		   = NULL;
2110   state->savedXRTable		   = newHTable(256);
2111   state->savedXRTable->free_symbol = freeXRSymbol;
2112   state->savedXRTableId		   = 0;
2113 }
2114 
2115 
2116 void
destroyXR(wic_state * state)2117 destroyXR(wic_state *state)
2118 { destroyHTable(state->savedXRTable);
2119   state->savedXRTable = NULL;
2120   if ( state->idMap )
2121   { destroyHTable(state->idMap);
2122     state->idMap = NULL;
2123   }
2124 }
2125 
2126 
2127 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2128 XR (External Reference)  table  handling.   The  table  contains  atoms,
2129 functors  and  various  types  of    pointers   (Module,  Procedure  and
2130 SourceFile). For savedXR()  to  work,  atom_t   and  functor_t  may  not
2131 conflict with pointers. We assume -as in  many other places in the code-
2132 that pointers are 4-byte aligned.
2133 
2134 savedXRConstant()  must  be  used  for    atom_t  and  functor_t,  while
2135 savedXRPointer  must  be  used  for   the    pointers.   The  value  for
2136 savedXRConstant() is or-ed with 0x1 to avoid conflict with pointers.
2137 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2138 
2139 static int
savedXR(wic_state * state,void * xr)2140 savedXR(wic_state *state, void *xr)
2141 { GET_LD
2142   IOSTREAM *fd = state->wicFd;
2143   unsigned int id;
2144 
2145   if ( (id = (intptr_t)lookupHTable(state->savedXRTable, xr)) )
2146   { Sputc(XR_REF, fd);
2147     putUInt(id, fd);
2148 
2149     succeed;
2150   } else
2151   { id = ++state->savedXRTableId;
2152     addNewHTable(state->savedXRTable, xr, (void *)(intptr_t)id);
2153   }
2154 
2155   fail;
2156 }
2157 
2158 
2159 static inline int
savedXRConstant(wic_state * state,word w)2160 savedXRConstant(wic_state *state, word w)
2161 { int rc;
2162 
2163   assert(tag(w) == TAG_ATOM);		/* Only functor_t and atom_t */
2164 
2165   if ( !(rc=savedXR(state, (void *)(w|0x1))) && isAtom(w) )
2166   { DEBUG(MSG_QLF_XR, Sdprintf("REG: %s\n", stringAtom(w)));
2167     PL_register_atom(w);
2168   }
2169 
2170   return rc;
2171 }
2172 
2173 
2174 static int XRNullPointer = 0;
2175 
2176 static inline int
savedXRPointer(wic_state * state,void * p)2177 savedXRPointer(wic_state *state, void *p)
2178 { assert(((word)p & 0x1) == 0);
2179 
2180   if ( !p )
2181   { return savedXR(state, &XRNullPointer);
2182   }
2183 
2184   return savedXR(state, p);
2185 }
2186 
2187 
2188 static void
saveXR__LD(wic_state * state,word xr ARG_LD)2189 saveXR__LD(wic_state *state, word xr ARG_LD)
2190 { IOSTREAM *fd = state->wicFd;
2191 
2192   if ( isTaggedInt(xr) )		/* TBD: switch */
2193   { Sputc(XR_INT, fd);
2194     putInt64(valInt(xr), fd);
2195     return;
2196   } else if ( isBignum(xr) )
2197   { Sputc(XR_INT, fd);
2198     putInt64(valBignum(xr), fd);
2199     return;
2200   } else if ( isFloat(xr) )
2201   { Sputc(XR_FLOAT, fd);
2202     putFloat(valFloat(xr), fd);
2203     return;
2204 #if O_STRING
2205   } else if ( isString(xr) )
2206   { char *s;
2207     pl_wchar_t *w;
2208     size_t len;
2209 
2210     if ( (s = getCharsString(xr, &len)) )
2211     { Sputc(XR_STRING, fd);
2212       putString(s, len, fd);
2213     } else if ( (w=getCharsWString(xr, &len)) )
2214     { Sputc(XR_STRING_UTF8, fd);
2215       putStringW(w, len, fd);
2216     }
2217     return;
2218 #endif /* O_STRING */
2219   }
2220 
2221   if ( xr == ATOM_nil )
2222   { Sputc(XR_NIL, fd);
2223     return;
2224   }
2225   if ( xr == ATOM_dot )
2226   { Sputc(XR_CONS, fd);
2227     return;
2228   }
2229 
2230 
2231   if ( savedXRConstant(state, xr) )
2232     return;
2233 
2234   if ( isAtom(xr) )
2235   { DEBUG(MSG_QLF_XR,
2236 	  Sdprintf("XR(%d) = '%s'\n", state->savedXRTableId, stringAtom(xr)));
2237     putAtom(state, xr);
2238     return;
2239   }
2240 
2241   assert(0);
2242 }
2243 #define saveXR(state, xr) saveXR__LD(state, xr PASS_LD)
2244 
2245 
2246 static void
saveXRBlobType(wic_state * state,PL_blob_t * type)2247 saveXRBlobType(wic_state *state, PL_blob_t *type)
2248 { IOSTREAM *fd = state->wicFd;
2249 
2250   if ( savedXRPointer(state, type) )
2251     return;
2252 
2253   Sputc(XR_BLOB_TYPE, fd);
2254   putString(type->name, STR_NOLEN, fd);
2255 }
2256 
2257 
2258 static void
saveXRModule(wic_state * state,Module m ARG_LD)2259 saveXRModule(wic_state *state, Module m ARG_LD)
2260 { IOSTREAM *fd = state->wicFd;
2261 
2262   if ( !m )
2263   { Sputc(XR_NULL, fd);
2264     return;
2265   }
2266 
2267   if ( savedXRPointer(state, m) )
2268     return;
2269 
2270   Sputc(XR_MODULE, fd);
2271   DEBUG(MSG_QLF_XR,
2272 	Sdprintf("XR(%d) = module %s\n",
2273 		 state->savedXRTableId, stringAtom(m->name)));
2274   saveXR(state, m->name);
2275 }
2276 
2277 
2278 static void
saveXRFunctor(wic_state * state,functor_t f ARG_LD)2279 saveXRFunctor(wic_state *state, functor_t f ARG_LD)
2280 { IOSTREAM *fd = state->wicFd;
2281   FunctorDef fdef;
2282   functor_t mapped;
2283 
2284   if ( savedXRConstant(state, f) )
2285     return;
2286 
2287   if ( state->idMap &&
2288        (mapped = (functor_t)lookupHTable(state->idMap, (void*)f)) )
2289     f = mapped;
2290 
2291   fdef = valueFunctor(f);
2292 
2293   DEBUG(MSG_QLF_XR,
2294 	Sdprintf("XR(%d) = %s/%d\n",
2295 		 state->savedXRTableId, stringAtom(fdef->name), fdef->arity));
2296   Sputc(XR_FUNCTOR, fd);
2297   saveXR(state, fdef->name);
2298   putInt64(fdef->arity, fd);
2299 }
2300 
2301 
2302 static void
saveXRProc(wic_state * state,Procedure p ARG_LD)2303 saveXRProc(wic_state *state, Procedure p ARG_LD)
2304 { IOSTREAM *fd = state->wicFd;
2305 
2306   if ( savedXRPointer(state, p) )
2307     return;
2308 
2309   DEBUG(MSG_QLF_XR, Sdprintf("XR(%d) = proc %s\n",
2310 			     state->savedXRTableId, procedureName(p)));
2311   Sputc(XR_PRED, fd);
2312   saveXRFunctor(state, p->definition->functor->functor PASS_LD);
2313   saveXRModule(state, p->definition->module PASS_LD);
2314 }
2315 
2316 
2317 static void
saveXRSourceFile(wic_state * state,SourceFile f ARG_LD)2318 saveXRSourceFile(wic_state *state, SourceFile f ARG_LD)
2319 { IOSTREAM *fd = state->wicFd;
2320 
2321   if ( savedXRPointer(state, f) )
2322     return;
2323 
2324   Sputc(XR_FILE, fd);
2325 
2326   if ( f )
2327   { DEBUG(MSG_QLF_XR, Sdprintf("XR(%d) = file %s\n",
2328 			       state->savedXRTableId, stringAtom(f->name)));
2329     Sputc(f->system ? 's' : 'u', fd);
2330     saveXR(state, f->name);
2331     putFloat(f->mtime, fd);
2332   } else
2333   { DEBUG(MSG_QLF_XR, Sdprintf("XR(%d) = <no file>\n", state->savedXRTableId));
2334     Sputc('-', fd);
2335   }
2336 }
2337 
2338 
2339 
2340 static void
do_save_qlf_term(wic_state * state,Word t ARG_LD)2341 do_save_qlf_term(wic_state *state, Word t ARG_LD)
2342 { IOSTREAM *fd = state->wicFd;
2343 
2344   deRef(t);
2345   if ( isTerm(*t) )
2346   { functor_t f = functorTerm(*t);
2347 
2348     if ( f == FUNCTOR_dvard1 )
2349     { int id = (int)valInt(argTerm(*t, 0));
2350 
2351       Sputc('v', fd);
2352       putInt64(id, fd);
2353     } else
2354     { Word q = argTermP(*t, 0);
2355       int n, arity = arityFunctor(f);
2356 
2357       Sputc('t', fd);
2358       saveXRFunctor(state, f PASS_LD);
2359       for(n=0; n < arity; n++, q++)
2360 	do_save_qlf_term(state, q PASS_LD);
2361     }
2362   } else
2363   { assert(isAtomic(*t));
2364     saveXR(state, *t);
2365   }
2366 }
2367 
2368 
2369 static int
saveQlfTerm(wic_state * state,term_t t ARG_LD)2370 saveQlfTerm(wic_state *state, term_t t ARG_LD)
2371 { IOSTREAM *fd = state->wicFd;
2372   intptr_t nvars, rc=TRUE;
2373   fid_t cid;
2374   nv_options options;
2375 
2376   cid = PL_open_foreign_frame();
2377 
2378   DEBUG(MSG_QLF_TERM,
2379 	Sdprintf("Saving ");
2380 	PL_write_term(Serror, t, 1200, 0);
2381 	Sdprintf(" from %d ... ", Stell(fd)));
2382 
2383   options.functor = FUNCTOR_dvard1;
2384   options.on_attvar = AV_SKIP;
2385   options.singletons = FALSE;		/* TBD: TRUE may be better! */
2386   options.numbered_check = TRUE;	/* otherwise may be wrong */
2387 
2388   if ( (nvars = numberVars(t, &options, 0 PASS_LD)) != NV_ERROR )
2389   { putInt64(nvars, fd);
2390     do_save_qlf_term(state, valTermRef(t) PASS_LD);	/* TBD */
2391     DEBUG(MSG_QLF_TERM, Sdprintf("to %d\n", Stell(fd)));
2392   } else
2393   { rc = FALSE;
2394   }
2395 
2396   PL_discard_foreign_frame(cid);
2397 
2398   return rc;
2399 }
2400 
2401 
2402 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2403 Label handling
2404 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2405 
2406 typedef struct vm_wlabel
2407 { Code		address;
2408   unsigned int	id;
2409 } vm_wlabel;
2410 
2411 typedef struct vm_wlabel_state
2412 { tmp_buffer	buf;
2413   vm_wlabel	current;
2414   unsigned int  next_id;
2415 } vm_wlabel_state;
2416 
2417 static void
init_wlabels(vm_wlabel_state * state)2418 init_wlabels(vm_wlabel_state *state)
2419 { initBuffer(&state->buf);
2420   state->current.address = NULL;
2421   state->next_id = 0;
2422 }
2423 
2424 static void
exit_wlabels(vm_wlabel_state * state)2425 exit_wlabels(vm_wlabel_state *state)
2426 { assert(entriesBuffer(&state->buf, vm_wlabel) == 0);
2427   discardBuffer(&state->buf);
2428 }
2429 
2430 static vm_wlabel *
push_wlabel(vm_wlabel_state * state,Code to,Clause clause)2431 push_wlabel(vm_wlabel_state *state, Code to, Clause clause)
2432 { vm_wlabel *lbl;
2433 
2434   if ( state->current.address )
2435   { if ( to == state->current.address )
2436     { lbl = &state->current;
2437     } else if ( to < state->current.address )
2438     { addBuffer(&state->buf, state->current, vm_wlabel);
2439       state->current.address = to;
2440       state->current.id = ++state->next_id;
2441       lbl = &state->current;
2442     } else
2443     { vm_wlabel *top    = allocFromBuffer(&state->buf, sizeof(*top));
2444       vm_wlabel *bottom = baseBuffer(&state->buf, vm_wlabel);
2445       vm_wlabel *prev   = top;
2446 
2447       while(prev > bottom && to > prev[-1].address)
2448 	prev--;
2449       if ( prev > bottom && prev[-1].address == to )
2450       { (void)popBuffer(&state->buf, vm_wlabel);
2451 	lbl = &prev[-1];
2452       } else
2453       { memmove(prev+1, prev, (char*)top - (char*)prev);
2454 	prev->address = to;
2455 	prev->id = ++state->next_id;
2456 	lbl = prev;
2457       }
2458     }
2459   } else
2460   { state->current.address = to;
2461     state->current.id = ++state->next_id;
2462     lbl = &state->current;
2463   }
2464 
2465   DEBUG(MSG_QLF_LABEL,
2466 	{ Sdprintf("%s, clause %d: current: %d at %p\n",
2467 		   predicateName(clause->predicate),
2468 		   clauseNo(clause, 0),
2469 		   state->current.id, state->current.address);
2470 	  vm_wlabel *top    = topBuffer(&state->buf, vm_wlabel);
2471 	  vm_wlabel *bottom = baseBuffer(&state->buf, vm_wlabel);
2472 	  for(--top; top >= bottom; top--)
2473 	    Sdprintf("    %d at %p\n", top->id, top->address);
2474 	});
2475 
2476   return lbl;
2477 }
2478 
2479 static void
emit_wlabels(vm_wlabel_state * state,Code here,IOSTREAM * fd)2480 emit_wlabels(vm_wlabel_state *state, Code here, IOSTREAM *fd)
2481 { while(state->current.address == here)
2482   { putUInt(V_LABEL, fd);
2483     putUInt(state->current.id, fd);
2484 
2485     if ( entriesBuffer(&state->buf, vm_wlabel) != 0 )
2486       state->current = popBuffer(&state->buf, vm_wlabel);
2487     else
2488       state->current.address = NULL;
2489   }
2490 }
2491 
2492 
2493 #ifdef O_GMP
2494 static void
put_mpz_size(IOSTREAM * fd,mpz_t mpz,size_t * szp)2495 put_mpz_size(IOSTREAM *fd, mpz_t mpz, size_t *szp)
2496 { size_t size = (mpz_sizeinbase(mpz, 2)+7)/8;
2497   ssize_t hdrsize;
2498 
2499   if ( mpz_sgn(mpz) < 0 )
2500     hdrsize = -(ssize_t)size;
2501   else
2502     hdrsize = (ssize_t)size;
2503 
2504   *szp = size;
2505   putInt64(hdrsize, fd);
2506 }
2507 
2508 static void
put_mpz_bits(IOSTREAM * fd,mpz_t mpz,size_t size)2509 put_mpz_bits(IOSTREAM *fd, mpz_t mpz, size_t size)
2510 { size_t i, count;
2511   char fast[1024];
2512   char *buf;
2513 
2514   if ( size < sizeof(fast) )
2515     buf = fast;
2516   else
2517     buf = PL_malloc(size);
2518 
2519   mpz_export(buf, &count, 1, 1, 1, 0, mpz);
2520   assert(count == size);
2521   for(i=0; i<count; i++)
2522     Sputc(buf[i]&0xff, fd);
2523   if ( buf != fast )
2524     PL_free(buf);
2525 }
2526 
2527 #endif
2528 
2529 
2530 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2531 saveWicClause()  saves  a  clause  to  the  .qlf  file.   For  predicate
2532 references of I_CALL and I_DEPART, we  cannot store the predicate itself
2533 as this would lead to an inconsistency if   the .qlf file is loaded into
2534 another context module.  Therefore we just   store the functor.  For now
2535 this is ok as constructs of the   form  module:goal are translated using
2536 the meta-call mechanism.  This needs consideration   if we optimise this
2537 (which is not that likely as I	think  module:goal, where `module' is an
2538 atom,  should  be  restricted  to  very    special  cases  and  toplevel
2539 interaction.
2540 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2541 
2542 static void
saveWicClause(wic_state * state,Clause clause)2543 saveWicClause(wic_state *state, Clause clause)
2544 { GET_LD
2545   IOSTREAM *fd = state->wicFd;
2546   Code bp, ep;
2547   vm_wlabel_state lstate;
2548 
2549   Sputc('C', fd);
2550   putUInt(state->obfuscate ? 0 : clause->line_no, fd);
2551   saveXRSourceFile(state,
2552 		   state->obfuscate ? NULL
2553 				    : indexToSourceFile(clause->owner_no)
2554 		   PASS_LD);
2555   saveXRSourceFile(state,
2556 		   state->obfuscate ? NULL
2557 				    : indexToSourceFile(clause->source_no)
2558 		   PASS_LD);
2559   putUInt(clause->prolog_vars, fd);
2560   putUInt(clause->variables, fd);
2561   putUInt(true(clause, UNIT_CLAUSE) ? 0 : 1, fd);
2562 
2563   bp = clause->codes;
2564   ep = bp + clause->code_size;
2565   init_wlabels(&lstate);
2566 
2567   while( bp < ep )
2568   { Code si = bp;				/* start instruction */
2569     unsigned int op = decode(*bp++);
2570     const char *ats = codeTable[op].argtype;
2571     int n;
2572 
2573     emit_wlabels(&lstate, si, fd);
2574 
2575     switch(op)
2576     { { int64_t v;
2577 
2578         case H_SMALLINT:
2579 	  v = valInt(*bp++);
2580 	  goto vh_int;
2581 #if SIZEOF_VOIDP == 4
2582 	case H_INT64:
2583 	{ Word p = (Word)&v;
2584 	  cpInt64Data(p, bp);
2585 	  goto vh_int;
2586 	}
2587 #endif
2588 	case H_INTEGER:
2589 	  v = (intptr_t)*bp++;
2590 	vh_int:
2591 	  putUInt(V_H_INTEGER, fd);
2592 	  putInt64(v, fd);
2593 	  continue;
2594       }
2595       { int64_t v;
2596 
2597         case B_SMALLINT:
2598 	  v = valInt(*bp++);
2599 	  goto vb_int;
2600 #if SIZEOF_VOIDP == 4
2601 	case B_INT64:
2602 	{ Word p = (Word)&v;
2603 	  cpInt64Data(p, bp);
2604 	  goto vb_int;
2605 	}
2606 #endif
2607 	case B_INTEGER:
2608 	  v = (intptr_t)*bp++;
2609 	vb_int:
2610 	  putUInt(V_B_INTEGER, fd);
2611 	  putInt64(v, fd);
2612 	  continue;
2613       }
2614       { int64_t v;
2615 
2616 #if SIZEOF_VOIDP == 4
2617 	case A_INT64:
2618 	{ Word p = (Word)&v;
2619 	  cpInt64Data(p, bp);
2620 	  goto va_int;
2621 	}
2622 #endif
2623 	case A_INTEGER:
2624 	  v = (intptr_t)*bp++;
2625 #if SIZEOF_VOIDP == 4
2626 	va_int:
2627 #endif
2628 	  putUInt(V_A_INTEGER, fd);
2629 	  putInt64(v, fd);
2630 	  continue;
2631       }
2632     }
2633 
2634     putUInt(op, fd);
2635 
2636     DEBUG(MSG_QLF_VMI, Sdprintf("\t%s at %ld\n", codeTable[op].name, Stell(fd)));
2637     for(n=0; ats[n]; n++)
2638     { switch(ats[n])
2639       { case CA1_PROC:
2640 	{ Procedure p = (Procedure) *bp++;
2641 	  saveXRProc(state, p PASS_LD);
2642 	  break;
2643 	}
2644 	case CA1_MODULE:
2645 	{ Module m = (Module) *bp++;	/* can be NULL, see I_CALLATMV */
2646 	  saveXRModule(state, m PASS_LD);
2647 	  break;
2648 	}
2649 	case CA1_FUNC:
2650 	{ functor_t f = (functor_t) *bp++;
2651 	  saveXRFunctor(state, f PASS_LD);
2652 	  break;
2653 	}
2654 	case CA1_AFUNC:
2655 	{ functor_t f = functorArithFunction((unsigned int)*bp++);
2656 	  saveXRFunctor(state, f PASS_LD);
2657 	  break;
2658 	}
2659 	case CA1_DATA:
2660 	{ word xr = (word) *bp++;
2661 	  saveXR(state, xr);
2662 	  break;
2663 	}
2664 	case CA1_JUMP:
2665 	{ Code to = stepPC(si) + *bp++;
2666 	  vm_wlabel *lbl = push_wlabel(&lstate, to, clause);
2667 	  putUInt(lbl->id, fd);
2668 	  break;
2669 	}
2670 	case CA1_INTEGER:
2671 	{ putInt64(*bp++, fd);
2672 	  break;
2673 	}
2674 	case CA1_VAR:
2675 	case CA1_FVAR:
2676 	case CA1_CHP:
2677 	{ intptr_t var = *bp++;
2678 	  putInt64(VAR_OFFSET(var), fd);
2679 	  break;
2680 	}
2681 	case CA1_INT64:
2682 	{ int64_t val;
2683 	  Word p = (Word)&val;
2684 
2685 	  cpInt64Data(p, bp);
2686 	  putInt64(val, fd);
2687 	  break;
2688 	}
2689 	case CA1_FLOAT:
2690 	{ union
2691 	  { word w[WORDS_PER_DOUBLE];
2692 	    double f;
2693 	  } v;
2694 	  Word p = v.w;
2695 	  cpDoubleData(p, bp);
2696 	  putFloat(v.f, fd);
2697 	  break;
2698 	}
2699 	case CA1_STRING:
2700 	{ word m = *bp;
2701 	  char *s = (char *)++bp;
2702 	  size_t wn = wsizeofInd(m);
2703 	  size_t l = wn*sizeof(word) - padHdr(m);
2704 	  bp += wn;
2705 
2706 	  if ( *s == 'B' )
2707 	  { putInt64(l, fd);
2708 	    while( l-- > 0 )
2709 	      Sputc(*s++&0xff, fd);
2710 	  } else
2711 	  { pl_wchar_t *w = (pl_wchar_t*)s + 1;
2712 	    IOENC oenc = fd->encoding;
2713 
2714 	    assert(*s == 'W');
2715 	    l /= sizeof(pl_wchar_t);
2716 	    l--;
2717 
2718 	    putInt64(l, fd);
2719 	    Sputc('W', fd);
2720 	    fd->encoding = ENC_UTF8;
2721 	    for( ; l-- > 0; w++)
2722 	    { Sputcode(*w, fd);
2723 	    }
2724 	    fd->encoding = oenc;
2725 	  }
2726 
2727 	  break;
2728 	}
2729 #ifdef O_GMP
2730 	case CA1_MPZ:
2731 	{ mpz_t mpz;
2732 	  size_t size;
2733 
2734 	  bp = get_mpz_from_code(bp, mpz);
2735 	  put_mpz_size(fd, mpz, &size);
2736 	  put_mpz_bits(fd, mpz, size);
2737 
2738 	  DEBUG(MSG_QLF_VMI, Sdprintf("Saved MPZ to %ld\n", Stell(fd)));
2739 	  break;
2740 	}
2741 	case CA1_MPQ:
2742 	{ mpq_t mpq;
2743 	  size_t num_size;
2744 	  size_t den_size;
2745 
2746 	  bp = get_mpq_from_code(bp, mpq);
2747 	  put_mpz_size(fd, mpq_numref(mpq), &num_size);
2748 	  put_mpz_size(fd, mpq_denref(mpq), &den_size);
2749 	  put_mpz_bits(fd, mpq_numref(mpq), num_size);
2750 	  put_mpz_bits(fd, mpq_denref(mpq), den_size);
2751 
2752 	  DEBUG(MSG_QLF_VMI, Sdprintf("Saved MPQ to %ld\n", Stell(fd)));
2753 	  break;
2754 	}
2755 #endif
2756 	default:
2757 	  fatalError("No support for VM argtype %d (arg %d of %s)",
2758 		     ats[n], n, codeTable[op].name);
2759       }
2760     }
2761   }
2762 
2763   exit_wlabels(&lstate);
2764 }
2765 
2766 
2767 		/********************************
2768 		*         COMPILATION           *
2769 		*********************************/
2770 
2771 static void
closePredicateWic(wic_state * state)2772 closePredicateWic(wic_state *state)
2773 { if ( state->currentPred )
2774   { Sputc('X', state->wicFd);
2775     state->currentPred = NULL;
2776   }
2777 }
2778 
2779 
2780 static unsigned int
predicateFlags(Definition def,atom_t sclass)2781 predicateFlags(Definition def, atom_t sclass)
2782 { unsigned int flags = 0;
2783 
2784   if ( sclass == ATOM_kernel )
2785   { if ( true(def, P_LOCKED) && false(def, HIDE_CHILDS) )
2786       return PRED_SYSTEM;
2787     return (PRED_SYSTEM|PRED_HIDE_CHILDS);
2788   }
2789 
2790   if ( true(def, P_LOCKED) )
2791     flags |= PRED_SYSTEM;
2792   if ( true(def, HIDE_CHILDS) )
2793     flags |= PRED_HIDE_CHILDS;
2794 
2795   return flags;
2796 }
2797 
2798 
2799 static void
openPredicateWic(wic_state * state,Definition def,atom_t sclass ARG_LD)2800 openPredicateWic(wic_state *state, Definition def, atom_t sclass ARG_LD)
2801 { if ( def != state->currentPred)
2802   { IOSTREAM *fd = state->wicFd;
2803     unsigned int mode = predicateFlags(def, sclass);
2804 
2805     closePredicateWic(state);
2806     state->currentPred = def;
2807 
2808     if ( def->module != LD->modules.source )
2809     { Sputc('O', fd);
2810       saveXR(state, def->module->name);
2811     } else
2812     { Sputc('P', fd);
2813     }
2814 
2815     saveXRFunctor(state, def->functor->functor PASS_LD);
2816     putUInt(mode, fd);
2817   }
2818 }
2819 
2820 
2821 static bool
putMagic(const char * s,IOSTREAM * fd)2822 putMagic(const char *s, IOSTREAM *fd)
2823 { for(; *s; s++)
2824     Sputc(*s, fd);
2825   Sputc(EOS, fd);
2826 
2827   succeed;
2828 }
2829 
2830 
2831 static bool
writeWicHeader(wic_state * state)2832 writeWicHeader(wic_state *state)
2833 { IOSTREAM *fd = state->wicFd;
2834 
2835   putMagic(saveMagic, fd);
2836   putInt64(PL_QLF_VERSION, fd);
2837   putInt64(VM_SIGNATURE, fd);
2838   if ( systemDefaults.home )
2839     putString(systemDefaults.home, STR_NOLEN, fd);
2840   else
2841     putString("<no home>",  STR_NOLEN, fd);
2842 
2843   initXR(state);
2844 
2845   DEBUG(MSG_QLF_SECTION, Sdprintf("Header complete ...\n"));
2846   succeed;
2847 }
2848 
2849 
2850 static bool
writeWicTrailer(wic_state * state)2851 writeWicTrailer(wic_state *state)
2852 { IOSTREAM *fd = state->wicFd;
2853 
2854   closePredicateWic(state);
2855   Sputc('X', fd);
2856   destroyXR(state);
2857   Sputc('T', fd);
2858 
2859   state->wicFd = NULL;
2860   if ( state->wicFile )
2861   { remove_string(state->wicFile);
2862     state->wicFile = NULL;
2863   }
2864 
2865   succeed;
2866 }
2867 
2868 /* FIXME: Deal with owner/real location in saved state
2869 */
2870 
2871 static bool
addClauseWic(wic_state * state,term_t term,atom_t file ARG_LD)2872 addClauseWic(wic_state *state, term_t term, atom_t file ARG_LD)
2873 { Clause clause;
2874   sourceloc loc;
2875 
2876   loc.file = file;
2877   loc.line = source_line_no;
2878 
2879   if ( (clause = assert_term(term, NULL, CL_END, file, &loc, 0 PASS_LD)) )
2880   { openPredicateWic(state, clause->predicate, ATOM_development PASS_LD);
2881     saveWicClause(state, clause);
2882 
2883     succeed;
2884   }
2885 
2886   Sdprintf("Failed to compile: "); pl_write(term); Sdprintf("\n");
2887   fail;
2888 }
2889 
2890 static bool
addDirectiveWic(wic_state * state,term_t term ARG_LD)2891 addDirectiveWic(wic_state *state, term_t term ARG_LD)
2892 { IOSTREAM *fd = state->wicFd;
2893 
2894   closePredicateWic(state);
2895   Sputc('D', fd);
2896   putInt64(source_line_no, fd);
2897 
2898   return saveQlfTerm(state, term PASS_LD);
2899 }
2900 
2901 
2902 static bool
importWic(wic_state * state,Procedure proc,atom_t strength ARG_LD)2903 importWic(wic_state *state, Procedure proc, atom_t strength ARG_LD)
2904 { int flags = atomToImportStrength(strength);
2905 
2906   assert(flags >= 0);
2907   closePredicateWic(state);
2908 
2909   Sputc('I', state->wicFd);
2910   saveXRProc(state, proc PASS_LD);
2911   putInt64(flags, state->wicFd);
2912 
2913   succeed;
2914 }
2915 
2916 		 /*******************************
2917 		 *	    PART MARKS		*
2918 		 *******************************/
2919 
2920 static void
initSourceMarks(wic_state * state)2921 initSourceMarks(wic_state *state)
2922 { state->has_source_marks = TRUE;
2923   state->source_mark_head = NULL;
2924   state->source_mark_tail = NULL;
2925 }
2926 
2927 
2928 static void
sourceMark(wic_state * state)2929 sourceMark(wic_state *state)
2930 { if ( state->has_source_marks )
2931   { SourceMark pm = allocHeapOrHalt(sizeof(struct source_mark));
2932 
2933     pm->file_index = Stell(state->wicFd);
2934     pm->next = NULL;
2935     if ( state->source_mark_tail )
2936     { state->source_mark_tail->next = pm;
2937       state->source_mark_tail = pm;
2938     } else
2939     { state->source_mark_tail = pm;
2940       state->source_mark_head = pm;
2941     }
2942   }
2943 }
2944 
2945 
2946 static int
writeSourceMarks(wic_state * state)2947 writeSourceMarks(wic_state *state)
2948 { long n = 0;
2949   SourceMark pn, pm = state->source_mark_head;
2950 
2951   DEBUG(MSG_QLF_SECTION, Sdprintf("Writing source marks: "));
2952 
2953   for( ; pm; pm = pn )
2954   { pn = pm->next;
2955 
2956     DEBUG(MSG_QLF_SECTION, Sdprintf(" %d", pm->file_index));
2957     putInt32(pm->file_index, state->wicFd);
2958     freeHeap(pm, sizeof(*pm));
2959     n++;
2960   }
2961   state->source_mark_head = state->source_mark_tail = NULL;
2962 
2963   DEBUG(MSG_QLF_SECTION, Sdprintf("\nWritten %d marks\n", n));
2964   putInt32(n, state->wicFd);
2965 
2966   return 0;
2967 }
2968 
2969 /* Raise an error of the format
2970 
2971 	error(qlf_format_error(File, Message), _)
2972 */
2973 
2974 static int
qlfError(wic_state * state,const char * error,...)2975 qlfError(wic_state *state, const char *error, ...)
2976 { va_list args;
2977   char message[LINESIZ];
2978   int rc;
2979   const char *file = state->wicFile;
2980 
2981   if ( !file )
2982     file = "<unknown>";
2983 
2984   va_start(args, error);
2985   Svsnprintf(message, sizeof(message), error, args);
2986   va_end(args);
2987 
2988   if ( GD->bootsession )
2989   { fatalError("%s: %s", file, message);
2990     rc = FALSE;				/* keep compiler happy */
2991     exit(1);
2992   } else
2993   { GET_LD
2994     term_t ex, fn;
2995 
2996     rc = ( (ex=PL_new_term_ref()) &&
2997 	   (fn=PL_new_term_ref()) &&
2998 	   PL_unify_chars(fn, PL_ATOM|REP_FN, (size_t)-1, file) &&
2999 	   PL_unify_term(ex,
3000 			 PL_FUNCTOR, FUNCTOR_error2,
3001 			   PL_FUNCTOR_CHARS, "qlf_format_error", 2,
3002 			     PL_TERM, fn,
3003 			     PL_CHARS, message,
3004 			   PL_VARIABLE) &&
3005 	   PL_raise_exception(ex) );
3006   }
3007 
3008   return rc;
3009 }
3010 
3011 
3012 static int
qlfSourceInfo(wic_state * state,size_t offset,term_t list ARG_LD)3013 qlfSourceInfo(wic_state *state, size_t offset, term_t list ARG_LD)
3014 { IOSTREAM *s = state->wicFd;
3015   char *str;
3016   term_t head = PL_new_term_ref();
3017   atom_t fname;
3018 
3019   if ( Sseek(s, (long)offset, SIO_SEEK_SET) != 0 )
3020     return qlfError(state, "seek to %zd failed: %s", offset, OsError());
3021   if ( Sgetc(s) != 'F' || !(str=getString(s, NULL)) )
3022     return qlfError(state, "invalid string (offset %zd)", offset);
3023   fname = qlfFixSourcePath(state, str);
3024 
3025   return PL_unify_list(list, head, list) &&
3026          PL_unify_atom(head, fname);
3027 }
3028 
3029 
3030 static word
qlfInfo(const char * file,term_t cversion,term_t minload,term_t fversion,term_t csig,term_t fsig,term_t files0 ARG_LD)3031 qlfInfo(const char *file,
3032 	term_t cversion, term_t minload, term_t fversion,
3033 	term_t csig, term_t fsig,
3034 	term_t files0 ARG_LD)
3035 { IOSTREAM *s = NULL;
3036   int lversion;
3037   int nqlf, i;
3038   size_t *qlfstart = NULL;
3039   word rval = FALSE;
3040   term_t files = PL_copy_term_ref(files0);
3041   wic_state state;
3042 
3043   memset(&state, 0, sizeof(state));
3044   state.wicFile = (char*)file;
3045 
3046   if ( !(s = Sopen_file(file, "rbr")) )
3047   { term_t f = PL_new_term_ref();
3048 
3049     PL_put_atom_chars(f, file);
3050     return PL_error(NULL, 0, OsError(), ERR_FILE_OPERATION,
3051 		    ATOM_open, ATOM_source_sink, f);
3052   }
3053   state.wicFd = s;
3054 
3055   if ( cversion )
3056   { int vm_signature;
3057 
3058     if ( !PL_unify_integer(cversion, PL_QLF_VERSION) ||
3059 	 !PL_unify_integer(minload, PL_QLF_LOADVERSION) ||
3060 	 !PL_unify_integer(csig, (int)VM_SIGNATURE) )
3061       goto out;
3062 
3063     if ( !qlfVersion(&state, qlfMagic, &lversion) ||
3064 	 !PL_unify_integer(fversion, lversion) )
3065       goto out;
3066 
3067     vm_signature = getInt(s);		/* TBD: provide to Prolog layer */
3068 
3069     if ( !PL_unify_integer(fsig, vm_signature) )
3070       goto out;
3071   } else
3072   { if ( !qlfIsCompatible(&state, qlfMagic) )
3073       goto out;
3074   }
3075 
3076   if ( !pushPathTranslation(&state, file, 0) )
3077     goto out;
3078 
3079   if ( Sseek(s, -4, SIO_SEEK_END) < 0 )	/* 4 bytes of PutInt32() */
3080   { qlfError(&state, "seek to index failed: %s", OsError());
3081     goto out;
3082   }
3083   if ( (nqlf = getInt32(s)) < 0 )
3084   { qlfError(&state, "invalid number of files (%d)", nqlf);
3085     goto out;
3086   }
3087   if ( Sseek(s, -4 * (nqlf+1), SIO_SEEK_END) < 0 )
3088   { qlfError(&state, "seek to files failed: %s", OsError());
3089     goto out;
3090   }
3091 
3092   DEBUG(MSG_QLF_SECTION, Sdprintf("Found %d sources at", nqlf));
3093   if ( !(qlfstart = malloc(sizeof(size_t)*nqlf)) )
3094   { PL_no_memory();
3095     goto out;
3096   }
3097   for(i=0; i<nqlf; i++)
3098   { qlfstart[i] = (size_t)getInt32(s);
3099     DEBUG(MSG_QLF_SECTION, Sdprintf(" %ld", qlfstart[i]));
3100   }
3101   DEBUG(MSG_QLF_SECTION, Sdprintf("\n"));
3102 
3103   for(i=0; i<nqlf; i++)
3104   { if ( !qlfSourceInfo(&state, qlfstart[i], files PASS_LD) )
3105       goto out;
3106   }
3107 
3108   rval = PL_unify_nil(files);
3109 
3110 out:
3111   popPathTranslation(&state);
3112   if ( qlfstart )
3113     free(qlfstart);
3114   if ( s )
3115     Sclose(s);
3116 
3117   return rval;
3118 }
3119 
3120 
3121 /** '$qlf_info'(+File,
3122 		-CurrentVersion, -MinLOadVersion, -FileVersion,
3123 		-CurrentSignature, -FileSignature,
3124 		-Files)
3125 
3126 Provide information about a QLF file.
3127 
3128 @arg CurrentVersion is the current save version
3129 @arg FileVersion is the version of the file
3130 @arg CurrentSignature is the current VM signature
3131 @arg FileSignature is the signature of the file
3132 @arg Files is a list of atoms representing the files used to create the QLF
3133 */
3134 
3135 static
3136 PRED_IMPL("$qlf_info", 7, qlf_info, 0)
3137 { PRED_LD
3138   char *name;
3139 
3140   if ( !PL_get_file_name(A1, &name, PL_FILE_ABSOLUTE) )
3141     fail;
3142 
3143   return qlfInfo(name, A2, A3, A4, A5, A6, A8 PASS_LD);
3144 }
3145 
3146 
3147 static
3148 PRED_IMPL("$qlf_sources", 2, qlf_sources, 0)
3149 { PRED_LD
3150   char *name;
3151 
3152   if ( !PL_get_file_name(A1, &name, PL_FILE_ABSOLUTE) )
3153     fail;
3154 
3155   return qlfInfo(name, 0, 0, 0, 0, 0, A2 PASS_LD);
3156 }
3157 
3158 
3159 		 /*******************************
3160 		 *	NEW MODULE SUPPORT	*
3161 		 *******************************/
3162 
3163 static wic_state *
qlfOpen(term_t file)3164 qlfOpen(term_t file)
3165 { char *name;
3166   char *absname;
3167   char tmp[MAXPATHLEN];
3168   IOSTREAM *out;
3169   wic_state *state;
3170 
3171   if ( !PL_get_file_name(file, &name, 0) ||
3172        !(absname = AbsoluteFile(name, tmp)) )
3173     return NULL;
3174 
3175   if ( !(out = Sopen_file(name, "wb" TRACK_POS)) )
3176   { PL_error(NULL, 0, NULL, ERR_PERMISSION, ATOM_write, ATOM_file, file);
3177     return NULL;
3178   }
3179 
3180   state = allocHeapOrHalt(sizeof(*state));
3181   memset(state, 0, sizeof(*state));
3182   state->wicFile = store_string(name);
3183   state->mkWicFile = store_string(name);
3184   state->wicFd = out;
3185   initXR(state);
3186   initSourceMarks(state);
3187 
3188   putMagic(qlfMagic, state->wicFd);
3189   putInt64(PL_QLF_VERSION, state->wicFd);
3190   putInt64(VM_SIGNATURE, state->wicFd);
3191 
3192   putString(absname, STR_NOLEN, state->wicFd);
3193 
3194   return state;
3195 }
3196 
3197 
3198 static bool
qlfClose(wic_state * state ARG_LD)3199 qlfClose(wic_state *state ARG_LD)
3200 { int rc;
3201 
3202   closePredicateWic(state);
3203   writeSourceMarks(state);
3204   rc = Sclose(state->wicFd);
3205   state->wicFd = NULL;
3206   if ( state->mkWicFile )
3207   { remove_string(state->mkWicFile);
3208     state->mkWicFile = NULL;
3209   }
3210   destroyXR(state);
3211 
3212   LD->qlf.current_state = state->parent;
3213   freeHeap(state, sizeof(*state));
3214 
3215   return rc == 0;
3216 }
3217 
3218 
3219 static int
qlfVersion(wic_state * state,const char * exp_magic,int * vp)3220 qlfVersion(wic_state *state, const char *exp_magic, int *vp)
3221 { IOSTREAM *s = state->wicFd;
3222   char mbuf[100];
3223   char *magic;
3224 
3225   if ( !(magic = getMagicString(s, mbuf, sizeof(mbuf))) ||
3226        !streq(magic, exp_magic) )
3227     return qlfError(state, "Not a %s", exp_magic);
3228 
3229   *vp = getInt(s);
3230 
3231   return TRUE;
3232 }
3233 
3234 
3235 static int
pushPathTranslation(wic_state * state,const char * absloadname,int flags)3236 pushPathTranslation(wic_state *state, const char *absloadname, int flags)
3237 { IOSTREAM *fd = state->wicFd;
3238   char *abssavename;
3239   qlf_state *new = allocHeapOrHalt(sizeof(*new));
3240 
3241   memset(new, 0, sizeof(*new));
3242   new->previous = state->load_state;
3243   state->load_state = new;
3244 
3245   if ( !(abssavename = getString(fd, NULL)) )
3246     return qlfError(state, "bad string");
3247 
3248   if ( absloadname && !streq(absloadname, abssavename) )
3249   { char load[MAXPATHLEN];
3250     char save[MAXPATHLEN];
3251     char *l, *s, *le, *se;
3252 
3253     if ( ( strlen(abssavename)+1 > MAXPATHLEN ||
3254 	   strlen(absloadname)+1 > MAXPATHLEN
3255 	 ) )
3256       return PL_representation_error("max_path_length");
3257 
3258     new->has_moved = TRUE;
3259 
3260     if ( (flags & PATH_ISDIR) )
3261     { l = strcpy(load, absloadname);
3262       s = strcpy(save, abssavename);
3263     } else
3264     { l = DirName(absloadname, load);
3265       s = DirName(abssavename, save);
3266     }
3267     le = l+strlen(l);
3268     se = s+strlen(s);
3269     for( ;le>l && se>s && le[-1] == se[-1]; le--, se--)
3270     { if ( le[-1] == '/' )
3271       { *le = EOS;
3272         *se = EOS;
3273       }
3274     }
3275 
3276     new->load_dir = store_string(l);
3277     new->save_dir = store_string(s);
3278     DEBUG(MSG_QLF_PATH,
3279 	  Sdprintf("QLF file has moved; replacing %s --> %s\n",
3280 		   state->load_state->save_dir,
3281 		   state->load_state->load_dir));
3282   }
3283 
3284   return TRUE;
3285 }
3286 
3287 
3288 static void
popPathTranslation(wic_state * state)3289 popPathTranslation(wic_state *state)
3290 { if ( state->load_state )
3291   { qlf_state *old = state->load_state;
3292 
3293     state->load_state = old->previous;
3294 
3295     if ( old->has_moved )
3296     { path_translated *tr;
3297 
3298       remove_string(old->load_dir);
3299       remove_string(old->save_dir);
3300 
3301       if ( (tr=old->translated) )
3302       { GET_LD
3303         path_translated *n;
3304 	static predicate_t pred = NULL;
3305 	fid_t fid = PL_open_foreign_frame();
3306 	term_t av = PL_new_term_refs(2);
3307 
3308 	if ( !pred )
3309 	  pred = PL_predicate("$translated_source", 2, "system");
3310 
3311 	for(; tr; tr=n)
3312 	{ n = tr->next;
3313 
3314 	  PL_put_atom(av+0, tr->from);
3315 	  PL_put_atom(av+1, tr->to);
3316 	  PL_unregister_atom(tr->from);
3317 
3318 	  if ( !PL_call_predicate(NULL, PL_Q_NORMAL, pred, av) )
3319 	    Sdprintf("$translated_source/2 failed~n");
3320 
3321 	  PL_free(tr);
3322 	}
3323 
3324 	PL_discard_foreign_frame(fid);
3325       }
3326     }
3327     freeHeap(old, sizeof(*old));
3328   }
3329 }
3330 
3331 static int
qlfIsCompatible(wic_state * state,const char * magic)3332 qlfIsCompatible(wic_state *state, const char *magic)
3333 { int lversion;
3334   int vm_signature;
3335 
3336   if ( !qlfVersion(state, magic, &lversion) )
3337     return FALSE;
3338   if ( lversion < PL_QLF_LOADVERSION )
3339     return qlfError(state, "incompatible version (file: %d, Prolog: %d)",
3340 		    lversion, PL_QLF_VERSION);
3341   state->saved_version = lversion;
3342 
3343   vm_signature = getInt(state->wicFd);
3344   if ( vm_signature != (int)VM_SIGNATURE )
3345     return qlfError(state, "incompatible VM-signature (file: 0x%x; Prolog: 0x%x)",
3346 		    (unsigned int)vm_signature, (unsigned int)VM_SIGNATURE);
3347 
3348   return TRUE;
3349 }
3350 
3351 
3352 static bool
qlfLoad(wic_state * state,Module * module ARG_LD)3353 qlfLoad(wic_state *state, Module *module ARG_LD)
3354 { IOSTREAM *fd = state->wicFd;
3355   bool rval;
3356   const char *absloadname;
3357   char tmp[MAXPATHLEN];
3358   atom_t file;
3359 
3360   if ( (file = fileNameStream(fd)) )
3361   { PL_chars_t text;
3362 
3363     if ( !get_atom_text(file, &text) )
3364       fail;
3365     if ( !PL_mb_text(&text, REP_FN) )
3366     { PL_free_text(&text);
3367       fail;
3368     }
3369     state->wicFile = store_string(text.text.t);
3370     if ( !(absloadname = AbsoluteFile(state->wicFile, tmp)) )
3371       fail;
3372     PL_free_text(&text);
3373   } else
3374   { absloadname = NULL;
3375   }
3376 
3377   if ( !qlfIsCompatible(state, qlfMagic) )
3378     return FALSE;
3379 
3380   if ( !pushPathTranslation(state, absloadname, 0) )
3381     return FALSE;
3382 
3383   pushXrIdTable(state);
3384   for(;;)
3385   { int c = Qgetc(fd);
3386 
3387     switch(c)
3388     { case 'Q':
3389         break;
3390       case 'I':
3391 	loadInclude(state PASS_LD);
3392         continue;
3393       default:
3394 	qlfLoadError(state);
3395     }
3396 
3397     break;
3398   }
3399 
3400   rval = loadPart(state, module, FALSE PASS_LD);
3401   popXrIdTable(state);
3402   popPathTranslation(state);
3403 
3404   if ( state->errors.invalid_wide_chars )
3405     Sdprintf("WARNING: %d wide characters could not be represented as UCS-2\n",
3406 	     state->errors.invalid_wide_chars);
3407 
3408   return rval;
3409 }
3410 
3411 
3412 static bool
qlfSaveSource(wic_state * state,SourceFile f)3413 qlfSaveSource(wic_state *state, SourceFile f)
3414 { GET_LD
3415   IOSTREAM *fd = state->wicFd;
3416   PL_chars_t text;
3417 
3418   PL_STRINGS_MARK();
3419   get_atom_text(f->name, &text);
3420   PL_mb_text(&text, REP_UTF8);
3421 
3422   sourceMark(state);
3423   Sputc('F', fd);
3424   putString(text.text.t, text.length, fd);
3425   putFloat(f->mtime, fd);
3426   Sputc(f->system ? 's' : 'u', fd);
3427   PL_STRINGS_RELEASE();
3428 
3429   state->currentSource = f;
3430 
3431   succeed;
3432 }
3433 
3434 
3435 static bool
qlfStartModule(wic_state * state,Module m ARG_LD)3436 qlfStartModule(wic_state *state, Module m ARG_LD)
3437 { IOSTREAM *fd = state->wicFd;
3438   ListCell c;
3439   closePredicateWic(state);
3440   Sputc('Q', fd);
3441   Sputc('M', fd);
3442   saveXR(state, m->name);
3443 
3444   if ( m->file )
3445   { qlfSaveSource(state, m->file);
3446     putInt64(m->line_no, fd);
3447   } else
3448   { Sputc('-', fd);
3449   }
3450 
3451   Sputc('C', fd);
3452   saveXR(state, m->class);
3453   for(c=m->supers; c; c=c->next)
3454   { Module s = c->value;
3455 
3456     Sputc('S', fd);
3457     saveXR(state, s->name);
3458   }
3459 
3460   DEBUG(MSG_QLF_SECTION, Sdprintf("MODULE %s\n", stringAtom(m->name)));
3461   for_table(m->public, name, value,
3462 	    { functor_t f = (functor_t)name;
3463 
3464 	      DEBUG(MSG_QLF_EXPORT,
3465 		    Sdprintf("Exported %s/%d\n",
3466 			     stringAtom(nameFunctor(f)),
3467 			     arityFunctor(f)));
3468 	      Sputc('E', fd);
3469 	      saveXRFunctor(state, f PASS_LD);
3470 	    })
3471 
3472   Sputc('X', fd);
3473 
3474   succeed;
3475 }
3476 
3477 
3478 static bool
qlfStartSubModule(wic_state * state,Module m ARG_LD)3479 qlfStartSubModule(wic_state *state, Module m ARG_LD)
3480 { IOSTREAM *fd = state->wicFd;
3481 
3482   closePredicateWic(state);
3483   Sputc('M', fd);
3484   saveXR(state, m->name);
3485 
3486   succeed;
3487 }
3488 
3489 
3490 static bool
qlfStartFile(wic_state * state,SourceFile f)3491 qlfStartFile(wic_state *state, SourceFile f)
3492 { IOSTREAM *fd = state->wicFd;
3493 
3494   closePredicateWic(state);
3495   Sputc('Q', fd);
3496   qlfSaveSource(state, f);
3497 
3498   succeed;
3499 }
3500 
3501 
3502 static bool
qlfEndPart(wic_state * state)3503 qlfEndPart(wic_state *state)
3504 { IOSTREAM *fd = state->wicFd;
3505 
3506   closePredicateWic(state);
3507   Sputc('X', fd);
3508 
3509   succeed;
3510 }
3511 
3512 
3513 /** '$qlf_start_module'(+Module)
3514 
3515 Start emitting a module.
3516 */
3517 
3518 static
3519 PRED_IMPL("$qlf_start_module", 1, qlf_start_module, 0)
3520 { PRED_LD
3521   wic_state *state;
3522 
3523   if ( (state=LD->qlf.current_state) )
3524   { Module m;
3525 
3526     if ( !PL_get_module_ex(A1, &m) )
3527       fail;
3528 
3529     return qlfStartModule(state, m PASS_LD);
3530   }
3531 
3532   succeed;
3533 }
3534 
3535 
3536 static
3537 PRED_IMPL("$qlf_start_sub_module", 1, qlf_start_sub_module, 0)
3538 { PRED_LD
3539   wic_state *state;
3540 
3541   if ( (state=LD->qlf.current_state) )
3542   { Module m;
3543 
3544     if ( !PL_get_module_ex(A1, &m) )
3545       fail;
3546 
3547     return qlfStartSubModule(state, m PASS_LD);
3548   }
3549 
3550   succeed;
3551 }
3552 
3553 
3554 static
3555 PRED_IMPL("$qlf_start_file", 1, qlf_start_file, 0)
3556 { PRED_LD
3557   wic_state *state;
3558 
3559   if ( (state=LD->qlf.current_state) )
3560   { atom_t a;
3561 
3562     if ( !PL_get_atom_ex(A1, &a) )
3563       fail;
3564 
3565     return qlfStartFile(state, lookupSourceFile(a, TRUE));
3566   }
3567 
3568   succeed;
3569 }
3570 
3571 
3572 static
3573 PRED_IMPL("$qlf_current_source", 1, qlf_current_source, 0)
3574 { PRED_LD
3575   wic_state *state;
3576   SourceFile sf;
3577 
3578   if ( (state=LD->qlf.current_state) &&
3579        (sf = state->currentSource) )
3580   { return PL_unify_atom(A1, sf->name);
3581   }
3582 
3583   return FALSE;
3584 }
3585 
3586 
3587 static
3588 PRED_IMPL("$qlf_include", 5, qlf_include, 0)
3589 { PRED_LD
3590   atom_t owner, pn, fn;
3591   int line;
3592   double time;
3593   wic_state *state;
3594 
3595   if ( PL_get_atom_ex(A1, &owner) &&
3596        PL_get_atom_ex(A2, &pn) &&
3597        PL_get_integer_ex(A3, &line) &&
3598        PL_get_atom_ex(A4, &fn) &&
3599        PL_get_float(A5, &time) &&
3600        (state=LD->qlf.current_state) )
3601   { IOSTREAM *fd = state->wicFd;
3602 
3603     Sputc('I', fd);
3604     saveXR(state, owner);
3605     saveXR(state, pn);
3606     putInt64(line, fd);
3607     saveXR(state, fn);
3608     putFloat(time, fd);
3609 
3610     return TRUE;
3611   }
3612 
3613   return FALSE;
3614 }
3615 
3616 
3617 static
3618 PRED_IMPL("$qlf_end_part", 0, qlf_end_part, 0)
3619 { PRED_LD
3620   wic_state *state;
3621 
3622   if ( (state=LD->qlf.current_state) )
3623   { return qlfEndPart(state);
3624   }
3625 
3626   succeed;
3627 }
3628 
3629 
3630 static
3631 PRED_IMPL("$qlf_open", 1, qlf_open, 0)
3632 { PRED_LD
3633   wic_state *state = qlfOpen(A1);
3634 
3635   if ( state )
3636   { state->parent = LD->qlf.current_state;
3637     LD->qlf.current_state = state;
3638 
3639     return TRUE;
3640   }
3641 
3642   return FALSE;
3643 }
3644 
3645 
3646 static
3647 PRED_IMPL("$qlf_close", 0, qlf_close, 0)
3648 { PRED_LD
3649   wic_state *state;
3650 
3651   if ( (state=LD->qlf.current_state) )
3652     return qlfClose(state PASS_LD);
3653 
3654   succeed;
3655 }
3656 
3657 
3658 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3659 $qlf_load(:Stream, -ModuleOut)
3660 
3661 Load QLF data from Stream.
3662 
3663 @param	ModuleOut is unified to an atom holding the name of the
3664 	loaded module or the integer 0 if the loaded object is
3665 	not a module.
3666 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3667 
3668 static
3669 PRED_IMPL("$qlf_load", 2, qlf_load, PL_FA_TRANSPARENT)
3670 { GET_LD
3671   term_t qstream = A1;
3672   term_t module = A2;
3673   Module m, oldsrc = LD->modules.source;
3674   bool rval;
3675   term_t stream = PL_new_term_ref();
3676   IOSTREAM *fd;
3677   IOENC saved_enc;
3678   wic_state state;
3679 
3680   m = oldsrc;
3681   if ( !PL_strip_module(qstream, &m, stream) )
3682     fail;
3683   if ( !PL_get_stream_handle(stream, &fd) )
3684     fail;
3685 
3686   memset(&state, 0, sizeof(state));
3687   state.wicFd = fd;
3688 
3689   saved_enc = fd->encoding;
3690   fd->encoding = ENC_OCTET;
3691   LD->modules.source = m;
3692   rval = qlfLoad(&state, &m PASS_LD);
3693   LD->modules.source = oldsrc;
3694   fd->encoding = saved_enc;
3695 
3696   if ( state.wicFile )
3697     remove_string(state.wicFile);
3698   PL_release_stream(fd);
3699 
3700   if ( rval )
3701   { if ( m )
3702       return PL_unify_atom(module, m->name);
3703 
3704     return PL_unify_integer(module, 0);
3705   }
3706 
3707   fail;
3708 }
3709 
3710 
3711 		/********************************
3712 		*        PROLOG SUPPORT         *
3713 		*********************************/
3714 
3715 /** '$open_wic'(+Stream) is det.
3716 
3717 Write a header for a QLF-stream
3718 */
3719 
3720 static const opt_spec open_wic_options[] =
3721 { { ATOM_obfuscate,	    OPT_BOOL },
3722   { NULL_ATOM,		    0 }
3723 };
3724 
3725 
3726 static
3727 PRED_IMPL("$open_wic", 2, open_wic, 0)
3728 { GET_LD
3729   IOSTREAM *fd;
3730   int obfuscate = FALSE;
3731 
3732   assert(V_LABEL > I_HIGHEST);
3733 
3734   if ( !scan_options(A2, 0, ATOM_state_option, open_wic_options,
3735 		     &obfuscate) )
3736     fail;
3737 
3738   if ( PL_get_stream_handle(A1, &fd) )
3739   { wic_state *state = allocHeapOrHalt(sizeof(*state));
3740 
3741     memset(state, 0, sizeof(*state));
3742     state->obfuscate = obfuscate;
3743     state->wicFd = fd;
3744     writeWicHeader(state);
3745     state->parent = LD->qlf.current_state;
3746     LD->qlf.current_state = state;
3747 
3748     succeed;
3749   }
3750 
3751   fail;					/* PL_get_stream_handle() */
3752 					/* throws exception */
3753 }
3754 
3755 
3756 static
3757 PRED_IMPL("$close_wic", 0, close_wic, 0)
3758 { PRED_LD
3759   wic_state *state;
3760 
3761   if ( (state=LD->qlf.current_state) )
3762   { writeWicTrailer(state);
3763 
3764     LD->qlf.current_state = state->parent;
3765     freeHeap(state, sizeof(*state));
3766 
3767     succeed;
3768   }
3769 
3770   fail;
3771 }
3772 
3773 static void
freeMapping(void * name,void * value)3774 freeMapping(void *name, void *value)
3775 { word id_from = (word)name;
3776   word id_to   = (word)value;
3777 
3778   if ( isAtom(id_from) ) PL_unregister_atom(id_from);
3779   if ( isAtom(id_to) )   PL_unregister_atom(id_to);
3780 }
3781 
3782 static int
get_id(term_t t,void ** id)3783 get_id(term_t t, void **id)
3784 { GET_LD
3785   atom_t a;
3786   functor_t f;
3787 
3788   if ( PL_get_atom(t, &a) )
3789   { *id = (void *)a;
3790   } else if ( PL_get_functor(t, &f) )
3791   { if ( f == FUNCTOR_colon2 )
3792     { Procedure proc;
3793 
3794       if ( get_procedure(t, &proc, 0, GP_FINDHERE|GP_EXISTENCE_ERROR) )
3795       { *id = (void *)proc->definition;
3796       } else
3797       { return FALSE;
3798       }
3799     }
3800     *id = (void *)f;
3801   } else
3802   { return PL_type_error("identifier", t);
3803   }
3804 
3805   return TRUE;
3806 }
3807 
3808 /** '$map_id'(+IdFrom, +IdTo) is det.
3809 
3810 Add a mapping between an identifier when saving a state.
3811 @arg IdFrom, IdTo are either atoms or compound terms.  In the
3812 latter case the functor is mapped.
3813 */
3814 
3815 static
3816 PRED_IMPL("$map_id", 2, map_id, 0)
3817 { PRED_LD
3818   wic_state *state;
3819 
3820   if ( (state=LD->qlf.current_state) )
3821   { void *id_from, *id_to, *old;
3822 
3823     if ( !get_id(A1, &id_from) ||
3824 	 !get_id(A2, &id_to) )
3825       return FALSE;
3826 
3827     if ( (isAtom((word)id_from)    && !isAtom((word)id_to)) ||
3828 	 (isFunctor((word)id_from) && !isFunctor((word)id_to)) )
3829       return PL_permission_error("map", "identifier", A1);
3830 
3831     if ( !state->idMap )
3832     { state->idMap = newHTable(256);
3833       state->idMap->free_symbol = freeMapping;
3834     }
3835 
3836     if ( (old=lookupHTable(state->idMap, id_from)) )
3837     { if ( old == id_to )
3838 	return TRUE;
3839       else
3840 	return PL_permission_error("map", "identifier", A1);
3841     } else
3842     { addNewHTable(state->idMap, id_from, id_to);
3843       if ( isAtom((word)id_from) )
3844       { PL_register_atom((atom_t)id_from);
3845 	PL_register_atom((atom_t)id_to);
3846       }
3847       return TRUE;
3848     }
3849   } else {
3850     return PL_permission_error("map", "identifier", A1);
3851   }
3852 }
3853 
3854 static
3855 PRED_IMPL("$unmap_id", 1, unmap_id, 0)
3856 { PRED_LD
3857   wic_state *state;
3858 
3859   if ( (state=LD->qlf.current_state) )
3860   { void *id_from;
3861 
3862     if ( !get_id(A1, &id_from) )
3863       return FALSE;
3864 
3865     if ( state->idMap )
3866       deleteHTable(state->idMap, id_from);
3867   }
3868 
3869   return TRUE;
3870 }
3871 
3872 
3873 static
3874 PRED_IMPL("$add_directive_wic", 1, add_directive_wic, PL_FA_TRANSPARENT)
3875 { PRED_LD
3876   wic_state *state;
3877 
3878   if ( (state=LD->qlf.current_state) )
3879   { Module m = MODULE_system;
3880     term_t term = PL_new_term_ref();
3881     term_t qterm = PL_new_term_ref();
3882 
3883     if ( !PL_strip_module(A1, &m, term) )
3884       return FALSE;
3885     if ( !(PL_is_callable(term)) )
3886       return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_callable, A1);
3887 
3888     if ( !PL_unify_term(qterm,
3889 			PL_FUNCTOR, FUNCTOR_colon2,
3890 			  PL_ATOM, m->name,
3891 			  PL_TERM, term) )
3892       return FALSE;
3893 
3894     return addDirectiveWic(state, qterm PASS_LD);
3895   }
3896 
3897   succeed;
3898 }
3899 
3900 
3901 /** '$import_wic'(+Module, +PredicateIndicator, +Strength)
3902 */
3903 
3904 static
3905 PRED_IMPL("$import_wic", 3, import_wic, 0)
3906 { PRED_LD
3907   wic_state *state;
3908 
3909   if ( (state=LD->qlf.current_state) )
3910   { Module m = NULL;
3911     functor_t fd;
3912     atom_t strength;
3913 
3914     if ( !PL_get_module(A1, &m) ||
3915 	 !get_functor(A2, &fd, &m, 0, GF_PROCEDURE) ||
3916 	 !PL_get_atom_ex(A3, &strength) )
3917       fail;
3918 
3919     return importWic(state, lookupProcedure(fd, m), strength PASS_LD);
3920   }
3921 
3922   succeed;
3923 }
3924 
3925 
3926 /** '$qlf_assert_clause'(+ClauseRef, +Class) is det.
3927 */
3928 
3929 static
3930 PRED_IMPL("$qlf_assert_clause", 2, qlf_assert_clause, 0)
3931 { PRED_LD
3932   wic_state *state;
3933 
3934   if ( (state=LD->qlf.current_state) )
3935   { Clause clause;
3936     atom_t sclass;
3937 
3938     if ( (PL_get_clref(A1, &clause) != TRUE) ||
3939 	 !PL_get_atom_ex(A2, &sclass) )
3940       fail;
3941 
3942     openPredicateWic(state, clause->predicate, sclass PASS_LD);
3943     saveWicClause(state, clause);
3944   }
3945 
3946   succeed;
3947 }
3948 
3949 
3950 		/********************************
3951 		*     BOOTSTRAP COMPILATION     *
3952 		*********************************/
3953 
3954 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3955 The code below offers a restricted compilation  toplevel  used  for  the
3956 bootstrap  compilation  (-b  option).  It handles most things the Prolog
3957 defined compiler handles as well, except:
3958 
3959   - Be carefull to define  a  predicate  first  before  using  it  as  a
3960     directive
3961   - It does not offer `consult', `ensure_loaded' or the  list  notation.
3962     (there is no way to include other files).
3963 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3964 
3965 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3966 Check whether clause is  of  the  form   :-  directive.  If  so, put the
3967 directive in directive and succeed. If the   term has no explicit module
3968 tag, add one from the current source-module.
3969 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3970 
3971 static int
directiveClause(term_t directive,term_t clause,const char * functor)3972 directiveClause(term_t directive, term_t clause, const char *functor)
3973 { GET_LD
3974   atom_t name;
3975   size_t arity;
3976   term_t d0 = PL_new_term_ref();
3977   functor_t f;
3978 
3979   if ( !PL_get_name_arity(clause, &name, &arity) ||
3980        arity != 1 ||
3981        !streq(stringAtom(name), functor) )
3982     fail;
3983 
3984   _PL_get_arg(1, clause, d0);
3985   if ( PL_get_functor(d0, &f) && f == FUNCTOR_colon2 )
3986   { PL_put_term(directive, d0);
3987   } else
3988   { term_t m;
3989 
3990     if ( !(m = PL_new_term_ref()) )
3991       return FALSE;
3992     PL_put_atom(m, LD->modules.source->name);
3993     return PL_cons_functor(directive, FUNCTOR_colon2, m, d0);
3994   }
3995 
3996   succeed;
3997 }
3998 
3999 /*  Compile an entire file into intermediate code.
4000 
4001  ** Thu Apr 28 13:44:43 1988  jan@swivax.UUCP (Jan Wielemaker)  */
4002 
4003 static bool
compileFile(wic_state * state,const char * file)4004 compileFile(wic_state *state, const char *file)
4005 { GET_LD
4006   char tmp[MAXPATHLEN];
4007   char *path;
4008   term_t f = PL_new_term_ref();
4009   SourceFile sf;
4010   atom_t nf;
4011 
4012   DEBUG(MSG_QLF_BOOT, Sdprintf("Boot compilation of %s\n", file));
4013   if ( !(path = AbsoluteFile(file, tmp)) )
4014     fail;
4015   DEBUG(MSG_QLF_PATH, Sdprintf("Expanded to %s\n", path));
4016 
4017   if ( PL_unify_chars(f, PL_ATOM|REP_MB, (size_t)-1, path) )
4018     PL_get_atom(f, &nf);
4019   else
4020     fatalError("Could not unify path");
4021   DEBUG(MSG_QLF_BOOT, Sdprintf("Opening\n"));
4022   if ( !pl_see(f) )
4023   { Sdprintf("Failed to open %s\n", path);
4024     return FALSE;
4025   }
4026   DEBUG(MSG_QLF_BOOT, Sdprintf("pl_start_consult()\n"));
4027   sf = lookupSourceFile(nf, TRUE);
4028   startConsult(sf);
4029   if ( !LastModifiedFile(path, &sf->mtime) )
4030     Sdprintf("Failed to get time from %s\n", path);
4031   qlfStartFile(state, sf);
4032 
4033   for(;;)
4034   { fid_t	 cid = PL_open_foreign_frame();
4035     term_t         t = PL_new_term_ref();
4036     term_t directive = PL_new_term_ref();
4037     atom_t eof;
4038 
4039     DEBUG(2, Sdprintf("pl_read_clause() -> "));
4040     PL_put_variable(t);
4041     if ( !read_clause(Scurin, t, 0 PASS_LD) ) /* syntax error */
4042     { Sdprintf("%s:%d: Syntax error\n",
4043 	       PL_atom_chars(source_file_name),
4044 	       source_line_no);
4045       continue;
4046     }
4047     if ( PL_get_atom(t, &eof) && eof == ATOM_end_of_file )
4048       break;
4049 
4050     DEBUG(MSG_QLF_BOOT_READ,
4051 	  PL_write_term(Serror, t, 1200, PL_WRT_NUMBERVARS);
4052 	  Sdprintf("\n"));
4053 
4054     if ( directiveClause(directive, t, ":-") )
4055     { DEBUG(MSG_QLF_DIRECTIVE,
4056 	    Sdprintf(":- ");
4057 	    PL_write_term(Serror, directive, 1200, 0);
4058 	    Sdprintf(".\n") );
4059       addDirectiveWic(state, directive PASS_LD);
4060       if ( !callProlog(MODULE_user, directive, PL_Q_NODEBUG, NULL) )
4061 	Sdprintf("%s:%d: directive failed\n",
4062 		 PL_atom_chars(source_file_name),
4063 		 source_line_no);
4064     } else if ( directiveClause(directive, t, "$:-") )
4065     { DEBUG(MSG_QLF_DIRECTIVE,
4066 	    Sdprintf("$:- ");
4067 	    PL_write_term(Serror, directive, 1200, 0);
4068 	    Sdprintf(".\n"));
4069       callProlog(MODULE_user, directive, PL_Q_NODEBUG, NULL);
4070     } else
4071       addClauseWic(state, t, nf PASS_LD);
4072 
4073     PL_discard_foreign_frame(cid);
4074   }
4075 
4076   qlfEndPart(state);
4077   pl_seen();
4078 
4079   succeed;
4080 }
4081 
4082 
4083 bool
compileFileList(IOSTREAM * fd,int argc,char ** argv)4084 compileFileList(IOSTREAM *fd, int argc, char **argv)
4085 { GET_LD
4086   wic_state *state = allocHeapOrHalt(sizeof(*state));
4087   predicate_t pred;
4088   int rc;
4089   access_level_t alevel;
4090 
4091   memset(state, 0, sizeof(*state));
4092   state->wicFd = fd;
4093 
4094   if ( !writeWicHeader(state) )
4095     return FALSE;
4096 
4097   alevel = setAccessLevel(ACCESS_LEVEL_SYSTEM);
4098   PL_set_prolog_flag("autoload", PL_BOOL, FALSE);
4099 
4100   LD->qlf.current_state = state; /* make Prolog compilation go into state */
4101   for(;argc > 0; argc--, argv++)
4102   { if ( streq(argv[0], "-c" ) )
4103       break;
4104     if ( !compileFile(state, argv[0]) )
4105       return FALSE;
4106   }
4107 
4108   PL_set_prolog_flag("autoload", PL_BOOL, TRUE);
4109   setAccessLevel(alevel);
4110 
4111   pred = PL_predicate("$load_additional_boot_files", 0, "user");
4112   rc = PL_call_predicate(MODULE_user, TRUE, pred, 0);
4113   if ( rc )
4114     rc = writeWicTrailer(state);
4115 
4116   LD->qlf.current_state = NULL;
4117   freeHeap(state, sizeof(*state));
4118 
4119   return rc;
4120 }
4121 
4122 
4123 		 /*******************************
4124 		 *	     CLEANUP		*
4125 		 *******************************/
4126 
4127 void
qlfCleanup(void)4128 qlfCleanup(void)
4129 { GET_LD
4130   wic_state *state;
4131   char *buf;
4132 
4133   while ( (state=LD->qlf.current_state) )
4134   { if ( state->mkWicFile )
4135     { if ( !printMessage(ATOM_warning,
4136 			 PL_FUNCTOR_CHARS, "qlf", 1,
4137 			   PL_FUNCTOR_CHARS, "removed_after_error", 1,
4138 			     PL_CHARS, state->mkWicFile) )
4139 	PL_clear_exception();
4140       RemoveFile(state->mkWicFile);
4141       remove_string(state->mkWicFile);
4142       state->mkWicFile = NULL;
4143     }
4144 
4145     LD->qlf.current_state = state->parent;
4146     freeHeap(state, sizeof(*state));
4147   }
4148 
4149   if ( (buf=LD->qlf.getstr_buffer) )
4150   { LD->qlf.getstr_buffer = NULL;
4151     LD->qlf.getstr_buffer_size = 0;
4152     free(buf);
4153   }
4154 }
4155 
4156 		 /*******************************
4157 		 *	 PUBLIC FUNCTIONS	*
4158 		 *******************************/
4159 
4160 void
wicPutStringW(const pl_wchar_t * w,size_t len,IOSTREAM * fd)4161 wicPutStringW(const pl_wchar_t *w, size_t len, IOSTREAM *fd)
4162 { putStringW(w, len, fd);
4163 }
4164 
4165 
4166 		 /*******************************
4167 		 *      PUBLISH PREDICATES	*
4168 		 *******************************/
4169 
4170 BeginPredDefs(wic)
4171   PRED_DEF("$qlf_info",		    7, qlf_info,	     0)
4172   PRED_DEF("$qlf_sources",	    2, qlf_sources,	     0)
4173   PRED_DEF("$qlf_load",		    2, qlf_load,	     PL_FA_TRANSPARENT)
4174   PRED_DEF("$add_directive_wic",    1, add_directive_wic,    PL_FA_TRANSPARENT)
4175   PRED_DEF("$qlf_start_module",	    1, qlf_start_module,     0)
4176   PRED_DEF("$qlf_start_sub_module", 1, qlf_start_sub_module, 0)
4177   PRED_DEF("$qlf_start_file",	    1, qlf_start_file,	     0)
4178   PRED_DEF("$qlf_current_source",   1, qlf_current_source,   0)
4179   PRED_DEF("$qlf_include",          5, qlf_include,          0)
4180   PRED_DEF("$qlf_end_part",	    0, qlf_end_part,	     0)
4181   PRED_DEF("$qlf_open",		    1, qlf_open,	     0)
4182   PRED_DEF("$qlf_close",	    0, qlf_close,	     0)
4183   PRED_DEF("$qlf_assert_clause",    2, qlf_assert_clause,    0)
4184   PRED_DEF("$open_wic",		    2, open_wic,	     0)
4185   PRED_DEF("$close_wic",	    0, close_wic,	     0)
4186   PRED_DEF("$map_id",               2, map_id,		     0)
4187   PRED_DEF("$unmap_id",             1, unmap_id,             0)
4188   PRED_DEF("$import_wic",	    3, import_wic,	     0)
4189 EndPredDefs
4190