1/* BEGIN LICENSE BLOCK
2 * Version: CMPL 1.1
3 *
4 * The contents of this file are subject to the Cisco-style Mozilla Public
5 * License Version 1.1 (the "License"); you may not use this file except
6 * in compliance with the License.  You may obtain a copy of the License
7 * at www.eclipse-clp.org/license.
8 *
9 * Software distributed under the License is distributed on an "AS IS"
10 * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied.  See
11 * the License for the specific language governing rights and limitations
12 * under the License.
13 *
14 * The Original Code is  The ECLiPSe Constraint Logic Programming System.
15 * The Initial Developer of the Original Code is  Cisco Systems, Inc.
16 * Portions created by the Initial Developer are
17 * Copyright (C) 1989-2006 Cisco Systems, Inc.  All Rights Reserved.
18 *
19 * Contributor(s):
20 *
21 * END LICENSE BLOCK */
22
23/*
24 * VERSION	$Id: procedure.c,v 1.4 2012/02/11 17:09:31 jschimpf Exp $
25 *
26 * IDENTIFICATION		procedure.c
27 *
28 * DESCRIPTION
29 *
30 *	Used to contain the ECLiPSe compiler, now only .eco boot loader.
31 *
32 * CONTENTS:
33 *
34 * AUTHOR	VERSION	 DATE	REASON
35 * Micha Meier	1.0		created the file
36 * Micha Meier	2.2	20.7.89	rewritten for the new compiler
37 */
38
39 /*
40  * INCLUDES:
41  */
42#include	"config.h"
43#include	"sepia.h"
44#include	"types.h"
45#include        "embed.h"
46#include 	"error.h"
47#include	"mem.h"
48#include	"dict.h"
49#include	"emu_export.h"
50#include	"property.h"
51#include	"ec_io.h"
52#include	"read.h"
53#include	"module.h"
54
55
56/*
57 * DEFINES:
58 */
59#define Query(did)		((did == d_.rulech1 || did == d_.goalch))
60
61
62 /*
63  * EXTERNAL VARIABLE DEFINITIONS:
64  */
65
66static dident
67		d_module2,
68		d_module3,
69		d_module_interface,
70		d_begin_module,
71		d_create_module3_,
72		d_erase_module_,
73		d_eclipse_language_;
74
75dident
76		d_call_susp_;
77
78pword		woken_susp_;
79
80
81/*
82 * Check whether the next len characters in stream nst match header[].
83 * If yes, skip them, otherwise don't advance the stream pointer.
84 */
85
86static int
87_skip_header_if_present(stream_id nst, char *header, int len)
88{
89    int i, res;
90
91    if (IsTty(nst))
92    {
93	/* Don't expect headers on a tty. This fixes bug 473 (having
94	 * to type CTRL-D 3 times to get out of the [user] prompt)  */
95    	return PFAIL;
96    }
97    for (i=0; i<len; ++i)
98    {
99	res = ec_getch(nst);
100	if (res < 0  ||  (char) res != header[i])
101	{
102	    /* header doesn't match: unget everything */
103	    while(i-- >= 0)
104	    	ec_ungetch(nst);
105	    return PFAIL;
106	}
107    }
108    return PSUCCEED;
109}
110
111
112/*
113 * Source files may start with a UTF-8 Byte-Order-Mark, which we want to skip
114 */
115
116#define UTF8_BOM_LENGTH	3
117static char utf8_bom[UTF8_BOM_LENGTH] = {'\357','\273','\277'};
118
119
120/*
121 * Current eco file version. This must correspond to
122 * the number in dump_header/1 in the file io.pl.
123 */
124#define ECO_CURRENT_VERSION	0x17
125
126#define MAGIC_LEN 3
127static char eco_magic[MAGIC_LEN] = {'\354','\034','\051'};
128
129static int
130_read_eco_header(stream_id nst)
131{
132    int i, res;
133    /*
134     * temporarily limit buffering to the header size because
135     * we may have to switch to SSCRAMBLE mode for the rest!
136     */
137    int bufsize = StreamSize(nst);
138    StreamSize(nst) = MAGIC_LEN+1;
139
140    /* check for eco header and skip if present */
141    res = _skip_header_if_present(nst, eco_magic, MAGIC_LEN);
142    StreamSize(nst) = bufsize;
143    if (res != PSUCCEED)
144    	return PFAIL;
145
146    /* next byte indicates the eco version */
147    res = ec_getch(nst);
148    if (res < 0)
149    	return res;
150    if (res != ECO_CURRENT_VERSION)
151	return BAD_DUMP_VERSION;
152
153    StreamMode(nst) |= SSCRAMBLE;
154    StreamRand(nst) = 73540 ^ 0x9bc33c86;
155
156    /* read the rest of the header */
157    for(i=0; i<8; ++i)
158    	res = ec_getch(nst);
159    return res < 0 ? res : PSUCCEED;
160}
161
162
163void
164compiler_init(int flags)
165{
166    if (flags & INIT_SHARED)
167    {
168	CompileId = 0;
169    }
170
171    d_call_susp_ = in_dict("call_suspension", 1);
172    d_module2 = in_dict("module", 2);
173    d_module3 = in_dict("module", 3);
174    d_module_interface = in_dict("module_interface", 1);
175    d_begin_module = in_dict("begin_module", 1);
176    d_erase_module_ = in_dict("erase_module", 1);
177    d_create_module3_ = in_dict("create_module", 3);
178    d_eclipse_language_ = in_dict("eclipse_language", 0);
179
180
181    /*
182     * A suspension which is marked as dead. Any suspension that occurs
183     * in a compiled clause is compiled into a TSUSP pointer to this one.
184     */
185    Init_Susp_Dead(&woken_susp_);
186}
187
188
189
190#ifdef PRINTAM
191void
192print_procedure(dident wdid, vmcode *code)
193{
194	extern int	als(word addr);
195
196	p_fprintf(current_output_, "\n%s/", DidName(wdid));
197	p_fprintf(current_output_, "%d:\n", DidArity(wdid));
198
199	(void) als((word) code);
200	ec_flush(current_output_);
201}
202#endif
203
204
205
206
207/***********************************************************************
208 * Load an .eco file
209 *
210 * An .eco file contains only directives
211 * Only module directives are treated specially here
212 * Pragmas are ignored for backward compatibility (they should not occur)
213 * The calling module is passed in *module, and the current module
214 * at the end of the eco file is returned in *module.
215 ***********************************************************************/
216
217int
218ec_load_eco_from_stream(stream_id nst, int options, pword *module)
219{
220    int res;
221    pword *clause, *query, *pw;
222    pword query_pw, kernel_pw;
223    pword top_module = *module;
224    int encoded = 0;
225
226    /* we are expecting an eco-encoded file, but we allow text as well */
227    res = _read_eco_header(nst);
228    encoded = (res == PSUCCEED);
229    StreamMode(nst) |= SNOMACROEXP; /* to avoid problems in text-eco files */
230    kernel_pw.val.did = d_.kernel_sepia;
231    kernel_pw.tag.kernel = ModuleTag(d_.kernel_sepia);
232
233    for(;;)
234    {
235	int recreate_module = 0;
236	pword exports_pw, language_pw;
237	pword *new_module = 0;
238
239	if (encoded)			/* encoded dbformat */
240	{
241	    int n;
242	    word nread;
243
244	    char *s = ec_getstring(nst, 4, &nread);
245	    if (!(s))
246		return nread;	/* error code */
247	    if (nread < 4)
248		return (nread == 0) ? PSUCCEED : UNEXPECTED_EOF;
249
250	    n = (unsigned char) *s++ << 24;
251	    n |= (unsigned char) *s++ << 16;
252	    n |= (unsigned char) *s++ << 8;
253	    n |= (unsigned char) *s;
254	    s = ec_getstring(nst, n, &nread);
255	    if (!(s))
256		return nread;	/* error code */
257	    if (nread < n)
258		return UNEXPECTED_EOF;
259
260	    clause = dbformat_to_term(s, module->val.did, module->tag);
261	    if (!clause)
262		return NOT_DUMP_FILE;
263	}
264	else				/* text format, call the parser */
265	{
266	    res = ec_read_term(nst,
267    		(GlobalFlags & VARIABLE_NAMES ? VARNAMES_PLEASE : 0),
268		&query_pw, 0, 0, module->val, module->tag);
269	    if (res != PSUCCEED)
270	    	return (res == PEOF) ? PSUCCEED : NOT_DUMP_FILE;
271
272	    clause = &query_pw;
273	}
274
275	Dereference_(clause);
276	if (!IsStructure(clause->tag) || !Query(clause->val.ptr->val.did))
277	    return NOT_DUMP_FILE;
278
279	pw = query = clause->val.ptr + 1;
280	Dereference_(pw);
281	if (IsStructure(pw->tag))	/* look for special directives */
282	{
283	    if (pw->val.ptr->val.did == d_.module1)
284	    {
285		recreate_module = 1;
286		new_module = &pw->val.ptr[1];
287		Make_Nil(&exports_pw);
288		Make_Atom(&language_pw, d_eclipse_language_);
289	    }
290	    if (pw->val.ptr->val.did == d_module_interface)
291	    {
292		recreate_module = 1;
293		new_module = &pw->val.ptr[1];
294		Make_Nil(&exports_pw);
295		Make_Atom(&language_pw, d_eclipse_language_);
296	    }
297	    else if (pw->val.ptr->val.did == d_module2)
298	    {
299		recreate_module = 1;
300		new_module = &pw->val.ptr[1];
301		exports_pw = pw->val.ptr[2];
302		Make_Atom(&language_pw, d_eclipse_language_);
303	    }
304	    else if (pw->val.ptr->val.did == d_module3)
305	    {
306		recreate_module = 1;
307		new_module = &pw->val.ptr[1];
308		exports_pw = pw->val.ptr[2];
309		language_pw = pw->val.ptr[3];
310	    }
311	    else if (pw->val.ptr->val.did == d_begin_module)
312	    {
313		new_module = &pw->val.ptr[1];
314		query = &query_pw;	/* don't execute anything */
315		Make_Atom(query, d_.true0);
316	    }
317	    else if (pw->val.ptr->val.did == d_.pragma)
318	    {
319		query = &query_pw;	/* ignore pragmas, replace with true */
320		Make_Atom(query, d_.true0);
321	    }
322	}
323	else if (pw->val.did == d_.system || pw->val.did == d_.system_debug)
324	{
325	    query = &query_pw;	/* ignore pragmas, replace with true */
326	    Make_Atom(query, d_.true0);
327	}
328
329	if (recreate_module)		/* build translated module query */
330	{
331	    pword *pgoal, *pcont;
332	    query = &query_pw;
333	    Make_Struct(query, TG);
334	    /* If module changes, raise CODE_UNIT_LOADED event first */
335	    if (module->val.did != top_module.val.did)
336	    {
337		pcont = TG;
338		Push_Struct_Frame(d_.comma);
339		Make_Struct(&pcont[1], TG);
340		pgoal = TG;
341		Push_Struct_Frame(d_.syserror);
342		Make_Integer(&pgoal[1], CODE_UNIT_LOADED);
343		Make_Atom(&pgoal[2], d_.eof);
344		pgoal[3] = *module;
345		pgoal[4] = *module;
346		Make_Struct(&pcont[2], TG);
347	    }
348	    pcont = TG;
349	    Push_Struct_Frame(d_.comma);
350	    Make_Struct(&pcont[1], TG);
351	    pgoal = TG;
352	    Push_Struct_Frame(d_erase_module_);
353	    pgoal[1] = *new_module;
354	    Make_Struct(&pcont[2], TG);
355	    pgoal = TG;
356	    Push_Struct_Frame(d_create_module3_);
357	    pgoal[1] = *new_module;
358	    pgoal[2] = exports_pw;
359	    pgoal[3] = language_pw;
360
361	    res = query_emulc(query->val, query->tag, kernel_pw.val, kernel_pw.tag);
362	}
363	else
364	{
365	    /* execute the query/directive */
366	    res = query_emulc(query->val, query->tag, module->val, module->tag);
367	}
368
369	if (res != PSUCCEED)
370	{
371	    pw = TG;
372	    Push_Struct_Frame(d_.syserror);
373	    Make_Integer(&pw[1], QUERY_FAILED);
374	    pw[2] = *query;
375	    pw[3] = *module;
376	    pw[4] = *module;
377	    query = &query_pw;
378	    Make_Struct(query, pw);
379	    (void) query_emulc(query->val, query->tag, kernel_pw.val, kernel_pw.tag);
380	}
381
382	if (new_module)			/* change to new context module */
383	{
384	    Dereference_(new_module);
385	    *module = *new_module;
386	}
387    }
388    return PSUCCEED;
389}
390
391