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 * SEPIA C SOURCE MODULE 25 * 26 * VERSION $Id: write.c,v 1.17 2015/01/14 01:31:09 jschimpf Exp $ 27 */ 28 29/* 30 * IDENTIFICATION write.c 31 * 32 * DESCRIPTION: SEPIA terminal input/output routines 33 * by Dominique Henry de Villeneuve 34 * 35 * CONTENTS: write/1,2 36 * writeq/1,2 37 * write_canonical/1,2 38 * print/1,2 39 * printf_/4 40 * display/1 41 * depth/1 42 * 43 */ 44 45/* 46 * INCLUDES: 47 */ 48 49#include "config.h" 50#include <math.h> 51#include <stdio.h> 52#include "sepia.h" 53#include "types.h" 54#include "embed.h" 55#include "mem.h" 56#include "error.h" 57#include "dict.h" 58#include "lex.h" 59#include "ec_io.h" 60#include "emu_export.h" 61#include "module.h" 62#include "property.h" 63 64#ifdef STDC_HEADERS 65#include <stdlib.h> 66#endif 67 68#if STDC_HEADERS || HAVE_STRING_H 69# include <string.h> 70#else 71# include <strings.h> 72# define strchr index 73#endif 74 75#ifdef HAVE_CTYPE_H 76#include <ctype.h> 77#endif 78 79 80/* 81 * DEFINES 82 */ 83 84#define ATOM 0 85#define OPERATOR 1 86 87#define WRITE_OPTIONS_WRITE (OUT_DOLLAR_VAR) 88#define WRITE_OPTIONS_PRINT (OUT_DOLLAR_VAR|PRINT_CALL) 89#define WRITE_OPTIONS_DISPLAY (CANONICAL|DOTLIST) 90#define WRITE_OPTIONS_WRITEQ (QUOTED|FULLDEPTH|VAR_NUMBERS|STD_ATTR|NO_MACROS|OUT_DOLLAR_VAR) 91#define WRITE_OPTIONS_CANON (QUOTED|FULLDEPTH|VAR_NUMBERS|STD_ATTR|NO_MACROS|CANONICAL|DOTLIST) 92 93#define UseDepth(id) (!((id) & FULLDEPTH)) 94 95#define MacrosAllowed(idwrite) (!((idwrite) & NO_MACROS)) 96#define GoalMacro(idwrite) (idwrite & WRITE_GOAL ? TR_GOAL : \ 97 (idwrite & WRITE_CLAUSE ? TR_CLAUSE : 0)) 98 99#define Handle_Type_Macro(t) \ 100 if (MacrosAllowed(idwrite) && DidMacro(TransfDid(t))) { \ 101 pword *tr_res = _write_trafo(TransfDid(t), \ 102 GoalMacro(idwrite), \ 103 &idwrite, val, tag, module, mod_tag); \ 104 if (tr_res) { \ 105 val.all = tr_res->val.all; \ 106 tag.all = tr_res->tag.all; \ 107 goto _pwrite_; /* print the transformed term */ \ 108 } \ 109 } 110 111/* 112 * FUNCTION DECLARATIONS: 113 */ 114 115int 116 p_write3(value vals, type tags, value val, type tag, value vm, type tm), 117 p_writeq3(value vals, type tags, value val, type tag, value vm, type tm); 118 119static int 120 p_write(value val, type tag, value vm, type tm), 121 p_writeln(value vals, type tags, value val, type tag, value vm, type tm), 122 p_writeq(value val, type tag, value vm, type tm), 123 p_print(value val, type tag, value vm, type tm), 124 p_print3(value vals, type tags, value val, type tag, value vm, type tm), 125 p_printf5(value vs, type ts, value strval, type strtag, value lval, type ltag, value vm, type tm, value vfc, type tfc, value vse, type tse, value vle, type tle, value verr, type terr), 126 p_write_canonical(value val, type tag, value vm, type tm), 127 p_write_canonical3(value vals, type tags, value val, type tag, value vm, type tm), 128 p_write_term(value vs, type ts, value val, type tag, value vcm, type tcm, value vsm, type tsm, value vdepth, type tdepth, value vprec, type tprec, value vm, type tm), 129 p_display(value vs, type ts, value val, type tag), 130 p_output_mode(value val, type tag), 131 p_output_mode_mask(value val, type tag), 132 133 _get_mode_mask(char *string, int *clr_mask, int *mask), 134 _merge_output_modes(int mask, int remove, int add), 135 _handle_string_size(value v, type t, int quoted_or_base), 136 _handle_to_string(value v, type t, char *buf, int quoted_or_base), 137 _num_string_size(value v, type t, int quoted), 138 _int_to_string(value v, type t, char *buf, int quoted_or_base), 139 _float_to_string(value v, type t, char *buf, int precise), 140 _float_to_string_opt(value v, type t, char *buf, int precise, int options), 141 _printf_asterisk(word asterisk, pword **list, type arg_type, stream_id nst, char *par), 142 _print_var(int idwrite, value v, type t, stream_id str, int depth, dident module, type mod_tag, syntax_desc *sd), 143 _pwrite1(int idwrite, stream_id out, value val, type tag, int maxprec, int depth, dident module, type mod_tag, syntax_desc *sd, register int flags), 144 _is_proper_list(pword *list), 145 _write_args_from_list(int idwrite, stream_id out, pword *list, int depth, dident module, type mod_tag, syntax_desc *sd, int flags), 146 _write_quoted(int idwrite, stream_id out, char *name, register word len, char quotechar, syntax_desc *sd, int depth), 147 _write_infix(int idwrite, stream_id out, dident d, register int flags, dident module, type mod_tag, syntax_desc *sd, pword *right, int depth), 148 _write_atom(int idwrite, stream_id out, dident d, int what, int flag, dident module, type mod_tag, syntax_desc *sd, int depth), 149 _write_string(int idwrite, stream_id out, char *start, word length, int depth), 150 _portray_term(int idwrite, stream_id out, value val, type tag, dident module, type mod_tag); 151 152static void _output_mode_string(char *s, int mask); 153 154static pword *_write_trafo(dident d, int flags, int *idwrite, value val, type tag, dident module, type mod_tag); 155 156 157/* 158 * EXTERNAL VARIABLE DECLARATIONS: 159 */ 160 161extern pword *transf_meta_out(value val, type tag, pword *top, dident mod, pword *presult); 162extern pword *p_meta_arity_; 163 164 165/* 166 * STATIC VARIABLE DEFINITIONS: 167 */ 168 169static dident d_dollar_var, 170 d_portray1, 171 d_portray2, 172 d_print_attributes, 173 d_var_name, 174 d_vname2; 175 176static char output_mode_chars[OUTPUT_MODES+1] = "OD.QvVPKmGMTCN_IUFL"; 177 178static int output_mode_mask = QUOTED | PRINT_CALL | ATTRIBUTE; 179 180 181 /* 182 * FUNCTION DEFINITIONS: 183 */ 184 185/* 186 * FUNCTION NAME: 187 * 188 * PARAMETERS: 189 * 190 * DESCRIPTION: 191 */ 192 193void 194write_init(int flags) 195{ 196 d_portray1 = in_dict("portray", 1); 197 d_portray2 = in_dict("portray", 2); 198 d_dollar_var = in_dict("$VAR", 1); 199 d_print_attributes = in_dict("print_attributes", 2); 200 d_var_name = in_dict("var_name", 0); 201 d_vname2 = in_dict("vname", 2); 202 203 tag_desc[TINT].string_size = _num_string_size; 204 tag_desc[TINT].to_string = _int_to_string; 205 tag_desc[TDBL].string_size = _num_string_size; 206 tag_desc[TDBL].to_string = _float_to_string; 207 tag_desc[THANDLE].string_size = _handle_string_size; 208 tag_desc[THANDLE].to_string = _handle_to_string; 209 210 if (!(flags & INIT_SHARED)) 211 return; 212 213 PrintDepth = 20; 214 215 (void) exported_built_in(in_dict("write_", 2), p_write, B_SAFE); 216 (void) exported_built_in(in_dict("writeq_", 2), p_writeq, B_SAFE); 217 (void) exported_built_in(in_dict("print_", 2), p_print, B_SAFE); 218 (void) exported_built_in(in_dict("write_canonical_", 2), p_write_canonical, B_SAFE); 219 (void) exported_built_in(in_dict("print_", 3), p_print3, B_SAFE); 220 (void) exported_built_in(in_dict("printf_", 8), p_printf5, B_SAFE); 221 (void) exported_built_in(in_dict("write_", 3), p_write3, B_SAFE); 222 (void) local_built_in(in_dict("writeln_body", 3), p_writeln, B_SAFE); 223 (void) exported_built_in(in_dict("writeq_", 3), p_writeq3, B_SAFE); 224 (void) exported_built_in(in_dict("write_canonical_", 3), p_write_canonical3, B_SAFE); 225 (void) exported_built_in(in_dict("write_term", 7), p_write_term, B_SAFE); 226 (void) built_in(in_dict("display", 2), p_display, B_SAFE); 227 (void) local_built_in(in_dict("output_mode", 1), p_output_mode, B_UNSAFE|U_SIMPLE); 228 (void) local_built_in(in_dict("output_mode_mask", 1), p_output_mode_mask, B_UNSAFE|U_SIMPLE); 229} 230 231 232/* 233 * visible_d_procedure() is the same as visible_procedure() except that 234 * it only returns something if there is a CODE_DEFINED (callable) 235 * procedure. It also does not set global_bip_error. 236*/ 237static pri * 238visible_d_procedure(dident functor, dident module, type module_tag) 239{ 240 pri *pd = visible_procedure(functor, module, module_tag, 0); 241 if (!pd) 242 { 243 Set_Bip_Error(0); 244 return 0; 245 } 246 return PriFlags(pd) & CODE_DEFINED ? pd : 0; 247} 248 249 250#define Check_Stream(out, res) \ 251 if (out == NO_STREAM) { Bip_Error(res) } \ 252 if (!(IsWriteStream(out))) { Bip_Error(STREAM_MODE) } 253 254#define Write_Infix(ww, s, d, flags, mod, mt, sd, arg, narg) \ 255 status = _write_infix(ww, s, d, flags, mod, mt, sd, narg, depth);\ 256 if (status < 0) \ 257 return(status); 258 259#define Write_Postfix(ww, s, d, flags, mod, mt, sd) \ 260 if((status = ec_outfc( s, ' ')) < 0 || \ 261 (status = _write_atom(ww, s, d, OPERATOR, flags, mod, mt, sd, depth)) < 0) \ 262 return(status); 263 264#define Write_Prefix(ww, s, d, flags, mod, mt, sd) \ 265 if((status = _write_atom(ww, s, d, OPERATOR, flags, mod, mt, sd, depth)) < 0 || \ 266 (status = ec_outfc( s, ' ')) < 0) return(status); 267 268#define Write_Atom(ww, s, d, what, flags, mod, mt, sd) \ 269 if((status = _write_atom(ww, s, d, what, flags, mod, mt, sd, depth)) < 0) \ 270 return(status); 271 272#define Pwrite(ww, s, v, t, mp, d, mod, mt, sd, flags) \ 273 if((status = _pwrite1(ww, s, v, t, mp, d, mod, mt, sd, flags)) < 0) \ 274 return(status); 275 276#define Write_Char(s,c) if ((status = ec_outfc(s,c)) < 0) return(status); 277 278#define Write_Str(s,str,l) if ((status = ec_outf(s,str,l)) < 0) return(status); 279 280#define Write_Comma(s) \ 281 Write_Char(s, ','); \ 282 if (!(idwrite & WRITE_COMPACT)) { Write_Char(s, ' '); } 283 284#define Next_Element(element, list, Return) \ 285 { \ 286 if (list) \ 287 { \ 288 element = list++; \ 289 Dereference_(list) \ 290 Dereference_(element) \ 291 if (IsNil(list->tag)) \ 292 list = 0; \ 293 else if (!IsList(list->tag)) { \ 294 Return(TYPE_ERROR); \ 295 } \ 296 else { \ 297 list = list->val.ptr; \ 298 } \ 299 } \ 300 else { \ 301 Return(BAD_ARGUMENT_LIST); \ 302 } \ 303 } 304 305#define Get_Counter(start,ptr,c) \ 306 c = 0; \ 307 ptr = start; \ 308 while (*(ptr) >= '0' && *(ptr) <= '9') \ 309 c = c * 10 + *(ptr)++ - '0'; 310 311 312#define MAXPREC ((sd->options & LIMIT_ARG_PRECEDENCE) ? 999 : 1200) 313 314 315/* 316 write_(Term, Module) 317 writes the Prolog term (tag,val) to the current output stream. 318 The term is written according to the current operator 319 declarations and spaces are inserted to separate operators 320 where necessary. 321 Functors, atoms and strings are not quoted. 322*/ 323static int 324p_write(value val, type tag, value vm, type tm) 325{ 326 int res; 327 Check_Module(tm, vm); 328 Lock_Stream(current_output_); 329 res = ec_pwrite(0, WRITE_OPTIONS_WRITE, current_output_, val, tag, 1200, 0, vm.did, tm); 330 Unlock_Stream(current_output_); 331 return res; 332} 333 334/* 335 writeq_(Term, Module) 336 The Prolog term is written to the current output stream 337 according to the current operator declarations. 338 Functors, atoms and strings are quoted. 339*/ 340static int 341p_writeq(value val, type tag, value vm, type tm) 342{ 343 int res; 344 Check_Module(tm, vm); 345 Lock_Stream(current_output_); 346 if (IsAtom(tag) && val.did == d_.eocl) 347 res = ec_outf(current_output_, "'.'", 3); 348 else 349 res = ec_pwrite(0, WRITE_OPTIONS_WRITEQ, 350 current_output_, val, tag, 1200, 0, vm.did, tm); 351 Unlock_Stream(current_output_); 352 return res; 353} 354 355 356/* 357 writeq_(Stream, Term, Module) 358*/ 359int 360p_writeq3(value vals, type tags, value val, type tag, value vm, type tm) 361{ 362 int res; 363 stream_id out = get_stream_id(vals, tags, SWRITE, &res); 364 365 Check_Stream(out, res); 366 Check_Module(tm, vm); 367 Lock_Stream(out); 368 if (IsAtom(tag) && val.did == d_.eocl) 369 res = ec_outf(out, "'.'", 3); 370 else 371 res = ec_pwrite(0, WRITE_OPTIONS_WRITEQ, 372 out, val, tag, 1200, 0, vm.did, tm); 373 Unlock_Stream(out); 374 return res; 375} 376 377/* 378 write_canonical_(Term, Module) 379*/ 380static int 381p_write_canonical(value val, type tag, value vm, type tm) 382{ 383 int res; 384 Check_Module(tm, vm); 385 Lock_Stream(current_output_); 386 if (IsAtom(tag) && val.did == d_.eocl) 387 res = ec_outf(current_output_, "'.'", 3); 388 else 389 res = ec_pwrite(0, WRITE_OPTIONS_CANON, 390 current_output_, val, tag, 1200, 0, vm.did, tm); 391 Unlock_Stream(current_output_); 392 return res; 393} 394 395/* 396 write_canonical_(Stream, Term, Module) 397*/ 398static int 399p_write_canonical3(value vals, type tags, value val, type tag, value vm, type tm) 400{ 401 int res; 402 stream_id out = get_stream_id(vals, tags, SWRITE, &res); 403 404 if (IsAtom(tag) && val.did == d_.eocl) 405 { 406 return(ec_outf(out, "'.'", 3)); 407 } 408 Check_Stream(out, res); 409 Check_Module(tm, vm); 410 Lock_Stream(out); 411 res = ec_pwrite(0, WRITE_OPTIONS_CANON, 412 out, val, tag, 1200, 0, vm.did, tm); 413 Unlock_Stream(out); 414 return res; 415} 416 417/* 418 write_(Stream, Term, Module) 419 writes the Prolog term (tag,val) to the specified output stream. 420 The term is written according to the current operator 421 declarations and spaces are inserted to separate operators 422 where necessary. 423*/ 424int 425p_write3(value vals, type tags, value val, type tag, value vm, type tm) 426{ 427 int res; 428 stream_id out = get_stream_id(vals, tags, SWRITE, &res); 429 430 Check_Stream(out, res); 431 Check_Module(tm, vm); 432 Lock_Stream(out); 433 res = ec_pwrite(0, WRITE_OPTIONS_WRITE, out, val, tag, 1200, 0, vm.did, tm); 434 Unlock_Stream(out); 435 return res; 436} 437 438 439/* 440 * writeln is in C because we want it atomic and the correct flushing 441 * behaviour (like nl) 442 */ 443static int 444p_writeln(value vals, type tags, value val, type tag, value vm, type tm) 445{ 446 int res; 447 stream_id out = get_stream_id(vals, tags, SWRITE, &res); 448 449 Check_Stream(out, res); 450 Check_Module(tm, vm); 451 Lock_Stream(out); 452 res = ec_pwrite(0, WRITE_OPTIONS_WRITE, out, val, tag, 1200, 0, vm.did, tm); 453 if (res == PSUCCEED) 454 res = ec_newline(out); 455 Unlock_Stream(out); 456 return res; 457} 458 459/* 460 print_(Term, Module) 461 writes the Prolog term (tag,val) using portray/1,2 if it exists. 462 The term is written according to the current operator 463 declarations and spaces are inserted to separate operators 464 where necessary. 465*/ 466static int 467p_print(value val, type tag, value vm, type tm) 468{ 469 int res; 470 471 Check_Module(tm, vm); 472 Lock_Stream(current_output_); 473 res = ec_pwrite(0, WRITE_OPTIONS_PRINT, current_output_, val, tag, 1200, 0, vm.did, tm); 474 Unlock_Stream(current_output_); 475 return res; 476} 477 478/* 479 print_(Stream, Term, Module) 480 writes the Prolog term (tag,val) to the specified output stream, 481 possibly using portray/1,2 to output it. 482 The term is written according to the current operator 483 declarations and spaces are inserted to separate operators 484 where necessary. 485*/ 486static int 487p_print3(value vals, type tags, value val, type tag, value vm, type tm) 488{ 489 int res; 490 stream_id out = get_stream_id(vals, tags, SWRITE, &res); 491 492 Check_Stream(out, res); 493 Check_Module(tm, vm); 494 Lock_Stream(out); 495 res = ec_pwrite(0, WRITE_OPTIONS_PRINT, out, val, tag, 1200, 0, vm.did, tm); 496 Unlock_Stream(out); 497 return res; 498} 499 500 501/* 502 * display(Stream, Term) 503 * The output is written (even for the operators) in functional form. 504 * Functors, atoms and strings are not quoted. 505*/ 506static int 507p_display(value vs, type ts, value val, type tag) 508{ 509 int res; 510 stream_id out = get_stream_id(vs, ts, SWRITE, &res); 511 512 Check_Stream(out, res); 513 /* the module tag is not meaningful here */ 514 Lock_Stream(out); 515 res = ec_pwrite(0, WRITE_OPTIONS_DISPLAY, 516 out, val, tag, 1200, 0, d_.default_module, tdict); 517 Unlock_Stream(out); 518 return res; 519} 520 521 522/* auxiliary for ec_pwrite(): terminate term with fullstop and/or newline */ 523 524static int 525_terminate_term(stream_id nst, int options, syntax_desc *sd) 526{ 527 int status; 528 if (options & TERM_FULLSTOP) 529 { 530 /* write a space if last character was a symbol */ 531 if (Symbol(sd->char_class[(unsigned char)StreamLastWritten(nst)])) 532 { 533 Write_Char(nst, ' '); 534 } 535 Write_Char(nst, '.'); 536 if (options & TERM_NEWLINE) 537 return ec_newline(nst); /* maybe YIELD_ON_FLUSH_REQ */ 538 else 539 return ec_outfc(nst, ' '); 540 } 541 else if (options & TERM_NEWLINE) 542 { 543 return ec_newline(nst); /* maybe YIELD_ON_FLUSH_REQ */ 544 } 545 return PSUCCEED; 546} 547 548 549/* 550 * ec_pwrite() - write a Prolog term 551 * 552 * When writing any meta variables are marked (tag is modified) these marks 553 * are trailed. This function is simply a wrapper round prwite1() which 554 * does initialisation and finalisation, while pwrite() is recursive. 555 */ 556int 557ec_pwrite(int mode_clr, int mode_set, stream_id out, value val, type tag, int maxprec, int depth, dident module, type mod_tag) 558{ 559 pword **old_tt = TT, *old_tg = TG, *old_ld = LD; 560 syntax_desc * sd = ModuleSyntax(module); 561 int idwrite; 562 int result; 563 564 /* Catch null stream here because some code within _pwrite1() 565 * assumes the presence of a stream buffer! */ 566 if ((StreamMode(out) & STYPE) == SNULL) 567 return PSUCCEED; 568 569 if (!IsTextStream(out)) 570 return STREAM_MODE; 571 572 /* 573 * Merge the stream's default output mode settings with the modes 574 * for this particular call 575 */ 576 idwrite = _merge_output_modes(StreamOutputMode(out), mode_clr, mode_set); 577 578 /* 579 * For backward compatibility, map obsolete syntax options to output modes 580 */ 581 if (sd->options & DOLLAR_VAR) 582 idwrite |= OUT_DOLLAR_VAR; 583 /* not fully compatible: 584 if (sd->options & DENSE_OUTPUT) 585 idwrite |= WRITE_COMPACT; 586 */ 587 588 /* 589 * If 0, inherit print depth from stream or from global setting 590 * (if the FULLDEPTH flag is set, this is irrelevant) 591 */ 592 if (depth == 0) 593 { 594 depth = StreamPrintDepth(out); 595 if (depth == 0) 596 depth = PrintDepth; 597 } 598 599 /* 600 * If the module is locked we cannot call any print handlers 601 * or look up the visible operators. 602 * In principle, we should also not see the locked module's 603 * syntax, but that may be unnecessarily restrictive. 604 */ 605 if (UnauthorizedAccess(module, mod_tag)) 606 idwrite = idwrite & ~(ATTRIBUTE|PORTRAY2|PORTRAY1|PRINT_CALL) 607 |NO_MACROS|CANONICAL; 608 609 /* 610 * If needed, do the expensive procedure lookups for portray/1,2 611 * here and set PORTRAY2 and PORTRAY1 flags accordingly. 612 */ 613 if (idwrite & PRINT_CALL) 614 { 615 if (visible_d_procedure(d_portray2, module, mod_tag)) 616 idwrite |= PORTRAY2; 617 if (visible_d_procedure(d_portray1, module, mod_tag)) 618 idwrite |= PORTRAY1; 619 } 620 621 result = _pwrite1(idwrite, out, val, tag, maxprec, depth, 622 module, mod_tag, sd, ARGLAST); 623 624 /* terminate the term, if requested */ 625 if (result == PSUCCEED) 626 result = _terminate_term(out, idwrite, sd); 627 628 /* 629 * Pop stuff that may have been left by write macros and 630 * untrail all marking that has been done during printing. 631 */ 632 Untrail_Variables(old_tt); TG = old_tg; LD = old_ld; 633 return result; 634 635} 636 637 638static int 639_is_signed_number(value v, type t) 640{ 641 pword sign; 642 int res = tag_desc[TagType(t)].arith_op[ARITH_SGN](v, &sign); 643 /* res can be ARITH_EXCEPTION for zero-spanning breals! */ 644 if (res != PSUCCEED) return 1; 645 if (sign.val.nint < 0) return 1; 646 if (sign.val.nint > 0) return 0; 647 648 /* deal with negative zeros */ 649 switch (TagType(t)) 650 { 651 case TDBL: 652 return PedanticZeroLess(Dbl(v),0.0); 653 case TIVL: 654 return PedanticZeroLess(IvlLwb(v.ptr),0.0); 655 } 656 return 0; 657} 658 659 660/* 661 * _pwrite1() - write a Prolog term 662 * 663 * idwrite: flags for the different write options (see ec_io.h) 664 * CANONICAL ignore operators 665 * FULLDEPTH ignore depth 666 * DOTLIST write lists in dot notation 667 * QUOTED print quotes when needed 668 * VAR_NUMBERS print var number only 669 * VAR_NAMENUM print var name (if available) and number 670 * VAR_ANON print var as _ 671 * PRINT_CALL print was called, use portray 672 * PORTRAY_VAR call portray even for variables 673 * WRITE_GOAL print with goal output macros 674 * ATTRIBUTE print attributes of metaterms in user format 675 * STD_ATTR print attributes of metaterms in standard format 676 * NO_MACROS don't apply write macros 677 * PORTRAY2 a portray/2 predicate exists 678 * PORTRAY1 a portray/1 predicate exists 679 * VARTERM print variables as '_'(...) 680 * flags: further context information for writeq 681 * ARGOP immediate argument of any operator 682 * ARGYF immediate argument of YF or YFX operator 683 * ARGLAST last term, i.e. a delimiter follows 684 * ARGLIST inside a bracketed list, used to handle 685 * bars that occur as atoms or operators 686 * ARGTERM inside a structure argument, used to handle 687 * commas that are not argument separators 688 * ARGSIGN term _textually_ follows a -/1 or +/1 689 * maxprec: the maximum precedence that may be printed without brackets 690 */ 691 692#define UnsignedNumberNeedsBrackets \ 693 ((idwrite & QUOTED) && (flags & ARGSIGN)) 694 695static int 696_pwrite1(int idwrite, stream_id out, value val, type tag, int maxprec, int depth, dident module, type mod_tag, syntax_desc *sd, register int flags) 697{ 698 register pword *arg; 699 register int status, arity; 700 register dident d; 701 opi *d_opi_desc; 702 int res; 703 704_pwrite_: 705 if (UseDepth(idwrite) && depth <= 0) 706 return (ec_outf(out, "...", 3)); 707 708 if (IsRef(tag)) 709 if ((idwrite & (PORTRAY2|PORTRAY1)) 710 && (idwrite & PORTRAY_VAR || IsMeta(tag)) 711 && _portray_term(idwrite, out, val, tag, module, mod_tag)) 712 return PSUCCEED; 713 else 714 { 715 return _print_var(idwrite, val.ptr->val, val.ptr->tag, out, depth, 716 module, mod_tag, sd); 717 } 718 else if ((idwrite & (PORTRAY2|PORTRAY1)) 719 && _portray_term(idwrite, out, val, tag, module, mod_tag)) 720 return PSUCCEED; 721 722 switch (TagType(tag)) 723 { 724 case TDICT: 725 Handle_Type_Macro(TDICT) 726 if (MacrosAllowed(idwrite) && DidMacro(val.did)) 727 { 728 pword *narg; 729 if ((narg = _write_trafo(val.did, GoalMacro(idwrite), 730 &idwrite, val, tag, module, mod_tag))) 731 { 732 val.all = narg->val.all; 733 tag.all = narg->tag.all; 734 idwrite &= ~(WRITE_GOAL|WRITE_CLAUSE); 735 goto _pwrite_; /* print the transformed term */ 736 } 737 } 738 return _write_atom(idwrite,out,val.did,ATOM,flags,module,mod_tag, sd, depth); 739 740 case TINT: 741 Handle_Type_Macro(TINT) 742 if (UnsignedNumberNeedsBrackets && (val.nint >= 0)) 743 return (p_fprintf(out, "(%" W_MOD "d)", val.nint)); 744 else 745 return (p_fprintf(out, "%" W_MOD "d", val.nint)); 746 747 case TDBL: 748 Handle_Type_Macro(TDBL) 749 { 750 char fbuf[32]; 751 int size = _float_to_string_opt(val, tag, fbuf, idwrite & QUOTED, sd->options); 752 if (UnsignedNumberNeedsBrackets && fbuf[0] != '-') 753 { 754 if ((status = ec_outfc(out, '(')) < 0 || 755 (status = ec_outf(out, fbuf, size)) < 0 || 756 (status = ec_outfc(out, ')')) < 0) 757 return status; 758 return status; 759 } 760 else 761 return ec_outf(out, fbuf, size); 762 } 763 764 case TSTRG: 765 Handle_Type_Macro(TSTRG) 766 return (idwrite & QUOTED) ? 767 _write_quoted(idwrite, out, StringStart(val), StringLength(val), 768 (char) sd->current_sq_char, sd, depth) : 769 _write_string(idwrite, out, StringStart(val), 770 StringLength(val), depth); 771 772 case TNIL: 773 Handle_Type_Macro(TDICT) 774 return (ec_outf(out, "[]", 2)); 775 776 case TEXTERN: /* shouldn't occur */ 777 return p_fprintf(out, "EXTERN_%" W_MOD "x", val.nint); 778 779 case TPTR: 780 return p_fprintf(out, "PTR_%" W_MOD "x", val.ptr); 781 782 case TSUSP: 783 Handle_Type_Macro(TSUSP) 784 if (!val.ptr) 785 return p_fprintf(out, "'SUSP-0-dead'"); 786 res = SuspDebugInvoc(val.ptr); 787 status = p_fprintf(out, "'SUSP-%s%d-%s'", 788 res ? "" : "_", res ? res : val.ptr - TG_ORIG, 789 SuspDead(val.ptr) ? "dead" : SuspScheduled(val.ptr) ? "sched" : "susp"); 790 if (status < 0) 791 return status; 792#if 0 793 if (SuspDead(val.ptr) || !(idwrite & QUOTED)) 794 return PSUCCEED; 795 arg = &val.ptr[SUSP_GOAL]; /* print: (Goal,Module) */ 796 arity = 2; 797 goto _write_args_; /* (arg,arity) */ 798#else 799 return PSUCCEED; 800#endif 801 802 case THANDLE: 803 Handle_Type_Macro(THANDLE) 804 if (ExternalClass(val.ptr)->to_string && ExternalData(val.ptr)) 805 { 806 int bufsize = 1 + (ExternalClass(val.ptr)->string_size)(ExternalData(val.ptr), idwrite"ED?1:0); 807 char *buf = (char *) hp_alloc_size(bufsize); 808 int len = (ExternalClass(val.ptr)->to_string)(ExternalData(val.ptr), buf, idwrite"ED?1:0); 809 status = ec_outf(out, buf, len); 810 hp_free_size((generic_ptr) buf, bufsize); 811 return status; 812 } 813 else 814 { 815 return p_fprintf(out, "'HANDLE'(16'%08x)", ExternalData(val.ptr)); 816 } 817 818 case TPROC: /* an atom goal in the compiler */ 819 return _write_atom(idwrite, out, PriDid((pri *) (val.ptr)), 820 ATOM,flags,module,mod_tag, sd, depth); 821 822 case TCOMP: 823 case TGRS: /* a ground structure in the compiler */ 824 if (val.ptr == 0) { /* e.g. default WL */ 825 return p_fprintf(out, "BAD_TERM_0x%" W_MOD "x_0x%" W_MOD "x", val.all, tag.all); 826 } 827 Handle_Type_Macro(TCOMP) 828 if (SameTypeC(val.ptr->tag, TPROC)) 829 { 830 /* We are inside the compiler, change TPROC to TDICT */ 831 d = PriDid((pri *) (val.ptr->val.ptr)); 832 } 833 else 834 d = val.ptr->val.did; /* did of the functor */ 835 arg = (val.ptr) + 1; 836_write_structure_: /* (d, arg) */ 837 arity = DidArity(d); 838 if (d == d_dollar_var && (idwrite & OUT_DOLLAR_VAR)) /* '$VAR'/1 */ 839 { 840 pword *narg = arg; 841 Dereference_(narg); 842 if (IsInteger(narg->tag) && narg->val.nint >= 0) { 843 if ((status = ec_outfc(out, 'A' + (char)(narg->val.nint % 26))) < 0) 844 return (status); 845 if (narg->val.nint / 26) 846 return p_fprintf(out, "%" W_MOD "d", narg->val.nint / 26); 847 return PSUCCEED; 848 } else if (!(sd->options & ISO_RESTRICTIONS)) { 849 switch (TagType(narg->tag)) { 850 case TSTRG: 851 return ec_outf(out, StringStart(narg->val), 852 (int) StringLength(narg->val)); 853 case TDICT: 854 return ec_outf(out, DidName(narg->val.did), 855 (int) DidLength(narg->val.did)); 856 case TNIL: 857 return ec_outf(out, "[]", 2); 858 } 859 } 860 /* else print the structure normally */ 861 } 862 if (!(idwrite & CANONICAL)) 863 { 864 dident hd = d; 865 if (d == d_.rulech2) { 866 pword *p = val.ptr + 1; 867 Dereference_(p); 868 if (IsAtom(p->tag)) 869 hd = p->val.did; 870 else if (IsStructure(p->tag)) 871 hd = p->val.ptr->val.did; 872 } 873 if (MacrosAllowed(idwrite) && DidMacro(hd)) /* output macros */ 874 { 875 pword *narg; 876 if ((narg = _write_trafo(hd, GoalMacro(idwrite), 877 &idwrite, val, tag, module, mod_tag))) 878 { 879 val.all = narg->val.all; 880 tag.all = narg->tag.all; 881 idwrite &= ~(WRITE_GOAL|WRITE_CLAUSE); 882 goto _pwrite_; /* print the transformed term */ 883 } 884 } 885 idwrite &= ~(WRITE_GOAL|WRITE_CLAUSE); 886 887 /* 888 * Check for all the functors that can have special syntax 889 */ 890 if (d == d_.nilcurbr1) /* special case {}/1 */ 891 { 892 if ((status = ec_outfc(out, '{')) < 0) 893 return (status); 894 Dereference_(arg); 895 status = _pwrite1(idwrite, out, arg->val, arg->tag, MAXPREC, 896 depth-1, module, mod_tag, sd, 0); 897 if (status < 0 || (status = ec_outfc(out, '}')) < 0) 898 return (status); 899 return (PSUCCEED); 900 } 901 else if (d == d_.subscript && !(sd->options & NO_ARRAY_SUBSCRIPTS )) 902 { 903 pword *arg1 = arg; 904 pword *arg2 = arg + 1; 905 Dereference_(arg1); 906 Dereference_(arg2); 907 if (IsList(arg2->tag) && (IsStructure(arg1->tag) || 908 IsRef(arg1->tag) && !IsMeta(arg1->tag) || 909 IsAtom(arg1->tag) && (sd->options & ATOM_SUBSCRIPTS))) 910 { 911 Pwrite(idwrite|CANONICAL, out, arg1->val, arg1->tag, MAXPREC, 912 depth, module, mod_tag, sd, flags); 913 Pwrite(idwrite, out, arg2->val, arg2->tag, MAXPREC, 914 depth, module, mod_tag, sd, flags); 915 return (PSUCCEED); 916 } 917 } 918 else if (d == d_.with_attributes2 && !(sd->options & NO_ATTRIBUTES)) 919 { 920 pword *arg1 = arg; 921 pword *arg2 = arg + 1; 922 Dereference_(arg1); 923 Dereference_(arg2); 924 if ((IsRef(arg1->tag) && !IsMeta(arg1->tag)) && _is_proper_list(arg2)) 925 { 926 Pwrite(idwrite, out, arg1->val, arg1->tag, MAXPREC, 927 depth, module, mod_tag, sd, ARGTERM | ARGLAST); 928 Write_Char(out, '{'); 929 status = _write_args_from_list(idwrite, out, arg2, depth, module, mod_tag, sd, flags); 930 if (status < 0) return status; 931 Write_Char(out, '}'); 932 return (PSUCCEED); 933 } 934 } 935 else if (d == d_.apply2 && (sd->options & VAR_FUNCTOR_IS_APPLY)) 936 { 937 pword *arg1 = arg; 938 pword *arg2 = arg + 1; 939 Dereference_(arg1); 940 Dereference_(arg2); 941 if ((IsRef(arg1->tag) && !IsMeta(arg1->tag)) && _is_proper_list(arg2)) 942 { 943 Pwrite(idwrite, out, arg1->val, arg1->tag, MAXPREC, 944 depth, module, mod_tag, sd, ARGTERM | ARGLAST); 945 Write_Char(out, '('); 946 status = _write_args_from_list(idwrite, out, arg2, depth, module, mod_tag, sd, flags); 947 if (status < 0) return status; 948 Write_Char(out, ')'); 949 return (PSUCCEED); 950 } 951 } 952 else if (d == d_.with2 && !(sd->options & NO_CURLY_ARGUMENTS)) 953 { 954 pword *arg1 = arg; 955 pword *arg2 = arg + 1; 956 Dereference_(arg1); 957 Dereference_(arg2); 958 if (IsAtom(arg1->tag) && (IsNil(arg2->tag) || _is_proper_list(arg2))) 959 { 960 Write_Atom(idwrite, out, arg1->val.did, ATOM, flags & ARGLIST, module, mod_tag, sd); 961 Write_Char(out, '{'); 962 status = _write_args_from_list(idwrite, out, arg2, depth, module, mod_tag, sd, flags); 963 if (status < 0) return status; 964 Write_Char(out, '}'); 965 return (PSUCCEED); 966 } 967 } 968 969 /* 970 * Check whether the functor is an operator 971 */ 972 if ((d_opi_desc = visible_op(d, module, mod_tag, &res))) 973 { /* val is an operator */ 974 int prec; 975 int openpar = 0; 976 word assoc; 977 opi *post_infix = 0; 978 pword *narg; 979 980 prec = GetOpiPreced(d_opi_desc); 981 assoc = GetOpiAssoc(d_opi_desc); 982 narg = arg + 1; 983 if (IsPostfixAss(assoc)) 984 { 985 dident atom = add_dict(d, 0); 986 post_infix = visible_infix_op(atom, module, mod_tag, &res); 987 } 988 if ( prec > maxprec 989 || d == d_.comma && (flags & ARGTERM) 990 || flags & ARGYF && prec == maxprec && 991 (assoc == FY || assoc == XFY || assoc == FXY) 992 || post_infix && !(flags & ARGLAST) 993 ) 994 { 995 flags = flags & ~(ARGTERM | ARGLIST | ARGSIGN) | ARGLAST; 996 openpar = 1; 997 Write_Char(out, '('); 998 } 999 Dereference_(arg); 1000 if (arity == 1) 1001 { 1002 switch (assoc) 1003 { 1004 case FX: 1005 prec -= 1; 1006 case FY: 1007 if ( !(sd->options & BLANK_AFTER_SIGN) && ( 1008 d == d_.minus1 || 1009 d == d_.plus1 && !(sd->options & PLUS_IS_NO_SIGN))) 1010 { 1011 /* ignore operators to avoid confusion 1012 * with signed numbers */ 1013 Write_Atom(idwrite, out, d, ATOM, flags & ARGLIST, 1014 module, mod_tag, sd); 1015 Write_Char(out, '('); 1016 Pwrite(idwrite, out, arg->val, arg->tag, 1017 MAXPREC, depth - 1, module, mod_tag, 1018 sd, ARGTERM | ARGLAST); 1019 Write_Char(out, ')'); 1020 } 1021 else 1022 { 1023 Write_Prefix(idwrite, out, d, flags & ARGLIST, 1024 module, mod_tag, sd); 1025 Pwrite(idwrite, out, arg->val, arg->tag, 1026 prec, depth - 1, module, mod_tag, 1027 sd, flags & (ARGTERM | ARGLIST | ARGLAST) 1028 | ARGOP | 1029 ( sd->options & BLANK_AFTER_SIGN && ( 1030 d == d_.minus1 || 1031 d == d_.plus1 && !(sd->options & PLUS_IS_NO_SIGN)) 1032 ? ARGSIGN : 0 )); 1033 } 1034 break; 1035 1036 case YF: 1037 Pwrite(idwrite, out, arg->val, arg->tag, 1038 prec, depth - 1, module, mod_tag, sd, 1039 flags & ~ARGLAST & (ARGTERM | ARGLIST | ARGSIGN) 1040 | ARGYF | ARGOP); 1041 Write_Postfix(idwrite, out, d, flags & ARGLIST, 1042 module, mod_tag, sd); 1043 break; 1044 1045 case XF: 1046 Pwrite(idwrite, out, arg->val, arg->tag, 1047 prec - 1, depth - 1, module, mod_tag, sd, 1048 flags & ~ARGLAST & (ARGTERM | ARGLIST | ARGSIGN) 1049 | ARGOP); 1050 Write_Postfix(idwrite, out, d, flags & ARGLIST, 1051 module, mod_tag, sd); 1052 break; 1053 } 1054 } 1055 else /* arity = 2 */ 1056 { 1057 Dereference_(narg); 1058 switch (assoc) 1059 { 1060 case XFX: 1061 case XFY: 1062 case YFX: 1063 Pwrite(idwrite, out, arg->val, arg->tag, 1064 assoc == YFX ? prec : prec - 1, 1065 depth - 1, module, mod_tag, sd, 1066 flags & ~ARGLAST & (ARGTERM | ARGLIST | ARGSIGN) 1067 | ARGOP | (assoc==YFX?ARGYF:0)); 1068 Write_Infix(idwrite, out, d, flags & ARGLIST, 1069 module, mod_tag, sd, arg, narg); 1070 Pwrite(idwrite, out, narg->val, narg->tag, 1071 assoc == XFY ? prec : prec - 1, 1072 depth - 1, module, mod_tag, sd, 1073 flags & (ARGTERM | ARGLIST | ARGLAST) 1074 | ARGOP); 1075 break; 1076 1077 case FXX: 1078 case FXY: 1079 Write_Prefix(idwrite, out, d, flags & ARGLIST, 1080 module, mod_tag, sd); 1081 Pwrite(idwrite, out, arg->val, arg->tag, 1082 prec - 1, depth - 1, module, mod_tag, sd, 1083 flags & ~ARGLAST & (ARGTERM | ARGLIST) 1084 | ARGOP | 1085 ( sd->options & BLANK_AFTER_SIGN && ( 1086 d == d_.minus || 1087 d == d_.plus && !(sd->options & PLUS_IS_NO_SIGN)) 1088 ? ARGSIGN : 0 )); 1089 Write_Char(out, ' '); 1090 Pwrite(idwrite, out, narg->val, narg->tag, 1091 assoc == FXY ? prec : prec - 1, 1092 depth - 1, module, mod_tag, sd, 1093 flags & (ARGTERM | ARGLIST | ARGLAST) 1094 | ARGOP); 1095 break; 1096 } 1097 } 1098 if (openpar) 1099 { 1100 Write_Char(out, ')'); 1101 } 1102 return (PSUCCEED); 1103 } 1104 /* else do as for a normal functor */ 1105 } 1106 1107 /* normal functor or we ignore operators */ 1108 1109 Write_Atom(idwrite, out, d, ATOM, flags & ARGLIST, module, mod_tag, sd); 1110 1111_write_args_: /* (arg,arity) */ 1112 Write_Char(out, '('); 1113 if (UseDepth(idwrite) && depth <= 1) 1114 { 1115 /* abbreviate even more: only one ... for all arguments */ 1116 if ((status = ec_outf(out, "...", 3)) < 0) 1117 return status; 1118 } 1119 else if (arity > 0) /* should always be true */ 1120 { 1121 for(;;) 1122 { 1123 pword *narg = arg + 1; 1124 Dereference_(arg); 1125 Pwrite(idwrite, out, arg->val, arg->tag, MAXPREC, 1126 depth-1, module, mod_tag, sd, ARGTERM | ARGLAST); 1127 if (--arity == 0) 1128 break; 1129 Write_Comma(out); 1130 arg = narg; 1131 } 1132 } 1133 Write_Char(out, ')'); 1134 break; 1135 1136 case TLIST: 1137 case TGRL: /* a ground list in the compiler */ 1138 Handle_Type_Macro(TCOMP) 1139 if (idwrite & DOTLIST) 1140 { 1141 d = d_.list; /* write list in ./2 notation */ 1142 arg = val.ptr; 1143 goto _write_structure_; 1144 } 1145 else /* write list in [ ] notation */ 1146 { 1147 pword *tail; 1148 if (MacrosAllowed(idwrite) && DidMacro(d_.list)) /* output macros */ 1149 { 1150 pword *narg; 1151 if ((narg = _write_trafo(d_.list, GoalMacro(idwrite), 1152 &idwrite, val, tag, module, mod_tag))) 1153 { 1154 val.all = narg->val.all; 1155 tag.all = narg->tag.all; 1156 idwrite &= ~(WRITE_GOAL|WRITE_CLAUSE); 1157 goto _pwrite_; /* print the transformed term */ 1158 } 1159 } 1160 idwrite &= ~(WRITE_GOAL|WRITE_CLAUSE); 1161 1162 if ((status = ec_outfc(out, '[')) < 0) 1163 return (status); 1164 arg = val.ptr; 1165 tail = arg + 1; 1166 Dereference_(arg) 1167 status = _pwrite1(idwrite, out, arg->val, arg->tag, MAXPREC, 1168 --depth, module, mod_tag, sd, ARGTERM | ARGLIST | ARGLAST); 1169 if (status < 0) 1170 return (status); 1171 while (!(UseDepth(idwrite) && depth <= 0)) 1172 { 1173 Dereference_(tail); 1174 switch (TagType(tail->tag)) 1175 { 1176 case TNIL: 1177 break; 1178 case TLIST: 1179 Write_Comma(out); 1180 tail = tail->val.ptr; 1181 arg = tail++; 1182 Dereference_(arg); 1183 status = _pwrite1(idwrite, out, arg->val, arg->tag, MAXPREC, 1184 --depth, module, mod_tag, sd, 1185 ARGTERM | ARGLIST | ARGLAST); 1186 if (status < 0) 1187 return (status); 1188 continue; 1189 default: 1190 if ((status = ec_outfc(out, '|')) < 0) 1191 return (status); 1192 status = _pwrite1(idwrite, out, tail->val, tail->tag, 1193 MAXPREC, --depth, module, mod_tag, 1194 sd, ARGTERM | ARGLIST | ARGLAST); 1195 if (status < 0) 1196 return (status); 1197 break; 1198 } 1199 break; 1200 } 1201 return (ec_outfc(out, ']')); 1202 } 1203 1204 1205/***** EXTENSION SLOT WRITE *****/ 1206 1207 default: 1208 if (TagType(tag) >= 0 && TagType(tag) <= NTYPES) 1209 { 1210 Handle_Type_Macro(TagType(tag)) 1211 1212 if (tag_desc[TagType(tag)].numeric 1213 && UnsignedNumberNeedsBrackets 1214 && !_is_signed_number(val, tag)) 1215 { 1216 if ((status = ec_outfc(out, '(')) < 0 || 1217 (status = tag_desc[TagType(tag)].write(idwrite & QUOTED, out, val, tag)) < 0 || 1218 (status = ec_outfc(out, ')')) < 0) 1219 return status; 1220 return status; 1221 } 1222 return tag_desc[TagType(tag)].write(idwrite & QUOTED, out, val, tag); 1223 } 1224 else 1225 p_fprintf(out, "BAD_TERM_0x%" W_MOD "x_0x%" W_MOD "x", val.all, tag.all); 1226 Succeed_ 1227 } 1228 return (PSUCCEED); 1229} 1230 1231 1232static int 1233_is_proper_list(pword *list) 1234{ 1235 if (!IsList(list->tag)) 1236 return 0; 1237 for(;;) 1238 { 1239 list = list->val.ptr + 1; 1240 Dereference_(list); 1241 if (!IsList(list->tag)) 1242 return IsNil(list->tag); 1243 } 1244} 1245 1246 1247 1248/* CAUTION: this function assumes that list is a proper list! */ 1249static int 1250_write_args_from_list(int idwrite, stream_id out, pword *list, int depth, dident module, type mod_tag, syntax_desc *sd, int flags) 1251{ 1252 pword *arg; 1253 int status; 1254 if (IsNil(list->tag)) 1255 return PSUCCEED; 1256 if (UseDepth(idwrite) && depth <= 1) 1257 { 1258 /* abbreviate even more: only one ... for all arguments */ 1259 Write_Str(out, "...", 3); 1260 } 1261 for(;;) 1262 { 1263 list = list->val.ptr; 1264 arg = list++; 1265 Dereference_(arg); 1266 Pwrite(idwrite, out, arg->val, arg->tag, MAXPREC, 1267 depth-1, module, mod_tag, sd, ARGTERM | ARGLAST); 1268 Dereference_(list); 1269 if (IsList(list->tag)) 1270 { 1271 Write_Comma(out); 1272 continue; 1273 } 1274 return PSUCCEED; 1275 } 1276} 1277 1278 1279static pword * 1280_write_trafo(dident d, int flags, int *idwrite, value val, type tag, dident module, type mod_tag) 1281{ 1282 extern pword *trafo_term(dident tr_did, int flags, dident mv, type mt, int *tr_flags); 1283 extern int do_trafo(pword *term); 1284 int macroflags; 1285 register pword *result, *tr_goal; 1286 pword *pw; 1287 1288 if (d == D_UNKNOWN) { /* meta attribute */ 1289 pw = TG; 1290 TG += 3; 1291 Check_Gc; 1292 pw[0].val.did = d_print_attributes; 1293 pw[0].tag.kernel = TDICT; 1294 pw[1].val.all = val.all; 1295 pw[1].tag.kernel = tag.kernel; 1296 pw[2].tag.kernel = TREF; 1297 pw[2].val.ptr = pw + 2; 1298 tr_goal = pw; 1299 macroflags = 0; 1300 result = pw + 2; 1301 } else { 1302 tr_goal = trafo_term(d, TR_WRITE|TR_TOP|flags, module, mod_tag, ¯oflags); 1303 if (tr_goal) 1304 { 1305 TransfTermIn(tr_goal)->val.all = val.all; 1306 TransfTermIn(tr_goal)->tag.kernel = tag.kernel; 1307 result = TransfTermOut(tr_goal); 1308 } else 1309 return (pword *) 0; 1310 } 1311 1312 if (do_trafo(tr_goal) == PSUCCEED) 1313 { 1314 Dereference_(result); 1315 /* to avoid looping, check if something was actually transformed */ 1316 if (result->val.all != val.all || result->tag.all != tag.all) { 1317 if (macroflags & TR_PROTECT) 1318 *idwrite |= NO_MACROS; 1319 return result; 1320 } 1321 } 1322 return (pword *) 0; 1323} 1324 1325 1326/* 1327 * Call portray/1,2 on a specified term. Returns 1 iff the call succeeded. 1328 */ 1329static int 1330_portray_term(int idwrite, stream_id out, value val, type tag, dident module, type mod_tag) 1331{ 1332 value v1, v2; 1333 int status = PFAIL; 1334 pword goal[3]; 1335 1336 v1.ptr = goal; 1337 v2.did = module; 1338 if (idwrite & PORTRAY2) 1339 { 1340 Make_Atom(&goal[0], d_portray2); 1341 goal[1] = StreamHandle(out); 1342 goal[2].tag = tag; 1343 goal[2].val = val; 1344 Unlock_Stream(out); /* release the stream lock while executing Prolog */ 1345 status = query_emulc(v1, tcomp, v2, mod_tag); 1346 Lock_Stream(out); 1347 if (status == PSUCCEED) return 1; 1348 /* else try portray/1 */ 1349 } 1350 if (idwrite & PORTRAY1) 1351 { 1352 /* compatibility hack for portray/1: temporarily redirect output */ 1353 stream_id saved_output = current_output_; 1354 if (set_stream(d_.output, out) != PSUCCEED) 1355 return 0; 1356 Make_Atom(&goal[0], d_portray1); 1357 goal[1].tag = tag; 1358 goal[1].val = val; 1359 Unlock_Stream(out); /* release the stream lock while executing Prolog */ 1360 status = query_emulc(v1, tcomp, v2, mod_tag); 1361 Lock_Stream(out); 1362 (void) set_stream(d_.output, saved_output); 1363 } 1364 return (status == PSUCCEED) ? 1 : 0; 1365} 1366 1367/* 1368 * Try to avoid space printing around some frequent infix operators. 1369 * Except for comma, make it symmetric. 1370 * 1371 * TODO: This should be done very differently. Rather than trying to 1372 * look ahead to the right hand side argument, we should remember the 1373 * last character of the operator and lazily insert a space if necessary 1374 * when we are about to print the first character of the next item. 1375 */ 1376static int 1377_write_infix(int idwrite, stream_id out, dident d, register int flags, dident module, type mod_tag, syntax_desc *sd, pword *right, int depth) 1378{ 1379 int status; 1380 int spaces = 0; 1381 1382 if ((sd->options & DENSE_OUTPUT || idwrite & WRITE_COMPACT) && d != d_.comma) 1383 { 1384 int last_left, first_right; 1385 int first = sd->char_class[*DidName(d)]; 1386 int last = sd->char_class[*(DidName(d) + DidLength(d) - 1)]; 1387 last_left = sd->char_class[(unsigned char)StreamLastWritten(out)]; 1388 if (IsNumber(right->tag)) 1389 { 1390 if (_is_signed_number(right->val, right->tag)) 1391 first_right = sd->char_class['-']; 1392 else 1393 first_right = N; 1394 } 1395 else if (IsAtom(right->tag)) 1396 first_right = sd->char_class[*(DidName(right->val.did))]; 1397 else 1398 first_right = -1; 1399 1400 if (last_left == first || Alphanum(last_left) && Alphanum(first) || 1401 last == first_right || Alphanum(last) && Alphanum(first_right) || 1402 (!IsNumber(right->tag) && !IsAtom(right->tag) && !IsList(right->tag))) 1403 { 1404 spaces = 1; 1405 } 1406 } 1407 else 1408 { 1409 spaces = 1; 1410 } 1411 if (spaces && d != d_.comma) 1412 if ((status = ec_outfc(out, ' ')) < 0) 1413 return status; 1414 if ((status = _write_atom(idwrite, out, d, OPERATOR, flags, 1415 module, mod_tag, sd, depth)) < 0) 1416 return status; 1417 if (spaces && (d != d_.comma || !(idwrite & WRITE_COMPACT))) 1418 if ((status = ec_outfc(out, ' ')) < 0) 1419 return(status); 1420 return 0; 1421} 1422 1423 1424#define STRING_PLUS 10 1425/*ARGSUSED*/ 1426static int 1427_write_string(int idwrite, stream_id out, char *start, word length, int depth) 1428{ 1429/* It is not obvious what is the best way to avoid long strings 1430 if (UseDepth(idwrite) && depth > 0 && 1431 length > PrintDepth - depth + STRING_PLUS) { 1432 length = PrintDepth - depth + STRING_PLUS; 1433 Write_Str(out, start, (int) length); 1434 return (ec_outf(out, "...", 3)); 1435 } else 1436 */ 1437 return ec_outf(out, start, (int) length); 1438} 1439 1440/* module argument is meaningful only when ARGOP is set in flag && 1441 QUOTED is set in idwrite */ 1442static int 1443_write_atom(int idwrite, stream_id out, dident d, int what, int flag, dident module, type mod_tag, syntax_desc *sd, int depth) 1444{ 1445 int status; 1446 word length = DidLength(d); 1447 char *name = DidName(d); 1448 1449 if (DidArity(d) < 0) 1450 { 1451 return ec_outfs(out, DidArity(d) == UNUSED_DID_ARITY ? 1452 "ILLEGAL_FREED_FUNCTOR" : "ILLEGAL_FUNCTOR"); 1453 } 1454 1455 if (idwrite & QUOTED) 1456 { 1457 dident d0 = check_did(d, 0); 1458 int nq = ec_need_quotes(d, sd); 1459 1460 if (nq == QIDENTIFIER || 1461 nq == COMMA && (what != OPERATOR) || 1462 nq == BAR && (flag & ARGLIST 1463 || ( (what == OPERATOR && d == d_.bar) 1464 ? sd->options & BAR_IS_SEMICOLON 1465 : sd->options & BAR_IS_NO_ATOM )) || 1466 nq == EOCL && (what == OPERATOR || (flag & ARGOP))) 1467 { 1468 if ((flag & ARGOP) 1469 && is_visible_op(d0, module, mod_tag)) 1470 { 1471 if ( ((status = ec_outfc(out, '(')) < 0) 1472 || ((status = _write_quoted(idwrite, out, name, length, 1473 (char) sd->current_aq_char, sd, depth)) < 0) 1474 || ((status = ec_outfc(out, ')')) <0 )) 1475 { 1476 return (status); 1477 } 1478 else 1479 { 1480 return(PSUCCEED); 1481 } 1482 } 1483 else 1484 { 1485 Set_Bip_Error(0); /* access checking already done */ 1486 return _write_quoted(idwrite, out, name, length, 1487 (char) sd->current_aq_char, sd, depth); 1488 } 1489 } 1490 1491 if ((flag & ARGOP) 1492 && is_visible_op(d0, module, mod_tag)) 1493 { 1494 if (((status = ec_outfc(out, '(')) <0) 1495 || ((status = ec_outf(out, name, (int) length)) < 0) 1496 || ((status = ec_outfc(out, ')')) < 0)) 1497 { 1498 return(status); 1499 } 1500 else 1501 { 1502 return(PSUCCEED); 1503 } 1504 } 1505 else 1506 { 1507 Set_Bip_Error(0); /* access checking already done */ 1508 return(ec_outf(out, name, (int) length)); 1509 } 1510 } 1511 else 1512 { 1513 if (!strcmp(name, "|") && (flag &ARGLIST)) 1514 { 1515 return _write_quoted(idwrite, out, name, length, 1516 (char)sd->current_aq_char, sd, depth); 1517 } 1518 else 1519 { 1520 return _write_string(idwrite, out, name, length, depth); 1521 } 1522 } 1523 1524} 1525 1526 1527/* 1528 * write a quoted atom or string 1529 * 1530 * If an escape character (usually backslash) is defined, 1531 * non printable characters are printed as <escape> <letter> 1532 * or (if no special notation exists) as <escape> <octal>. 1533 * Moreover, the escape character itself and the current quote 1534 * are escaped. 1535 * If no escape character is defined, only the current quote is 1536 * treated in a special way (doubled) to achieve Cprolog compatibility. 1537 */ 1538/*ARGSUSED*/ 1539static int 1540_write_quoted(int idwrite, stream_id out, char *name, register word len, char quotechar, syntax_desc *sd, int depth) 1541{ 1542 int status; 1543 int cut; 1544 register char c; 1545 1546/* It is not obvious what is the best way to avoid long strings 1547 if (UseDepth(idwrite) && depth > 0 && len > PrintDepth - depth + STRING_PLUS) { 1548 len = PrintDepth - depth + STRING_PLUS; 1549 cut = 1; 1550 } else 1551*/ 1552 cut = 0; 1553 if ((status = ec_outfc(out, quotechar))) /* write the left quote */ 1554 return status; 1555 1556 if (sd->current_escape >= 0) /* there is an escape character */ 1557 { 1558 while (len-- > 0) 1559 { 1560 switch(c = *name++) 1561 { 1562 case 0007: 1563 c = 'a'; break; 1564 case 0013: 1565 c = 'v'; break; 1566 case '\b': 1567 c = 'b'; break; 1568 case '\t': 1569 if (idwrite & DONT_QUOTE_NL) 1570 { 1571 if ((status = ec_outfc(out, c))) 1572 return status; 1573 continue; 1574 } 1575 c = 't'; break; 1576 case '\n': 1577 if (idwrite & DONT_QUOTE_NL) 1578 { 1579 if ((status = ec_outfc(out, c))) 1580 return status; 1581 continue; 1582 } 1583 c = 'n'; 1584 break; 1585 case '\r': 1586 c = 'r'; break; 1587 case '\f': 1588 c = 'f'; break; 1589 default: 1590 if (c == (char) sd->current_escape || c == quotechar) 1591 break; 1592 else if(c < 32 || c >= 127) /* write escaped octal */ 1593 { 1594 if ((status = ec_outfc(out, sd->current_escape))) 1595 return status; 1596 if (sd->options & ISO_ESCAPES) 1597 { 1598 if ((status = p_fprintf(out, "%o", c & 0xff))) 1599 return status; 1600 if ((status = ec_outfc(out, sd->current_escape))) 1601 return status; 1602 } 1603 else 1604 if ((status = p_fprintf(out, "%03o", c & 0xff))) 1605 return status; 1606 } 1607 else /* normal printable character */ 1608 if ((status = ec_outfc(out, c))) 1609 return status; 1610 continue; 1611 } 1612 /* write escaped char */ 1613 if ((status = ec_outfc(out, sd->current_escape))) 1614 return status; 1615 if ((status = ec_outfc(out, c))) 1616 return status; 1617 } 1618 } 1619 else /* we have no escape character */ 1620 { 1621 while (len-- > 0) 1622 { 1623 c = *name++; 1624 if (c == quotechar) /* double an internal quote */ 1625 if ((status = ec_outfc(out, c))) 1626 return status; 1627 if ((status = ec_outfc(out, c))) 1628 return status; 1629 } 1630 } 1631 if (cut) { 1632 Write_Str(out, "...", 3); 1633 } 1634 1635 return ec_outfc(out, quotechar); /* write the right quote */ 1636} 1637 1638/* 1639 * Print the variable. 1640 * The number is the distance in pwords from the stack origin. 1641 * The stack is pword-aligned. 1642 */ 1643static int 1644_print_var(int idwrite, value v, type t, stream_id str, int depth, dident module, type mod_tag, syntax_desc *sd) 1645{ 1646 int name_printed = 0; 1647 int slot; 1648 1649 if (idwrite & VARTERM) 1650 (void) ec_outf(str, "'_'(\"", 5); 1651 1652 if (idwrite & VAR_ANON) 1653 { 1654 (void) ec_outfc(str, (char) sd->current_ul_char); 1655 } 1656 else if (GlobalFlags & STRIP_VARIABLES) /* in the tests, all vars are the same */ 1657 { 1658 if (IsMeta(t)) 1659 (void) ec_outf(str, "_m", 2); 1660 else 1661 (void) ec_outf(str, "_g", 2); 1662 return PSUCCEED; 1663 } 1664 else 1665 { 1666 /* ISO requires _xxx names */ 1667 if (!(idwrite & VAR_NUMBERS) && !(sd->options & ISO_RESTRICTIONS)) 1668 { 1669 switch (TagType(t)) 1670 { 1671 case TMETA: 1672 if ((slot = meta_index(d_var_name))) 1673 { 1674 pword *t1, *t2; 1675 1676 t1 = (v.ptr + 1)->val.ptr + slot; 1677 Dereference_(t1); 1678 if (IsStructure(t1->tag)) 1679 { 1680 t1 = t1->val.ptr; 1681 if ((t1++)->val.did == d_vname2) 1682 {/* vname(basename, number) as in var_name.ecl */ 1683 t2 = t1 + 1; 1684 Dereference_(t1); 1685 Dereference_(t2); 1686 if (IsString(t1->tag) && IsInteger(t2->tag)) 1687 { 1688 p_fprintf(str, "%s#%" W_MOD "d", StringStart(t1->val), t2->val.nint); 1689 name_printed = 2; 1690 } 1691 } 1692 } 1693 } 1694 1695 case TNAME: /* all the named variable types */ 1696 case TUNIV: 1697 if (IsNamed(t.kernel) && (name_printed != 2)) 1698 { 1699 p_fprintf(str, "%s", DidName(TagDid(t.kernel))); 1700 name_printed = 1; 1701 } 1702 } 1703 } 1704 1705 if ((idwrite & (VAR_NUMBERS|VAR_NAMENUM) && name_printed != 2) 1706 || !name_printed) 1707 { 1708 (void) ec_outfc(str, (char) sd->current_ul_char); 1709 switch (TagType(t)) 1710 { 1711 case TVAR_TAG: 1712 if (B_ORIG < v.ptr && v.ptr <= SP_ORIG) /* local */ 1713 p_fprintf(str, "l%" W_MOD "d", SP_ORIG - v.ptr); 1714 else 1715 case TNAME: 1716 if (TG_ORIG <= v.ptr && v.ptr < B_ORIG) /* global */ 1717 p_fprintf(str, "%" W_MOD "d", v.ptr - TG_ORIG); 1718 else /* heap */ 1719 p_fprintf(str, "h%" W_MOD "d", v.ptr - B_ORIG); 1720 break; 1721 1722 case TUNIV: 1723 p_fprintf(str, "%" W_MOD "d", v.ptr - TG_ORIG); 1724 break; 1725 1726 case TMETA: 1727 p_fprintf(str, "%" W_MOD "d", v.ptr - TG_ORIG); 1728 break; 1729 1730 default: 1731 p_fprintf(str, "BAD_VAR_0x%" W_MOD "x_0x%" W_MOD "x", v.all, t.all); 1732 break; 1733 } 1734 } 1735 } 1736 1737 /* if it's a non marked metavariable write the metaterm */ 1738 if (IsMeta(t) && (idwrite & (STD_ATTR | ATTRIBUTE)) && !(t.kernel & HIDE_ATTR)) 1739 { 1740 /* important to mark before printing meta term or 1741 * could not write circular metaterms. 1742 * mark by changing type to normal variable so that other occurrences 1743 * will be printed normally 1744 */ 1745 Trail_Tag(v.ptr); 1746 1747 if (idwrite & STD_ATTR) { 1748 pword *pw, *r; 1749 pword pw_out; 1750 (v.ptr)->tag.kernel |= HIDE_ATTR; 1751 (void) ec_outfc(str,'{'); 1752 pw = MetaTerm(v.ptr); 1753 Dereference_(pw); 1754 r = TG; 1755 TG += ATTR_IO_TERM_SIZE; 1756 Check_Gc; 1757 TG = transf_meta_out(pw->val, pw->tag, r, 1758 (idwrite & CANONICAL ? D_UNKNOWN : module), &pw_out); 1759 (void) _pwrite1(idwrite, str, pw_out.val, pw_out.tag, 1200, depth, 1760 module, mod_tag, sd, ARGLAST); 1761 (void) ec_outfc(str,'}'); 1762 } else { 1763 pword *r = _write_trafo(D_UNKNOWN /*META*/, 0, 1764 &idwrite, v, t, module, mod_tag); 1765 (v.ptr)->tag.kernel |= HIDE_ATTR; 1766 if (r) { 1767 (void) _pwrite1(idwrite, str, r->val, r->tag, 1200, depth, 1768 module, mod_tag, sd, ARGLAST); 1769 } 1770 } 1771 } 1772 1773 if (idwrite & VARTERM) 1774 (void) ec_outf(str, "\")", 2); 1775 1776 return PSUCCEED; 1777} 1778 1779 1780/* 1781 * Convert a float to a Prolog-readable representation. 1782 * The caller has to provide a large enough buffer. 1783 * The length of the printed representation is returned. 1784 * If the precise-flag is set, we make sure that reading back the 1785 * number will give exactly the same float as before. 1786 */ 1787 1788static int 1789_float_to_string(value v, type t, char *buf, int precise) 1790{ 1791 return _float_to_string_opt(v, t, buf, precise, 0); 1792} 1793 1794 1795static int 1796_float_to_string_opt(value v, type t, char *buf, int precise, int syntax_options) 1797{ 1798 char aux[32]; 1799 char *s; 1800 char *bufp = buf; 1801 int dot_seen = 0; 1802 int is_nan = 0; 1803 double f = Dbl(v); 1804 1805 if (!GoodFloat(f)) 1806 { 1807 ieee_double nan; 1808 is_nan = 1; 1809 nan.as_dbl = f; 1810 /* change the exponent to 1 and print as a number */ 1811 nan.as_struct.mant1 = (nan.as_struct.mant1 & 0x800FFFFF)|0x3FF00000; 1812 f = nan.as_dbl; 1813 } 1814 if (!finite(f)) 1815 { 1816 s = f < 0 ? "-1.0Inf" : "1.0Inf"; 1817 } 1818 else if (f == 0.0) /* not all sprintf's deal properly with -0.0 */ 1819 { 1820 s = (1.0/f < 0.0 /* && precise */) ? "-0.0" : "0.0"; 1821 } 1822 else 1823 { 1824 if (IsDouble(t)) 1825 { 1826 (void) sprintf(aux, "%.15g", f); /* try with precise digits only */ 1827 if (precise && f != atof(aux)) 1828 (void) sprintf(aux, "%.17g", f);/* not exact enough, use more */ 1829 } 1830 else 1831 { 1832 (void) sprintf(aux, "%.6g", f); /* try with precise digits only */ 1833 if (precise && (float) f != (float) atof(aux)) 1834 (void) sprintf(aux, "%.9g", f); /* not exact enough, use more */ 1835 } 1836 s = aux; 1837 if (*s == '-') 1838 *bufp++ = *s++; /* copy sign */ 1839 if (*s == '.') 1840 *bufp = '0'; /* insert 0 in front of . */ 1841 for (;;) 1842 { 1843 switch (*s) 1844 { 1845 case 'e': 1846 case 'E': 1847 if (!dot_seen && (syntax_options & FLOAT_NEEDS_POINT)) 1848 { 1849 *bufp++ = '.'; /* insert .0 */ 1850 *bufp++ = '0'; 1851 } 1852 dot_seen = 1; 1853 *bufp++ = *s++; 1854 if (*s == '+' || *s == '-') /* copy sign if any */ 1855 *bufp++ = *s++; 1856 while (*s == '0') /* remove leading zeros in exponent */ 1857 ++s; 1858 if (! *s) /* but don't lose them all */ 1859 *bufp++ = '0'; 1860 continue; 1861 case '.': 1862 dot_seen = 1; 1863 break; 1864 case 0: 1865 if (!dot_seen) 1866 { 1867 *bufp++ = '.'; /* insert .0 */ 1868 *bufp++ = '0'; 1869 } 1870 *bufp++ = 0; 1871 goto _return_; 1872 } 1873 *bufp++ = *s++; 1874 } 1875 /* NOTREACHED */ 1876 } 1877 while ((*bufp++ = *s++)) {} /* copy the rest of sprintf result */ 1878_return_: 1879 if (is_nan) { 1880 s = "NaN"; 1881 --bufp; 1882 while ((*bufp++ = *s++)) {} 1883 } 1884 return (bufp - buf) - 1; 1885} 1886 1887/*ARGSUSED*/ 1888static int 1889_num_string_size(value v, type t, int quoted) 1890{ 1891 /* enough space for an integer in base 2 + sign */ 1892 return 8*SIZEOF_WORD + 1; 1893} 1894 1895/*ARGSUSED*/ 1896static int 1897_int_to_string(value v, type t, char *buf, int quoted_or_base) 1898{ 1899 int base = quoted_or_base < 2 ? 10 : quoted_or_base; 1900 word number = v.nint; 1901 word aux = number; 1902 int len, pos = 0; 1903 value vv; 1904 1905 do /* count digits */ 1906 { 1907 ++pos; 1908 aux /= base; 1909 } while(aux); 1910 1911 if (number < 0) 1912 { 1913 len = pos+1; 1914 buf[0] = '-'; 1915 buf[len] = '\0'; 1916 if (number == MIN_S_WORD) /* special case -2^(wordsize-1) */ 1917 { 1918 int ch = (number-base) % base; 1919 buf[pos--] = (ch < 10) ? ch + '0' : ch + 'a' - 10; 1920 number = -(number/base); 1921 } else 1922 number = -number; 1923 } else 1924 { 1925 len = pos; 1926 buf[pos--] = '\0'; 1927 } 1928 do 1929 { 1930 int ch = number % base; 1931 buf[pos--] = (ch < 10) ? ch + '0' : ch + 'a' - 10; 1932 number /= base; 1933 } while(number); 1934 1935 return len; 1936} 1937 1938 1939static int 1940_handle_string_size(value v, type t, int quoted_or_base) 1941{ 1942 if (ExternalClass(v.ptr)->string_size && ExternalData(v.ptr)) 1943 return (ExternalClass(v.ptr)->string_size)(ExternalData(v.ptr), quoted_or_base); 1944 else 1945 return 0; 1946} 1947 1948static int 1949_handle_to_string(value v, type t, char *buf, int quoted_or_base) 1950{ 1951 if (ExternalClass(v.ptr)->to_string && ExternalData(v.ptr)) 1952 return (ExternalClass(v.ptr)->to_string)(ExternalData(v.ptr), buf, quoted_or_base); 1953 else 1954 return 0; 1955} 1956 1957 1958/* 1959 * 1960 * printf_(+Stream, +Format, +List, +Module, 0'%, -ErrFormat, -ErrList, -Res) 1961 * 1962 * ErrFormat and ErrList return the remaining data 1963 * when there was an error (Res != 0) 1964 */ 1965 1966/* 1967 * CAUTION: p_printf5() uses a special error return mechanism in order to 1968 * deal better with errors that occur halfway through the format string. 1969 * It always succeeds and returns: 1970 * the return/error code in verr/terr 1971 * the remaining format string in vse/tse 1972 * the remaining argument list in vle/tle 1973 * Bip_Error() is therefore temporarily redefined during p_printf5() 1974 * and changed back later!!! 1975 */ 1976 1977#undef Bip_Error 1978#define Bip_Error(N) Printf_Error(N) 1979#define Printf_Error(N) { res = N; goto _return_res_; } 1980 1981static int 1982p_printf5(value vs, type ts, value strval, type strtag, value lval, type ltag, value vm, type tm, value vfc, type tfc, value vse, type tse, value vle, type tle, value verr, type terr) 1983{ 1984 char formstrt = vfc.nint; 1985 char *format, *cpar, *npar, par[32]; 1986 int success_code = PSUCCEED; 1987 int res; 1988 stream_id nst = get_stream_id(vs, ts, SWRITE, &res); 1989 long asterisk, c, i; 1990 int radix; 1991 pword my_list[2]; 1992 pword *list; 1993 pword *elem; 1994 char *last_format = NULL; 1995 pword *last_list; 1996 1997 Get_Name(strval, strtag, format); 1998 if (nst == NO_STREAM) { 1999 Bip_Error(res) 2000 } 2001 Check_Stream(nst, res); 2002 Check_Module(tm, vm); 2003 Check_Integer(tfc); 2004 2005 if ((StreamMode(nst) & STYPE) == SNULL) 2006 goto _return_succ_; 2007 2008 if (IsNil(ltag)) 2009 list = 0; 2010 else if (!IsList(ltag)) 2011 { 2012 my_list[0].tag = ltag; 2013 my_list[0].val = lval; 2014 my_list[1].tag.kernel = TNIL; 2015 list = &my_list[0]; 2016 } 2017 else 2018 list = lval.ptr; 2019 2020 par[0] = '%'; /* here we build up the format string for C printf */ 2021 cpar = &par[0]; 2022 2023 last_list = list; 2024 last_format = format; 2025 2026 Lock_Stream(nst); /* Be sure to unlock before returning !!! */ 2027 2028 for (; *format; last_format = ++format, last_list = list) 2029 { 2030 if (*format == formstrt) 2031 { /* within control sequence */ 2032 asterisk = 0; 2033 while ((*(++cpar) = *(++format))) 2034 { 2035 if (*cpar == formstrt) 2036 { 2037 if (cpar != &par[1]) { 2038 /* something between two %'s */ 2039 Printf_Error(BAD_FORMAT_STRING); 2040 } else if ((res = ec_outfc(nst, formstrt)) < 0) { 2041 goto _return_res_; 2042 } 2043 } else 2044 switch (*cpar) 2045 { 2046/* 2047 * free : hjyz BHJSYZ 2048 */ 2049 case ' ' : /* flags and sizes */ 2050 case '+' : 2051 case '-' : 2052 case '.' : 2053 case '#' : 2054 case '0' : 2055 case '1' : 2056 case '2' : 2057 case '3' : 2058 case '4' : 2059 case '5' : 2060 case '6' : 2061 case '7' : 2062 case '8' : 2063 case '9' : 2064 case 'l' : 2065 case 'm' : 2066 case 'v' : 2067 case 'C' : 2068 case 'D' : 2069 case 'F' : 2070 case 'G' : 2071 case 'I' : 2072 case 'K' : 2073 case 'L' : 2074 case 'M' : 2075 case 'N' : 2076 case 'O' : 2077 case 'P' : 2078 case 'Q' : 2079 case 'T' : 2080 case 'U' : 2081 case 'V' : 2082 case '_' : 2083 continue; 2084 2085 case '*' : 2086 if (++asterisk > 2) { 2087 Printf_Error(BAD_FORMAT_STRING) 2088 } 2089 continue; 2090 2091 case 'd' : /* integers */ 2092 case 'o' : 2093 case 'u' : 2094 case 'x' : 2095 case 'X' : 2096 *(++cpar) = '\0'; 2097 res = _printf_asterisk(asterisk, &list, tint, nst, par); 2098 if (res < 0) { 2099 goto _return_res_; 2100 } 2101 break; 2102 2103 case 'f' : /* floating numbers */ 2104 case 'e' : 2105 case 'E' : 2106 case 'g' : 2107 *(++cpar) = '\0'; 2108 res = _printf_asterisk(asterisk, &list, tag_desc[TDBL].tag, nst, par); 2109 if (res < 0) { 2110 goto _return_res_; 2111 } 2112 break; 2113 2114 case 'n' : /* newline */ 2115 case 't' : /* tab */ 2116 case 'c' : /* single char */ 2117 if (asterisk > 1) { 2118 Printf_Error(BAD_FORMAT_STRING) 2119 } 2120 else if (asterisk) { 2121 Next_Element(elem, list, Printf_Error) 2122 Check_Integer(elem->tag) 2123 i = elem->val.nint; /* character count */ 2124 } 2125 else { 2126 Get_Counter(par+1,npar,i); 2127 if (i==0) i=1; 2128 } 2129 switch (*cpar) 2130 { 2131 case 'c': 2132 Next_Element(elem, list, Printf_Error) 2133 Check_Integer(elem->tag) 2134 c = elem->val.nint; 2135 break; 2136 case 'n': 2137 while (i) 2138 { 2139 if ((res = ec_newline(nst)) < 0) { 2140 if (res == YIELD_ON_FLUSH_REQ) 2141 success_code = res; 2142 else 2143 goto _return_res_; 2144 } 2145 --i; 2146 } 2147 break; 2148 case 't': 2149 c = '\t'; 2150 break; 2151 } 2152 while(i--) 2153 { 2154 if ((res = ec_outfc(nst, (char) c) < 0)) 2155 goto _return_res_; 2156 } 2157 break; 2158 2159 case 's' : /* string */ 2160 if (cpar != &par[1]) 2161 { 2162 /* we don't have a simple %s, pass to C's printf ... */ 2163 *(++cpar) = '\0'; 2164 res = _printf_asterisk(asterisk, &list, tstrg, nst, par); 2165 if (res < 0) { 2166 goto _return_res_; 2167 } 2168 break; 2169 } 2170 /* else fall through and treat %s like %a 2171 * (because we cope better with long strings) 2172 */ 2173 2174 case 'a' : /* 'write' atom or string (may contain NUL) */ 2175 case 'A' : /* same but map to upper case */ 2176 Next_Element(elem, list, Printf_Error) 2177 if (cpar != &par[1]) 2178 { 2179 Printf_Error(BAD_FORMAT_STRING) 2180 } 2181 if (IsString(elem->tag)) { 2182 i = (int) StringLength(elem->val); 2183 npar = StringStart(elem->val); 2184 } else if (IsAtom(elem->tag)) { 2185 i = (int) DidLength(elem->val.did); 2186 npar = DidName(elem->val.did); 2187 } else if (IsNil(elem->tag)) { 2188 i = (int) DidLength(d_.nil); 2189 npar = DidName(d_.nil); 2190 } else if (IsRef(elem->tag)) { 2191 Printf_Error(INSTANTIATION_FAULT); 2192 } else { 2193 Printf_Error(TYPE_ERROR); 2194 } 2195 if (*cpar == 'A') { 2196 for (res=0; res==0 && i--; ++npar) 2197 res = ec_outfc(nst, toupper(*npar)); 2198 } else { 2199 res = ec_outf(nst, npar, i); 2200 } 2201 if (res < 0) { 2202 goto _return_res_; 2203 } 2204 break; 2205 2206 case 'w' : /* 'write' term (ignore stream defaults) */ 2207 case 'W' : /* 'write' term (use stream defaults) */ 2208 { 2209 char form_char = *cpar; 2210 int mask_clr, mask_set; 2211 if (asterisk > 1) { 2212 Printf_Error(BAD_FORMAT_STRING) 2213 } 2214 else if (asterisk) { 2215 Next_Element(elem, list, Printf_Error) 2216 Check_Integer(elem->tag) 2217 i = elem->val.nint; /* character count */ 2218 npar = par+2; 2219 } 2220 else { 2221 Get_Counter(par+1,npar,i); 2222 } 2223 Next_Element(elem, list, Printf_Error) 2224 2225 *(cpar) = '\0'; 2226 res = _get_mode_mask(npar, &mask_clr, &mask_set); 2227 if (res != PSUCCEED) { 2228 goto _return_res_; 2229 } 2230 if (form_char == 'w') 2231 mask_clr = StreamOutputMode(nst); 2232 2233 res = ec_pwrite(mask_clr, mask_set, nst, elem->val, elem->tag, 2234 1200, i, vm.did, tm); 2235 if (res < 0) { 2236 goto _return_res_; 2237 } 2238 break; 2239 } 2240 2241 case 'p' : /* 'print' term */ 2242 if (cpar != &par[1]) 2243 { 2244 Printf_Error(BAD_FORMAT_STRING) 2245 } 2246 Next_Element(elem, list, Printf_Error) 2247 res = ec_pwrite(0, WRITE_OPTIONS_PRINT, nst, 2248 elem->val, elem->tag, 1200, 0, vm.did, tm); 2249 if (res < 0) { 2250 goto _return_res_; 2251 } 2252 break; 2253 2254 case 'q' : /* 'writeq' term */ 2255 if (cpar != &par[1]) 2256 { 2257 Printf_Error(BAD_FORMAT_STRING) 2258 } 2259 Next_Element(elem, list, Printf_Error) 2260 res = ec_pwrite(0, WRITE_OPTIONS_WRITEQ, nst, 2261 elem->val, elem->tag, 1200, 0, vm.did, tm); 2262 if (res < 0) { 2263 goto _return_res_; 2264 } 2265 break; 2266 2267 case 'k' : /* 'display' term */ 2268 if (cpar != &par[1]) 2269 { 2270 Printf_Error(BAD_FORMAT_STRING) 2271 } 2272 Next_Element(elem, list, Printf_Error) 2273 res = ec_pwrite(0, WRITE_OPTIONS_DISPLAY, nst, 2274 elem->val, elem->tag, 1200, 0, vm.did, tm); 2275 if (res < 0) { 2276 goto _return_res_; 2277 } 2278 break; 2279 2280 case 'i' : /* skip term */ 2281 if (asterisk > 1) { 2282 Printf_Error(BAD_FORMAT_STRING) 2283 } 2284 else if (asterisk) 2285 { 2286 Next_Element(elem, list, Printf_Error) 2287 Check_Integer(elem->tag) 2288 i = elem->val.nint; 2289 } 2290 else 2291 { 2292 Get_Counter(par+1,npar,i); 2293 if (i==0) i=1; 2294 } 2295 while (i--) { 2296 Next_Element(elem, list, Printf_Error) 2297 } 2298 break; 2299 2300 case 'b': /* flush buffer */ 2301 if (cpar != &par[1]) 2302 { 2303 Printf_Error(BAD_FORMAT_STRING) 2304 } 2305 if ((res = ec_flush(nst)) < 0) { 2306 if (res == YIELD_ON_FLUSH_REQ) 2307 success_code = res; 2308 else 2309 goto _return_res_; 2310 } 2311 break; 2312 2313 case 'R': 2314 case 'r': /* radix printing */ 2315 if (asterisk > 1) { 2316 Printf_Error(BAD_FORMAT_STRING) 2317 } 2318 else if (asterisk) 2319 { 2320 Next_Element(elem, list, Printf_Error) 2321 Check_Integer(elem->tag) 2322 radix = elem->val.nint; 2323 } 2324 else if (cpar == par + 1) 2325 radix = 8; 2326 else 2327 { 2328 Get_Counter(par+1,npar,radix); 2329 } 2330 if (radix < 2 || radix > 'z' - 'a' + 11) { 2331 Printf_Error(BAD_FORMAT_STRING) 2332 } 2333 Next_Element(elem, list, Printf_Error) 2334 if (IsRef(elem->tag)) { 2335 Printf_Error(INSTANTIATION_FAULT) 2336 } else if (IsInteger(elem->tag) || IsBignum(elem->tag)) { 2337 int bufsize = 1 + tag_desc[TagType(elem->tag)].string_size(elem->val, elem->tag, radix); 2338 char *buf = (char *) hp_alloc_size(bufsize); 2339 int len = tag_desc[TagType(elem->tag)].to_string(elem->val, elem->tag, buf, radix); 2340 if (*cpar == 'R') { 2341 for (res=0,i=0; res==0 && i<len; ++i) 2342 res = ec_outfc(nst, toupper(buf[i])); 2343 } else { 2344 res = ec_outf(nst, buf, len); 2345 } 2346 hp_free_size((generic_ptr) buf, bufsize); 2347 if (res < 0) { 2348 goto _return_res_; 2349 } 2350 } else { 2351 Printf_Error(TYPE_ERROR) 2352 } 2353 break; 2354 2355 default: 2356 Printf_Error(BAD_FORMAT_STRING); 2357 break; 2358 } 2359 cpar = &par[0]; 2360 break; 2361 } 2362 } 2363 else 2364 { 2365 if ((res = ec_outfc(nst, (char) *format)) < 0) 2366 { 2367 goto _return_res_; 2368 } 2369 } 2370 } 2371 if (cpar != &par[0]) { 2372 /* % without a control character */ 2373 Printf_Error(BAD_FORMAT_STRING) 2374 } 2375 if (list) { 2376 Printf_Error(BAD_ARGUMENT_LIST) 2377 } 2378 Unlock_Stream(nst); 2379_return_succ_: 2380 Return_Unify_Integer(verr, terr, success_code) 2381 2382_return_res_: 2383 { 2384 value fv; 2385 Prepare_Requests; 2386 2387 if (last_format) 2388 { 2389 /* stream was already locked, unlock it */ 2390 Unlock_Stream(nst); 2391 2392 /* compute the "remaining" format string and list */ 2393 Cstring_To_Prolog(last_format, fv); 2394 Request_Unify_String(vse, tse, fv.ptr); 2395 if (last_list == 0) { 2396 Request_Unify_Nil(vle, tle); 2397 } else if (last_list == &my_list[0]) { 2398 Request_Unify_Pw(vle, tle, my_list[0].val, my_list[0].tag); 2399 } else { 2400 Request_Unify_List(vle, tle, last_list); 2401 } 2402 } 2403 else 2404 { 2405 Request_Unify_Pw(vse, tse, strval, strtag); 2406 Request_Unify_Pw(vle, tle, lval, ltag); 2407 } 2408 Request_Unify_Integer(verr, terr, -res) 2409 Return_Unify; 2410 } 2411} 2412 2413/* define Bip_Error() back to Bip_Error_Fail() */ 2414#undef Bip_Error 2415#define Bip_Error(N) Bip_Error_Fail(N) 2416 2417static int 2418_printf_asterisk(word asterisk, pword **list, type arg_type, stream_id nst, char *par) 2419{ 2420 pword *elem; 2421 pword *elem2; 2422 pword *elem3; 2423 2424 if (asterisk == 0) 2425 { 2426 Next_Element(elem, (*list), return) 2427 if (IsRef(elem->tag)) 2428 return INSTANTIATION_FAULT; 2429 if (!(SameType(elem->tag, arg_type) || 2430 SameType(arg_type, tstrg) && (IsAtom(elem->tag)||IsNil(elem->tag)) 2431 )) 2432 return(TYPE_ERROR); 2433 switch (TagType(elem->tag)) 2434 { 2435 case TSTRG: 2436 return p_fprintf(nst, par, StringStart(elem->val)); 2437 case TDICT: 2438 return p_fprintf(nst, par, DidName(elem->val.did)); 2439 case TNIL: 2440 return p_fprintf(nst, par, "[]"); 2441 case TDBL: 2442 return p_fprintf(nst, par, Dbl(elem->val)); 2443 case TINT: 2444 return p_fprintf(nst, par, elem->val.nint); 2445 } 2446 } 2447 else if (asterisk == 1) 2448 { 2449 Next_Element(elem, (*list), return) 2450 if (IsRef(elem->tag)) 2451 return INSTANTIATION_FAULT; 2452 else if (!IsInteger(elem->tag)) 2453 return TYPE_ERROR; 2454 Next_Element(elem2, (*list), return) 2455 if (IsRef(elem2->tag)) 2456 return INSTANTIATION_FAULT; 2457 if (!(SameType(elem2->tag, arg_type) || 2458 SameType(arg_type, tstrg) && (IsAtom(elem2->tag)||IsNil(elem2->tag)) 2459 )) 2460 return(TYPE_ERROR); 2461 switch (TagType(elem2->tag)) 2462 { 2463 case TSTRG: 2464 return p_fprintf(nst, par, elem->val.nint, StringStart(elem2->val)); 2465 case TDICT: 2466 return p_fprintf(nst, par, elem->val.nint, DidName(elem2->val.did)); 2467 case TNIL: 2468 return p_fprintf(nst, par, elem->val.nint, "[]"); 2469 case TDBL: 2470 return p_fprintf(nst, par, elem->val.nint, Dbl(elem2->val)); 2471 case TINT: 2472 return p_fprintf(nst, par, elem->val.nint, elem2->val.nint); 2473 } 2474 } 2475 else if (asterisk == 2) 2476 { 2477 Next_Element(elem, (*list), return) 2478 if (IsRef(elem->tag)) 2479 return INSTANTIATION_FAULT; 2480 else if (!IsInteger(elem->tag)) 2481 return TYPE_ERROR; 2482 Next_Element(elem2, (*list), return) 2483 if (IsRef(elem2->tag)) 2484 return INSTANTIATION_FAULT; 2485 else if (!IsInteger(elem2->tag)) 2486 return TYPE_ERROR; 2487 Next_Element(elem3, (*list), return) 2488 if (IsRef(elem3->tag)) 2489 return INSTANTIATION_FAULT; 2490 if (!(SameType(elem3->tag, arg_type) || 2491 SameType(arg_type, tstrg) && (IsAtom(elem3->tag)||IsNil(elem3->tag)) 2492 )) 2493 return(TYPE_ERROR); 2494 switch (TagType(elem3->tag)) 2495 { 2496 case TSTRG: 2497 return p_fprintf(nst, par, 2498 elem->val.nint, elem2->val.nint, StringStart(elem3->val)); 2499 case TDICT: 2500 return p_fprintf(nst, par, 2501 elem->val.nint, elem2->val.nint, DidName(elem3->val.did)); 2502 case TNIL: 2503 return p_fprintf(nst, par, 2504 elem->val.nint, elem2->val.nint, "[]"); 2505 case TDBL: 2506 return p_fprintf(nst, par, 2507 elem->val.nint, elem2->val.nint, Dbl(elem3->val)); 2508 case TINT: 2509 return p_fprintf(nst, par, 2510 elem->val.nint, elem2->val.nint, elem3->val.nint); 2511 } 2512 } 2513 2514 return(BAD_FORMAT_STRING); 2515} 2516 2517 2518/* 2519 * get/set output_mode_mask (as integer) 2520 */ 2521static int 2522p_output_mode_mask(value v, type t) 2523{ 2524 if (IsRef(t)) { 2525 Return_Unify_Integer(v, t, output_mode_mask); 2526 } else { 2527 Check_Integer(t); 2528 if (v.nint & WRITE_GOAL) { /* must not be set */ 2529 Bip_Error(RANGE_ERROR) 2530 } 2531 output_mode_mask = v.nint; 2532 Succeed_; 2533 } 2534} 2535 2536/* 2537 * get/set output_mode_mask (as string) 2538 */ 2539static int 2540p_output_mode(value val, type tag) 2541{ 2542 if (IsRef(tag)) 2543 { 2544 value sv; 2545 char s[OUTPUT_MODES+1]; 2546 2547 _output_mode_string(s, output_mode_mask); 2548 Cstring_To_Prolog(s, sv); 2549 Return_Unify_String(val, tag, sv.ptr); 2550 } 2551 else 2552 { 2553 char *new_output_mode; 2554 int mask, mask_clr; 2555 int res; 2556 2557 Get_Name(val, tag, new_output_mode); 2558 if ((res = _get_mode_mask(new_output_mode, &mask_clr, &mask)) != PSUCCEED) { 2559 Bip_Error(res) 2560 } 2561 if (mask_clr) { /* not supported here */ 2562 Bip_Error(RANGE_ERROR) 2563 } 2564 if (mask & WRITE_GOAL) { /* must not be set */ 2565 Bip_Error(RANGE_ERROR) 2566 } 2567 output_mode_mask = mask; 2568 Succeed_; 2569 } 2570} 2571 2572static void 2573_output_mode_string(char *s, int mask) 2574{ 2575 int i = 0, j; 2576 2577 for (j=0; j<OUTPUT_MODES; j++) 2578 { 2579 if (mask & 1<<j) 2580 s[i++] = output_mode_chars[j]; 2581 } 2582 s[i] = '\0'; 2583} 2584 2585 2586/* 2587 * _get_mode_mask() to decode a printf %w format string: 2588 * 2589 * characters must be those in output_mode_chars[] 2590 * options can be negated by prefixing a - sign 2591 * returns one bit mask with bits to clear, and one with bits to set 2592 * 2593 */ 2594 2595#define MoreThanOneBitSet(n) ((n) & ((n)-1)) /* cute 2's complement trick */ 2596 2597static int 2598_get_mode_mask(char *string, int *clr_mask, int *mask) 2599{ 2600 char c; 2601 char *p; 2602 int negative = 0; 2603 int bit; 2604 2605 *mask = *clr_mask = 0; 2606 for (; (c = *string); ++string) 2607 { 2608 if (c == '-') 2609 { 2610 negative = 1; 2611 continue; 2612 } 2613 if ((p = strchr(output_mode_chars, c))) 2614 bit = 1 << (p - output_mode_chars); 2615 else 2616 return(RANGE_ERROR); 2617 if (negative) 2618 { 2619 negative = 0; 2620 *clr_mask |= bit; 2621 } 2622 else 2623 { 2624 *mask |= bit; 2625 } 2626 } 2627 2628 /* Don't allow setting more than one of the mutually exclusive options */ 2629 if (MoreThanOneBitSet(*mask & (VAR_NUMBERS|VAR_ANON|VAR_NAMENUM)) 2630 || MoreThanOneBitSet(*mask & (STD_ATTR|ATTRIBUTE))) 2631 { 2632 return BAD_FORMAT_STRING; 2633 } 2634 return PSUCCEED; 2635} 2636 2637static int 2638_merge_output_modes(int mask, int remove, int add) 2639{ 2640 mask &= ~remove; 2641 /* if any of the one-of-several-bits options is added, clear bits first */ 2642 if (add & (VAR_NUMBERS|VAR_ANON|VAR_NAMENUM)) 2643 mask &= ~(VAR_NUMBERS|VAR_ANON|VAR_NAMENUM); 2644 if (add & (STD_ATTR|ATTRIBUTE)) 2645 mask &= ~(STD_ATTR|ATTRIBUTE); 2646 return mask | add; 2647} 2648 2649 2650/* A Function to be used in the debugger */ 2651void 2652writeq_term(uword val, uword tag) 2653{ 2654 value v; 2655 type t; 2656 value vm; 2657 2658 v.all = val; 2659 t.kernel = tag; 2660 vm.did = d_.default_module; 2661 2662 (void) p_writeq(v, t, vm, tdict); 2663 ec_flush(current_output_); 2664 (void) ec_newline(current_output_); 2665} 2666 2667 2668/* 2669 * write_term(+Stream, +Term, +ClrOptions, +SetOptions, +Depth, +Precedence, +Module) 2670 * 2671 * Depth=0 use stream's/global default setting 2672 */ 2673static int 2674p_write_term(value vs, type ts, value val, type tag, value vcm, type tcm, 2675 value vsm, type tsm, value vdepth, type tdepth, 2676 value vprec, type tprec, value vm, type tm) 2677{ 2678 int res; 2679 stream_id out = get_stream_id(vs, ts, SWRITE, &res); 2680 2681 Check_Stream(out, res); 2682 Check_Integer(tcm); 2683 Check_Integer(tsm); 2684 Check_Integer(tdepth); 2685 Check_Integer(tprec); 2686 if (vprec.nint < 0 || 1200 < vprec.nint) { Bip_Error(RANGE_ERROR); } 2687 Check_Module(tm, vm); 2688 Lock_Stream(out); 2689 res = ec_pwrite(vcm.nint, vsm.nint, out, val, tag, vprec.nint, vdepth.nint, vm.did, tm); 2690 Unlock_Stream(out); 2691 return res; 2692} 2693 2694 2695/* CAUTION: Bip_Error() is redefined to Bip_Error_Fail() ! */ 2696 2697