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