home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / plbin.zip / pl / src / pl-write.c < prev    next >
C/C++ Source or Header  |  1993-02-23  |  9KB  |  450 lines
  1. /*  pl-write.c,v 1.3 1993/02/23 13:16:51 jan Exp
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: write/1 and display/1 definition
  8. */
  9.  
  10. #include "pl-incl.h"
  11. #include "pl-ctype.h"
  12. extern int Output;
  13.  
  14. forwards char *    varName P((Word));
  15. forwards void    writePrimitive P((Word, bool));
  16. forwards bool    display P((Word, bool));
  17. forwards int    priorityOperator P((Atom));
  18. forwards bool    writeTerm P((Word, int, bool, Word));
  19. forwards word    displayStream P((Word, Word, bool));
  20. forwards word    writeStreamTerm P((Word, Word, int, int, Word));
  21.  
  22. static char *
  23. varName(adr)
  24. Word adr;
  25. { static char name[10];
  26.  
  27.   if (adr > (Word) lBase)
  28.     sprintf(name, "L%ld", adr - (Word)lBase);
  29.   else
  30.     sprintf(name, "G%ld", adr - (Word)gBase);
  31.  
  32.   return name;
  33. }
  34.  
  35. static void
  36. writePrimitive(w, quote)
  37. Word w;
  38. bool quote;
  39. { char *s, c;
  40.  
  41.   DEBUG(9, printf("writing primitive at 0x%x: 0x%x\n", w, *w));
  42.  
  43.   if (isInteger(*w))
  44.   { Putf("%ld", valNum(*w));
  45.     return;
  46.   }
  47.  
  48.   if (isReal(*w))
  49.   { Putf("%f", valReal(*w));
  50.     return;
  51.   }
  52.  
  53. #if O_STRING
  54.   if ( isString(*w) )
  55.   { s = valString(*w);
  56.     if ( quote == TRUE )
  57.     { Put('\"');
  58.       while( (c = *s++) != EOS )
  59.       { if ( c == '"' )
  60.           Put('"');
  61.         Put(c);
  62.       }
  63.       Put('\"');
  64.     } else
  65.     { Putf("%s", s);
  66.     }
  67.     return;
  68.   }
  69. #endif /* O_STRING */
  70.  
  71.   if (isVar(*w))
  72.   { Putf("%s", varName(w) );
  73.     return;
  74.   }    
  75.   if (isAtom(*w))
  76.   { s = stringAtom(*w);
  77.     DEBUG(9, printf("Atom(%s)\n", s));
  78.     if (quote == TRUE)
  79.     { if (isLower(*s))
  80.       { char *s2;
  81.  
  82.     for(s2 = s; *s2 && isAlpha(*s2); )
  83.       s2++;
  84.     if (*s2 == EOS)
  85.     { Putf("%s", stringAtom(*w) );    /* starts lower, rest alpha */
  86.       return;
  87.     }
  88.       }
  89.       if (streq(s, ".") )            /* otherwise might be seen */
  90.       { Putf("'.'");                /* as a full stop */
  91.     return;
  92.       }
  93.       if (isSymbol(*s))
  94.       { char *s2;
  95.  
  96.     for(s2 = s; *s2 && isSymbol(*s2); )
  97.       s2++;
  98.     if (*s2 == EOS)
  99.     { Putf("%s", stringAtom(*w) );    /* all symbol */
  100.       return;
  101.     }
  102.       }
  103.       if ((isSolo(*s) || *s == ',') && s[1] == EOS)
  104.       { Putf("%s", stringAtom(*w) );        /* just a solo */
  105.     return;
  106.       }
  107.       if (streq(s, "[]") || streq(s, "{}") )    /* specials */
  108.       { Putf("%s", s);
  109.     return;
  110.       }
  111.       Put('\'');
  112.       while( (c = *s++) != EOS )
  113.     if (c == '\'')
  114.       Putf("''");
  115.     else
  116.       Put(c);
  117.       Put('\'');
  118.       return;
  119.     } else
  120.     { Putf("%s", stringAtom(*w) );
  121.       return;
  122.     }
  123.   }
  124. }
  125.  
  126. word
  127. pl_nl()
  128. { return Put('\n');
  129. }
  130.  
  131. word
  132. pl_nl1(stream)
  133. Word stream;
  134. { streamOutput(stream, pl_nl());
  135. }
  136.  
  137.  
  138. static bool
  139. display(t, quote)
  140. Word t;
  141. bool quote;
  142. { int n;
  143.   int arity;
  144.   Word arg;
  145.  
  146.   DEBUG(9, printf("display term at 0x%x; ", t));
  147.   deRef(t);
  148.   DEBUG(9, printf("after deRef() at 0x%x\n", t));
  149.  
  150.   if (isPrimitive(*t) )
  151.   { DEBUG(9, printf("primitive\n"));
  152.     writePrimitive(t, quote);
  153.     succeed;
  154.   }
  155.  
  156.   arity = functorTerm(*t)->arity;
  157.   arg = argTermP(*t, 0);
  158.   DEBUG(9, printf("Complex; arg0 at 0x%x, arity = %d\n", arg, arity));
  159.  
  160.   DEBUG(9, printf("functorTerm() = 0x%x, ->name = 0x%x\n",
  161.                 functorTerm(*t), functorTerm(*t)->name));
  162.   writePrimitive((Word)&(functorTerm(*t)->name), quote);
  163.   Putf("(");
  164.   for(n=0; n<arity; n++, arg++)
  165.   { if (n > 0)
  166.       Putf(", ");
  167.     display(arg, quote);
  168.   }
  169.   Putf(")");
  170.  
  171.   succeed;
  172. }
  173.  
  174. word
  175. pl_display(term)
  176. Word term;
  177. { return display(term, FALSE);
  178. }
  179.  
  180. word
  181. pl_displayq(term)
  182. Word term;
  183. { return display(term, TRUE);
  184. }
  185.  
  186. static word
  187. displayStream(stream, term, quote)
  188. Word stream, term;
  189. bool quote;
  190. { streamOutput(stream, display(term, quote));
  191. }
  192.  
  193. word
  194. pl_display2(stream, term)
  195. Word stream, term;
  196. { return displayStream(stream, term, FALSE);
  197. }
  198.  
  199. word
  200. pl_displayq2(stream, term)
  201. Word stream, term;
  202. { return displayStream(stream, term, TRUE);
  203. }
  204.  
  205. static int
  206. priorityOperator(atom)
  207. Atom atom;
  208. { int type, priority;
  209.   int result = 0;
  210.  
  211.   if (isPrefixOperator(atom, &type, &priority) && priority > result)
  212.     result = priority;
  213.   if (isPostfixOperator(atom, &type, &priority) && priority > result)
  214.     result = priority;
  215.   if (isInfixOperator(atom, &type, &priority) && priority > result)
  216.     result = priority;
  217.  
  218.   return result;
  219. }
  220.  
  221. /*  write a term. The 'enviroment' precedence is prec. 'style' askes
  222.     for plain writing (write/1), quoting (writeq/1) or portray (print/1)
  223.  
  224.  ** Sun Apr 17 12:48:09 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  225.  
  226. #define PLAIN        0
  227. #define QUOTE_ATOMS    1
  228. #define PORTRAY        2
  229.  
  230. /*  Call Prolog predicate $portray/1 on 'term'. Succeed or fail
  231.     according to the result.
  232.  
  233.  ** Sun Jun  5 15:37:12 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  234.  
  235. static bool
  236. pl_call2(goal, arg)
  237. Word goal;
  238. Word arg;
  239. { Module mod = NULL;
  240.   Atom name;
  241.   int arity;
  242.   word g;
  243.   mark m;
  244.   int n;
  245.   bool rval;
  246.  
  247.   TRY(goal = stripModule(goal, &mod));
  248.   deRef(goal);
  249.  
  250.   if ( isAtom(*goal) )
  251.   { name = (Atom) *goal;
  252.     arity = 0;
  253.   } else if ( isTerm(*goal) )
  254.   { name = functorTerm(*goal)->name;
  255.     arity = functorTerm(*goal)->arity;
  256.   } else
  257.     return warning("call/2: instantiation fault");
  258.   
  259.   Mark(m);
  260.   g = globalFunctor(lookupFunctorDef(name, arity+1));
  261.   for(n = 0; n < arity; n++)
  262.     pl_unify(argTermP(g, n), argTermP(goal, n));
  263.   pl_unify(argTermP(g, n), arg);
  264.   debugstatus.suspendTrace++;
  265.   rval = callGoal(mod, g, FALSE);
  266.   debugstatus.suspendTrace--;
  267.   Undo(m);
  268.  
  269.   return rval;
  270. }
  271.  
  272.  
  273. static bool
  274. writeTerm(term, prec, style, g)
  275. Word term;
  276. int prec;
  277. bool style;
  278. Word g;
  279. { Atom functor;
  280.   int arity, n;
  281.   int op_type, op_pri;
  282.   Word arg;
  283.   bool quote = (style != PLAIN);
  284.  
  285.   deRef(term);
  286.  
  287.   if ( !isVar(*term) && style == PORTRAY && pl_call2(g, term) )
  288.     succeed;
  289.  
  290.   if (isPrimitive(*term) )
  291.   { if (isAtom(*term) && priorityOperator((Atom)*term) > prec)
  292.     { Put('(');
  293.       writePrimitive(term, quote);
  294.       Put(')');
  295.     } else
  296.       writePrimitive(term, quote);
  297.  
  298.     succeed;
  299.   }
  300.  
  301.   functor = functorTerm(*term)->name;
  302.   arity = functorTerm(*term)->arity;
  303.   arg = argTermP(*term, 0);
  304.  
  305.   if (arity == 1)
  306.   { if (functor == ATOM_curl)
  307.     { Put('{');
  308.       for(;;)
  309.       { deRef(arg);
  310.     if (!isTerm(*arg) || functorTerm(*arg) != FUNCTOR_comma2)
  311.       break;
  312.     writeTerm(argTermP(*arg, 0), 999, style, g);
  313.     Put(',');
  314.     arg = argTermP(*arg, 1);
  315.       }
  316.       writeTerm(arg, 999, style, g);      
  317.       Put('}');
  318.       succeed;
  319.     }
  320.     if (isPrefixOperator(functor, &op_type, &op_pri) )
  321.     { if (op_pri > prec)
  322.     Put('(');
  323.       writePrimitive((Word) &functor, quote);
  324.       Put(' ');
  325.       writeTerm(arg, op_type == OP_FX ? op_pri-1 : op_pri, style, g);
  326.       if (op_pri > prec)
  327.     Put(')');
  328.       succeed;
  329.     }
  330.     if (isPostfixOperator(functor, &op_type, &op_pri) )
  331.     { if (op_pri > prec)
  332.     Put('(');
  333.       writeTerm(arg, op_type == OP_XF ? op_pri-1 : op_pri, style, g);
  334.       Put(' ');
  335.       writePrimitive((Word)&functor, quote);
  336.       if (op_pri > prec)
  337.     Put(')');
  338.       succeed;
  339.     }
  340.   } else if (arity == 2)
  341.   { if (functor == ATOM_dot)
  342.     { Put('[');
  343.       for(;;)
  344.       { writeTerm(arg++, 999, style, g);
  345.     deRef(arg);
  346.     if (*arg == (word) ATOM_nil)
  347.       break;
  348.     if (!isList(*arg) )
  349.     { Put('|');
  350.       writeTerm(arg, 999, style, g);
  351.       break;
  352.     }
  353.     Put(',');
  354.     arg = HeadList(arg);
  355.       }
  356.       Put(']');
  357.       succeed;
  358.     }
  359.     if (isInfixOperator(functor, &op_type, &op_pri) )
  360.     { if (op_pri > prec)
  361.     Put('(');
  362.       writeTerm(arg++, 
  363.         op_type == OP_XFX || op_type == OP_XFY ? op_pri-1 : op_pri, 
  364.         style, g);
  365.       if (functor != ATOM_comma)
  366.     Put(' ');
  367.       writePrimitive((Word)&functor, quote);
  368.       Put(' ');
  369.       writeTerm(arg, 
  370.         op_type == OP_XFX || op_type == OP_YFX ? op_pri-1 : op_pri, 
  371.         style, g);
  372.       if (op_pri > prec)
  373.     Put(')');
  374.       succeed;
  375.     }
  376.   }
  377.  
  378.   writePrimitive((Word)&functor, quote);
  379.   Put('(');
  380.   for(n=0; n<arity; n++, arg++)
  381.   { if (n > 0)
  382.       Putf(", ");
  383.     writeTerm(arg, 999, style, g);
  384.   }
  385.   Put(')');
  386.  
  387.   succeed;
  388. }
  389.  
  390. word
  391. pl_write(term)
  392. Word term;
  393. { writeTerm(term, 1200, PLAIN, NULL);
  394.  
  395.   succeed;
  396. }
  397.  
  398. word
  399. pl_writeq(term)
  400. Word term;
  401. { writeTerm(term, 1200, QUOTE_ATOMS, NULL);
  402.  
  403.   succeed;
  404. }
  405.  
  406. word
  407. pl_print(term)
  408. Word term;
  409. { word g = (word) ATOM_portray;
  410.  
  411.   writeTerm(term, 1200, PORTRAY, &g);
  412.  
  413.   succeed;
  414. }
  415.  
  416. word
  417. pl_dprint(term, g)
  418. Word term, g;
  419. { writeTerm(term, 1200, PORTRAY, g);
  420.  
  421.   succeed;
  422. }
  423.  
  424. static word
  425. writeStreamTerm(stream, term, prec, style, g)
  426. Word stream, term, g;
  427. int prec, style;
  428. { streamOutput(stream, writeTerm(term, prec, style, g));
  429. }
  430.  
  431. word
  432. pl_write2(stream, term)
  433. Word stream, term;
  434. { return writeStreamTerm(stream, term, 1200, PLAIN, NULL);
  435. }
  436.  
  437. word
  438. pl_writeq2(stream, term)
  439. Word stream, term;
  440. { return writeStreamTerm(stream, term, 1200, QUOTE_ATOMS, NULL);
  441. }
  442.  
  443. word
  444. pl_print2(stream, term)
  445. Word stream, term;
  446. { word g = (word) ATOM_portray;
  447.  
  448.   return writeStreamTerm(stream, term, 1200, PORTRAY, &g);
  449. }
  450.