home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / glass / glass.lha / GLASS / contsens / contsens.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-02-08  |  57.0 KB  |  2,146 lines
  1.  
  2. /*   Copyright (C) 1990 Riet Oolman
  3.  
  4. This file is part of GLASS.
  5.  
  6. GLASS is free software; you can redistribute it and/or modify
  7. it under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 1, or (at your option)
  9. any later version.
  10.  
  11. GLASS is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. GNU General Public License for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with GLASS; see the file COPYING.  If not, write to
  18. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. /* file: contsens.c
  21.    author: H. Oolman
  22.    last modified: 8-2-1991
  23.    purpose: procedures for context-sensitive checks on Glass
  24.    modifications: p2c translated, tmc access procs.
  25. */
  26.  
  27. #include "handleds.h"
  28. #include "check.ds.h"
  29. #include "check.var.h"
  30. #include "check.afuncs.h"
  31. #include "errorenv.h"
  32. #include "unification.h"
  33. #include "contsens.h"
  34.  
  35. Local typcrec *replacelocssome ();
  36.  
  37. typedef struct typcrec * adirindic ;
  38. /* to inidcate if a system application should be interpreted adirectionally
  39.    (if type APPSET) or unidirectionally (otherwise) */
  40.  
  41. #define makeadirwanted  BuildAPS()
  42. /* adirectional system application wanted */
  43. #define makedirwanted  BuildUNKNOWN(0L,false,false)
  44. /* unidirectional system application wanted */
  45. #define makewanted(t) replacelocssome(t,true)
  46. /* turn type into info on what kind of system appl. is wanted */
  47. /* These three make an adirindic */
  48.  
  49. Void splitwanted(ty, frst, scnd)
  50. /* split ty, which should be composed, in parts frst and scnd
  51.    to be used in subparts of a ':' expression */
  52. adirindic ty, *frst, *scnd;
  53. { while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
  54.   if (ty->kind == kindCT)
  55.   { *frst = ty->CT.tcfirst;
  56.     *scnd = ty->CT.tcrest;
  57.   }
  58.   else if (ty->kind == kindSOME)
  59.   { *frst = ty->SOME.tcpart;
  60.     *scnd = ty;
  61.   } else { *frst = makedirwanted;
  62.        *scnd = *frst;
  63.      }
  64. }
  65.  
  66. boolean adirwanted(ty)
  67. /* test if adirectional system application wanted */
  68. adirindic ty;
  69. { while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
  70.   return (ty->kind == kindAPS);
  71. }
  72.  
  73. Local typcrec *typeval PP((adirindic appnon, val vl, envrec *btns_,
  74.                   long splitlevel_));
  75.  
  76. Local Void WritesymbolNoext(f, nm)
  77. FILE *f;
  78. symbol nm;
  79. { /* Because it is not known beforehand if errors will occur,
  80.      all names are extended if uiq is true. But in printing
  81.      error messages it is nicer if they are not there.
  82.      This procedure prints a name nm without extension. */
  83.   long i, lth;
  84.  
  85.   lth = nm->length;
  86.   if (uniq) {
  87.     while (nm->body[lth - 1] != '_' && lth > 0)
  88.       lth--;
  89.     lth--;
  90.   }
  91.   for (i = 0; i < lth; i++)
  92.     putc(nm->body[i], f);
  93. }
  94.  
  95. Local Void unparsfp(f, fmp)
  96. FILE *f;
  97. fp fmp;
  98. { /* unparses fp's */
  99.   switch (fmp->tag) {
  100.  
  101.   case TAGFpComp:
  102.     putc('(', f);
  103.     unparsfp(f, fmp->FpComp.fpfirst);
  104.     fprintf(f, "): ");
  105.     unparsfp(f, fmp->FpComp.fprest);
  106.     break;
  107.  
  108.   case TAGFpEmpty:
  109.     fprintf(f, "[]");
  110.     break;
  111.  
  112.   case TAGFpList:
  113.     putc('[', f);
  114.     fmp = fmp->FpList.fplist;
  115.     while (fmp != NULL) {
  116.       unparsfp(f, fmp);
  117.       fmp = fmp->next;
  118.       if (fmp != NULL)
  119.      fprintf(f, ", ");
  120.     }
  121.     putc(']', f);
  122.     break;
  123.  
  124.   case TAGFpName:
  125.     WritesymbolNoext(f, fmp->FpName.fpsym);
  126.     break;
  127.  
  128.   case TAGFpInt:
  129.     fprint_inum(f, fmp->FpInt.fpi);
  130.     break;
  131.  
  132.   case TAGFpFlo:
  133.     fprint_fnum(f, fmp->FpFlo.fpf);
  134.     break;
  135.  
  136.   case TAGFpStr:
  137.     fprint_string(f, fmp->FpStr.fps);
  138.     break;
  139.  
  140.   case TAGFpBool:
  141.     if (fmp->FpBool.fpb)
  142.       fprintf(f, "TRUE");
  143.     else
  144.       fprintf(f, "FALSE");
  145.     break;
  146.   }
  147. }  /* unparsfp */
  148.  
  149. /* true <-> data struct. adaptations for the use of macro
  150.    expander the result of which is not handled by the type
  151.    checker */
  152.  
  153. Local Void unparsval(f, vl)
  154. FILE *f;
  155. val vl;
  156. { /* unparses (most) val's  */
  157.   long l;
  158.   string op;
  159.  
  160.   switch (vl->tag) {
  161.  
  162.   case TAGVValApply:
  163.     unparsval(f, vl->VValApply.avval);
  164.     fprintf(f, " (");
  165.     unparsval(f, vl->VValApply.avpar);
  166.     putc(')', f);
  167.     break;
  168.  
  169.   case TAGVSym:
  170.     WritesymbolNoext(f, vl->VSym.sym);
  171.     if (takewarning) {
  172.       fprintf(f, "/*");
  173.       myprint_orig(f,vl->VSym.symorig);
  174.       fprintf(f, "*/");
  175.     }
  176.     break;
  177.  
  178.   case TAGVInt:
  179.     fprint_inum(f,vl->VInt.i);
  180.     break;
  181.  
  182.   case TAGVFlo:
  183.     fprint_fnum(f,vl->VFlo.f);
  184.     break;
  185.  
  186.   case TAGVStr:
  187.     fprint_string(f,vl->VStr.s);
  188.     break;
  189.  
  190.   case TAGVBool:
  191.     if (vl->VBool.b)
  192.       fprintf(f, "TRUE");
  193.     else
  194.       fprintf(f, "FALSE");
  195.     break;
  196.  
  197.   case TAGVAtom:
  198.   case TAGVType:
  199.   case TAGVMacAlts:
  200.     error(10L, NULL, NULL, Buildsymbol( "unparsval", 9L), NULL, false);
  201.     break;
  202.  
  203.   case TAGVSysLambda:
  204.     putc('%', f);
  205.     unparsfp(f, vl->VSysLambda.slpar);
  206.     putc('.', f);
  207.     unparsval(f, vl->VSysLambda.slval);
  208.     break;
  209.  
  210.   case TAGVSysSigma:
  211.     putc('$', f);
  212.     unparsfp(f, vl->VSysSigma.sspar);
  213.     putc('.', f);
  214.     unparsval(f, vl->VSysSigma.ssval);
  215.     break;
  216.  
  217.   case TAGVSysApply:
  218.     unparsval(f, vl->VSysApply.asval);
  219.     fprintf(f, " (");
  220.     unparsval(f, vl->VSysApply.aspar);
  221.     putc(')', f);
  222.     break;
  223.  
  224.   case TAGVWhere:
  225.     unparsval(f, vl->VWhere.wval);
  226.     fprintf(f, " Where .... Endwhere");
  227.     break;
  228.  
  229.   case TAGVList:
  230.     putc('[', f);
  231.     vl = vl->VList.l;
  232.     while (vl != NULL) {
  233.       unparsval(f, vl);
  234.       vl = vl->next;
  235.       if (vl != NULL)
  236.      fprintf(f, ", ");
  237.     }
  238.     putc(']', f);
  239.     break;
  240.  
  241.   case TAGVAppset:
  242.     putc('{', f);
  243.     vl = vl->VAppset.aps;
  244.     while (vl != NULL) {
  245.       unparsval(f, vl);
  246.       vl = vl->next;
  247.       if (vl != NULL)
  248.      fprintf(f, ", ");
  249.     }
  250.     putc('}', f);
  251.     break;
  252.  
  253.   case TAGVSyn:
  254.     fprintf(f, "*[");
  255.     vl = vl->VSyn.synlist;
  256.     while (vl != NULL) {
  257.       unparsval(f, vl);
  258.       vl = vl->next;
  259.       if (vl != NULL)
  260.      fprintf(f, ", ");
  261.     }
  262.     putc(']', f);
  263.     break;
  264.  
  265.   case TAGVMacLambda:
  266.     if (vl->VMacLambda.mval == NULL)   /* !! used to pack fp */
  267.       unparsfp(f, vl->VMacLambda.mpar);
  268.     else {
  269.       fprintf(f, "\\(");
  270.       unparsfp(f, vl->VMacLambda.mpar);
  271.       fprintf(f, ").");
  272.       unparsval(f, vl->VMacLambda.mval);
  273.     }
  274.     break;
  275.  
  276.   case TAGVBuiltin:
  277.     op = vl->VBuiltin.oper;
  278.     if (cmp_string(op, "->")==0) {
  279.       unparsval(f, vl->VBuiltin.args);
  280.       fprintf(f, "->");
  281.       unparsval(f, vl->VBuiltin.args->next);
  282.       fprintf(f, "; ");
  283.       unparsval(f, vl->VBuiltin.args->next->next);
  284.     } else {
  285.       if (cmp_string(op,"[]")==0) {
  286.      unparsval(f, vl->VBuiltin.args);
  287.      fprintf(f, " (");
  288.      unparsval(f, vl->VBuiltin.args->next);
  289.      putc(')', f);
  290.       } else {
  291.      if (cmp_string(op, "[..]")==0) {
  292.        unparsval(f, vl->VBuiltin.args);
  293.        fprintf(f, " @(");
  294.        unparsval(f, vl->VBuiltin.args->next);
  295.        fprintf(f, ")...(");
  296.        unparsval(f, vl->VBuiltin.args->next->next);
  297.        putc(')', f);
  298.      } else {
  299.        if (cmp_string(op, "+1")==0) {
  300.          putc('+', f);
  301.          unparsval(f, vl->VBuiltin.args);
  302.        } else {
  303.          if (cmp_string(op, "-1")==0) {
  304.            putc('-', f);
  305.            unparsval(f, vl->VBuiltin.args);
  306.          } else {
  307.            if (cmp_string(op, "~")==0) {
  308.           putc('~', f);
  309.           unparsval(f, vl->VBuiltin.args);
  310.            } else {
  311.           if (cmp_string(op, "itof")==0) {
  312.             fprintf(f, "itof ");
  313.             unparsval(f, vl->VBuiltin.args);
  314.           } else {
  315.             if ((cmp_string(op, "^")==0) | (cmp_string(op,":")==0)) {
  316.               putc('(', f);
  317.               unparsval(f, vl->VBuiltin.args);
  318.               putc(')', f);
  319.               fprintf(f, op);
  320.               putc(' ', f);
  321.               unparsval(f, vl->VBuiltin.args->next);
  322.             } else {
  323.               if ((cmp_string(op,"=")==0) | (cmp_string(op,"/=")==0) |
  324.                  (cmp_string(op,"<")==0) | (cmp_string(op,"<=")==0) |
  325.                  (cmp_string(op,">=")==0) | (cmp_string(op,">")==0) |
  326.                  (cmp_string(op,"*")==0) | (cmp_string(op,"/")==0) |
  327.                  (cmp_string(op,"DIV")==0) | (cmp_string(op,"MOD")==0) |
  328.                  (cmp_string(op,"&")==0) | (cmp_string(op,"|")==0) |
  329.                  (cmp_string(op,"-2")==0) | (cmp_string(op,"+2")==0)) {
  330.                 unparsval(f, vl->VBuiltin.args);
  331.                 putc(' ', f);
  332.                 if (cmp_string(op,"-2")==0)
  333.                putc('-', f);
  334.                 else if (cmp_string(op, "+2")==0)
  335.                putc('+', f);
  336.                 else
  337.                fprintf(f, op);
  338.                 fprintf(f, " (");
  339.                 unparsval(f, vl->VBuiltin.args->next);
  340.                 putc(')', f);
  341.               } else
  342.         {l=0; while (op[l]!='\0') l++;
  343.                 error(10L, NULL, NULL, Buildsymbol(op,l), NULL, false);}
  344.             }
  345.           }
  346.            }
  347.          }
  348.        }
  349.      }
  350.       }
  351.     }
  352.     break;
  353.   }
  354. }  /* unparsval */
  355.  
  356. /* Local variables for convtype: */
  357. struct LOC_convtype {
  358.   envrec *btns;
  359.   orig typorig;
  360.   symbol loctyvars, boundnames;
  361. } ;
  362.  
  363. Local dirgraphrec *extractdirs(t)
  364. /* extract the directions in a systemtype. Easy for comparing */
  365. typ t;
  366. {
  367.  
  368.   switch (t->tag) {
  369.  
  370.   case TAGTypUni:
  371.     return BuildCd(BuildOd(BuildIN()),
  372.                BuildCd(BuildOd(BuildOUT()), BuildOd(BuildNON())));
  373.     break;
  374.  
  375.   case TAGTypNon:
  376.     return extractdirs(t->TypNon.nontyp);
  377.     break;
  378.  
  379.   case TAGTypProd:
  380.     if (t->TypProd.ptypes == NULL)
  381.       return BuildOd(BuildNON());
  382.     else {
  383.       return BuildCd(extractdirs(t->TypProd.ptypes),
  384.                  extractdirs(new_TypProd(t->TypProd.ptypes->next)));
  385.     }
  386.     break;
  387.  
  388.   case TAGTypAtom:
  389.     return BuildOd(BuildNON());
  390.     break;
  391.  
  392.   case TAGTypIn:
  393.     return BuildOd(BuildIN());
  394.     break;
  395.  
  396.   case TAGTypOut:
  397.     return BuildOd(BuildOUT());
  398.     break;
  399.  
  400.   case TAGTypPwr:
  401.     return BuildSd(extractdirs(t->TypPwr.pwrtyp),
  402.                      BuildOd(BuildNON()));
  403.     break;
  404.   case TAGTypStar:
  405.     return BuildSd(extractdirs(t->TypStar.startyp),
  406.                      BuildOd(BuildNON()));
  407.     break;
  408.  
  409.   case TAGTypLocal:
  410.     return extractdirs(t->TypLocal.loctyp);
  411.     break;
  412.  
  413.   case TAGTypSym:
  414.     return BuildOd(BuildNON());
  415.     break;
  416.  
  417.   case TAGTypAppset:
  418.   case TAGTypFun:
  419.   case TAGTypInt:
  420.   case TAGTypFlo:
  421.   case TAGTypBind:
  422.   case TAGTypBool:
  423.   case TAGTypString:
  424.     error(8L, NULL, NULL, NULL, NULL, false);
  425.     return BuildOd(BuildNON());
  426.     break;
  427.   }
  428. }
  429.  
  430. Local Void addnumnamestoenv(e)
  431.   /* adds names to curenv, with type INT, if not yet present;
  432.      otherwise redirects namepointer
  433.      e: expression in power type */
  434. val e;
  435. {
  436.   symbol nm;
  437.  
  438.   switch (e->tag) {
  439.  
  440.   case TAGVValApply:
  441.     addnumnamestoenv(e->VValApply.avpar);
  442.     addnumnamestoenv(e->VValApply.avval);
  443.     break;
  444.  
  445.   case TAGVSym:
  446.     nm = e->VSym.sym;
  447.     if (lookup(curenv, &nm) == NULL) {
  448.       error(21L, NULL, NULL, nm, NULL, true);
  449.       update(&curenv, nm, BuildINT());
  450.     } else
  451.       e->VSym.sym = nm;
  452.     break;
  453.  
  454.   case TAGVInt:
  455.   case TAGVFlo:
  456.   case TAGVStr:
  457.   case TAGVBool:   /* ready */
  458.     break;
  459.  
  460.   case TAGVList:
  461.     e = e->VList.l;
  462.     while (e != NULL) {
  463.       addnumnamestoenv(e);
  464.       e = e->next;
  465.     }
  466.     break;
  467.  
  468.   case TAGVBuiltin:
  469.     e = e->VBuiltin.args;
  470.     while (e != NULL) {
  471.       addnumnamestoenv(e);
  472.       e = e->next;
  473.     }
  474.     break;
  475.  
  476.   case TAGVType:
  477.   case TAGVSysLambda:
  478.   case TAGVSysSigma:
  479.   case TAGVSysApply:
  480.   case TAGVMacAlts:
  481.   case TAGVMacLambda:
  482.   case TAGVWhere:
  483.   case TAGVAppset:
  484.   case TAGVAtom:
  485.   case TAGVSyn:
  486.     error(20L, NULL, NULL, NULL, NULL, false);
  487.     break;
  488.   }
  489. }  /* addnumnamestoenv */
  490.  
  491. Local typcrec *conv(glty, mustconn, LINK)
  492.   /* make tc form for glty: names replaced by   
  493.      loc.ty.var/basetype/typename,
  494.      extract directions, listtypes to some, Prodtype to
  495.      comp.type; also some simple checks
  496.      mustconn: glty must be a connection type
  497.      check if no -:n names occur more than once in glty, and if
  498.      the expression in a power type give integers; make the int.
  499.      names unique if uniq */
  500. typ glty;
  501. boolean mustconn;
  502. struct LOC_convtype *LINK;
  503. { /* ass.: restrictions on type (except for names) checked by parser */
  504.   symbol n;
  505.   typcrec *tc, *Result;
  506.   envrec *cur;
  507.  
  508.   switch (glty->tag) {
  509.  
  510.   case TAGTypAtom:
  511.     Result = BuildBASETY(Copysymbol(glty->TypAtom.atomnm),     
  512.                          newname(),
  513.                          LINK->typorig);
  514.     /* make glty^.atomnm point to btns: */
  515.     n = glty->TypAtom.atomnm;
  516.     tc = lookup(LINK->btns, &n);
  517.     glty->TypAtom.atomnm = n;
  518.     return Result;
  519.     break;
  520.  
  521.   case TAGTypFun:
  522.     if (glty->TypFun.funpar->tag == TAGTypBind) {
  523.       n = glty->TypFun.funpar->TypBind.boundname;
  524.       addunequal(n, &LINK->boundnames);
  525.       update(&curenv, n, BuildINT());
  526.       cur = curenv;
  527.       tc = conv(glty->TypFun.funres, false, LINK);
  528.       /* unbound names from $e$ in $t^e$ types found in
  529.      funres are added to curenv */
  530.       if (adaptds && uniq)
  531.       addext(cur->name0, cur->uniqext);
  532.       cur->name0 = marker;
  533.        /* turn into marker: invisible */
  534.       return BuildSINGLEARROW(BuildINT(), tc);
  535.     } else
  536.       return BuildSINGLEARROW(
  537.                     conv(glty->TypFun.funpar, false, LINK),
  538.                     conv(glty->TypFun.funres, false, LINK));
  539.     break;
  540.  
  541.   case TAGTypIn:
  542.     return conv(glty->TypIn.ityp, true, LINK);
  543.     break;
  544.  
  545.   case TAGTypOut:
  546.     return conv(glty->TypOut.otyp, true, LINK);
  547.     break;
  548.  
  549.   case TAGTypUni:
  550.     return BuildSYSTY(extractdirs(glty),
  551.      BuildCT(conv(glty->TypUni.uityp, true, LINK),
  552.           BuildCT(conv(glty->TypUni.uotyp, true, LINK),
  553.                BuildSOME(BuildUNKNOWN(newname(), false, true),
  554.                       newname()))));
  555.     break;
  556.  
  557.   case TAGTypNon:
  558.     return BuildSYSTY(extractdirs(glty),
  559.                        conv(glty->TypNon.nontyp, true, LINK));
  560.     break;
  561.  
  562.   case TAGTypInt:
  563.     return BuildINT();
  564.     break;
  565.  
  566.   case TAGTypBind:
  567.     return BuildINT();
  568.     break;
  569.  
  570.   case TAGTypFlo:
  571.     return BuildFLOAT();
  572.     break;
  573.  
  574.   case TAGTypString:
  575.     return BuildSTRING();
  576.     break;
  577.  
  578.   case TAGTypBool:
  579.     return BuildBOOL();
  580.     break;
  581.  
  582.   case TAGTypAppset:
  583.     return BuildAPS();
  584.     break;
  585.  
  586.   case TAGTypPwr:
  587.     addnumnamestoenv(glty->TypPwr.pwrval);
  588.     compat(BuildINT(),
  589.            typeval(makedirwanted, glty->TypPwr.pwrval, NULL, 0L),
  590.            glty->TypPwr.pwrval);
  591.     return BuildSOME(conv(glty->TypPwr.pwrtyp, mustconn, LINK),
  592.                        newname());
  593.     break;
  594.  
  595.   case TAGTypProd:
  596.     if (glty->TypProd.ptypes == NULL) {
  597.       return BuildSOME(BuildUNKNOWN(newname(), false,
  598.                          mustconn), newname());
  599.       /* !! mog. foute invulling voor UNKNOWN false false */
  600.     } else {
  601.       return BuildCT
  602.                 (conv(glty->TypProd.ptypes, mustconn, LINK),
  603.                  conv(new_TypProd(glty->TypProd.ptypes->next),
  604.                       mustconn, LINK));
  605.     }
  606.     break;
  607.  
  608.   case TAGTypStar:
  609.     return BuildSOME
  610.                (conv(glty->TypStar.startyp, mustconn,  LINK),
  611.                 newname());
  612.     break;
  613.  
  614.   case TAGTypSym:
  615.     n = glty->TypSym.sym;
  616.     tc = lookup(LINK->btns, &n);
  617.     if (tc == NULL) 
  618.     { error(1L, NULL, NULL, n, NULL, false);
  619.       return BuildUNKNOWN(newname(), false, false);
  620.     } else 
  621.     { glty->TypSym.sym = n; return tc;}
  622.     break;
  623.   }
  624. }  /* conv */
  625.  
  626. Local nminstrec *convlocs(lnames)
  627.   /* lnames does not contain double names; in result all get inst. nr. 0 */
  628. symbol lnames;
  629. {
  630.   nminstrec *nmi;
  631.  
  632.   if (lnames == NULL) return NULL;
  633.   else {
  634.     nmi = Buildnminstptr(lnames, 0L);
  635.     nmi->next = convlocs(lnames->next);
  636.     return nmi;
  637.   }
  638. }  /* convlocs */
  639.  
  640. Local typcrec *convtype(glty, btns_, typorig_)
  641.   /* glty: glass type to be converted to tc form (and checked for
  642.            grammatical correctness)
  643.      btns_: BT/TN names plus types in glty
  644.      typorig_: orig, if glty is the typas of a DefTyp */
  645. typ glty;
  646. envrec *btns_;
  647. orig typorig_;
  648. { 
  649.   struct LOC_convtype V;
  650.   typcrec *Result;
  651.   symbol l1, l2, l2o;
  652.   envrec *oce;
  653.  
  654.   V.typorig = typorig_;
  655.   if (glty->tag == TAGTypLocal) {
  656.     V.loctyvars = glty->TypLocal.locsyms;
  657.     glty = glty->TypLocal.loctyp;
  658.   } else
  659.     V.loctyvars = NULL;
  660.   l1 = NULL;
  661.   l2 = V.loctyvars;
  662.   mark_(&btns_);
  663.   while (l2 != NULL) {/* remove double names from loctyvars */
  664.     if (!isin(l2, l1)) {
  665.       l2o = l2;
  666.       addcopy(l2, &l1);
  667.       update(&btns_,l2,BuildLOC(l2,0L));
  668.     } else
  669.       l2o->next = l2->next;
  670.     l2 = l2->next;
  671.   }
  672.   V.btns = btns_;
  673.   oce = curenv;
  674.   curenv = NULL;
  675.   mark_(&curenv);   /* for the -: n names */
  676.   V.boundnames = NULL;   /* the -:n names */
  677.   Result = BuildALL(convlocs(V.loctyvars), 
  678.                     conv(glty, false, &V));
  679.   while (curenv != NULL)
  680.     release_(&curenv, adaptds && uniq);
  681.   /* make -:n names and those in power types unique
  682.      while loop because of names made invisible by turning into marker */
  683.   curenv = oce;
  684.   release_(&btns_,adaptds && uniq); /* make loc. ty.vars. unique */
  685.   return Result;
  686. }  /* convtype */
  687.  
  688. Local envrec *extendbtns(elts, btns)
  689.   /* btns: environment of BASETYPE/TYPE names plus tc-form of
  690.            defining types;
  691.      elts: list of defs, the BASETYPEs/TYPEs from which are to
  692.            extend btns for forming the result;
  693.      in the tc types in this btns env. names for BT/TY have been
  694.      replaced by redirections to the defining types */
  695. def elts;
  696. envrec *btns;
  697. {
  698.   def hel;
  699.   symbol n, ens;
  700.   typcrec *ut, *t;
  701.   orig oo;
  702.  
  703.   hel = elts;
  704.   ens = NULL;
  705.   while (hel != NULL) {
  706.     if (hel->tag == TAGDefVal) {
  707.       addcopy(hel->DefVal.defval, &nestednames);
  708.       oo = nestednorig;
  709.       nestednorig = hel->DefVal.valorig;
  710.       addunequal(hel->DefVal.defval, &ens);
  711.       nestednames = nestednames->next;
  712.       nestednorig = oo;
  713.     } else {
  714.       if (hel->tag == TAGDefTyp) {
  715.      addcopy(hel->DefTyp.deftyp, &nestednames);
  716.      oo = nestednorig;
  717.      nestednorig = hel->DefTyp.typorig;
  718.      addunequal(hel->DefTyp.deftyp, &ens);
  719.      update(&btns, hel->DefTyp.deftyp,
  720.             BuildUNKNOWN(newname(), false, false));
  721.      /* fist put all in btns with unknown type */
  722.      nestednames = nestednames->next;
  723.      nestednorig = oo;
  724.       }
  725.     }
  726.     hel = hel->next;
  727.   }
  728.   hel = elts;
  729.   while (hel != NULL) {
  730.     if (hel->tag == TAGDefTyp) {
  731.       addcopy(hel->DefTyp.deftyp, &nestednames);
  732.       oo = nestednorig;
  733.       nestednorig = hel->DefTyp.typorig;
  734.       t = convtype(hel->DefTyp.typas, btns, hel->DefTyp.typorig);
  735.       n = hel->DefTyp.deftyp;
  736.       ut = lookup(btns, &n);
  737.       hel->DefTyp.deftyp = n;   /* for unique names */
  738.       if (occurs(ut->UNKNOWN.unknm, t))
  739.      error(0L, NULL, NULL, n, NULL, false);
  740.       else
  741.      becomes(ut, t);
  742.       /* replace the unknown type by indir. to the found one */
  743.       nestednames = nestednames->next;
  744.       nestednorig = oo;
  745.     }
  746.     hel = hel->next;
  747.   }
  748.   return btns;
  749. }  /* extendbtns */
  750.  
  751. Local nminstrec *wrl(lns, nr)
  752. nminstrec *lns;
  753. long nr;
  754. {
  755.   /* make a copy of the list lns, with nr as inst. nr. */
  756.   nminstrec *hn;
  757.  
  758.   if (lns == NULL)
  759.     return NULL;
  760.   else {
  761.     hn = Buildnminstptr(lns->nm, nr);
  762.     hn->next = wrl(lns->next, nr);
  763.     return hn;
  764.   }
  765. }  /* wrl */
  766.  
  767. Local Void wro(ty, inst, tyo, locnrd)
  768. typcrec *ty;
  769. long inst;
  770. typcrec **tyo;
  771. nminstrec **locnrd;
  772. {
  773.   /* ty can contain nested 'ALL's (because of typenamings)
  774.      tyo is ty with the ALLs removed (after supplying LOCs with
  775.      an instance nr.)
  776.      locnrd are the names from the ALLs in ty (with inst. nr.)
  777.      inst is the instance nr. for LOCs which are not within an
  778.      ALL (those get a different inst. nr.)
  779.   */
  780.   long nn;
  781.   typcrec *t1, *t2;
  782.   nminstrec *ln1, *ln2;
  783.  
  784.   *locnrd = NULL;
  785.   while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
  786.   switch (ty->kind) {
  787.  
  788.   case kindALL:
  789.     nn = newname();   /* inst. nr. for LOCs in ALL's scope */
  790.     wro(ty->ALL.tcall, nn, tyo, locnrd);
  791.     Appendnminstptr(wrl(ty->ALL.locs, nn), *locnrd, locnrd);
  792.     break;
  793.  
  794.   case kindLOC:
  795.     *tyo = BuildLOC(ty->LOC.locname, inst);
  796.     break;
  797.  
  798.   case kindSINGLEARROW:
  799.     wro(ty->SINGLEARROW.tcarg, inst, &t1, &ln1);
  800.     wro(ty->SINGLEARROW.tcres, inst, &t2, &ln2);
  801.     Appendnminstptr(ln2, ln1, locnrd);
  802.     *tyo = BuildSINGLEARROW(t1, t2);
  803.     break;
  804.  
  805.   case kindAPS:
  806.   case kindINT:
  807.   case kindBOOL:
  808.   case kindSTRING:
  809.   case kindFLOAT:
  810.   case kindBASETY:
  811.     *tyo = ty;
  812.     break;
  813.  
  814.   case kindSYSTY:
  815.     wro(ty->SYSTY.syscomp, inst, &t1, locnrd);
  816.     *tyo = BuildSYSTY(ty->SYSTY.sysdirs, t1);
  817.     break;
  818.  
  819.   case kindEMPTYT:
  820.     *tyo = ty;
  821.     break;
  822.  
  823.   case kindCT:
  824.     wro(ty->CT.tcfirst, inst, &t1, &ln1);
  825.     wro(ty->CT.tcrest, inst, &t2, &ln2);
  826.     *tyo = BuildCT(t1, t2);
  827.     Appendnminstptr(ln2, ln1, locnrd);
  828.     break;
  829.  
  830.   case kindUNKNOWN:
  831.     *tyo = BuildUNKNOWN(newname(), ty->UNKNOWN.mustendemp,
  832.                         ty->UNKNOWN.mustconn);
  833.     break;
  834.  
  835.   case kindSOME:
  836.     wro(ty->SOME.tcpart, inst, &t1, locnrd);
  837.     *tyo = BuildSOME(t1, newname());
  838.     break;
  839.  
  840.   }
  841. }  /* wro */
  842.  
  843. Local Void satistyp(t, mustconn, mustendemp)
  844. typcrec *t;
  845. boolean mustconn, mustendemp;
  846. {
  847.   /* checks that after replacing names by named type/ loctyvar/
  848.      basetype the result t is syntactically correct */
  849.   if ((((1L << ((long)t->kind)) & 
  850.      ((1L << ((long)kindAPS)) | (1L << ((long)kindSINGLEARROW)) |
  851.      (1L << ((long)kindSYSTY)) | (1L << ((long)kindINT)) |
  852.      (1L << ((long)kindFLOAT)) | (1L << ((long)kindSTRING)) |
  853.      (1L << ((long)kindBOOL)))) != 0 &&
  854.        (mustconn || mustendemp)) ||
  855.       (((1L << ((long)t->kind)) & ((1L << ((long)kindLOC)) | 
  856.         (1L << ((long)kindBASETY)))) !=0 && mustendemp)) {
  857.     /* << used for test if t->kind in a set */
  858.     error(18L, NULL, NULL, NULL, NULL, false);
  859.     t->kind = kindUNKNOWN;
  860.     t->UNKNOWN.unknm = newname();
  861.     t->UNKNOWN.mustendemp = false;
  862.     t->UNKNOWN.mustconn = false;
  863.   }
  864.   while (t->kind == kindINDIR) t = t->INDIR.tcind;
  865.   switch (t->kind) {
  866.  
  867.   case kindSINGLEARROW:
  868.     satistyp(t->SINGLEARROW.tcarg, false, false);
  869.     satistyp(t->SINGLEARROW.tcres, false, false);
  870.     break;
  871.  
  872.   case kindINT:
  873.   case kindFLOAT:
  874.   case kindSTRING:
  875.   case kindBOOL:
  876.   case kindAPS:
  877.   case kindUNKNOWN:
  878.   case kindEMPTYT:
  879.   case kindBASETY:
  880.   case kindLOC:   /* ready */
  881.     break;
  882.  
  883.   case kindSYSTY:
  884.     satistyp(t->SYSTY.syscomp, true, false);
  885.     break;
  886.  
  887.   /* it is not possible that there are nested directions */
  888.   case kindCT:
  889.     satistyp(t->CT.tcfirst, mustconn, false);
  890.     satistyp(t->CT.tcrest, mustconn, true);
  891.     break;
  892.  
  893.   case kindALL:
  894.     error(10L, NULL, NULL, Buildsymbol("satistyp",8L), NULL, false);
  895.     break;
  896.  
  897.   case kindSOME:
  898.     satistyp(t->SOME.tcpart, mustconn, false);
  899.     break;
  900.  
  901.   }
  902. }  /* satistyp */
  903.  
  904. Local typcrec *writeout(ty)
  905. typcrec *ty;
  906. {
  907.   /* move the 'ALL' constructors in ty outward, of course after
  908.     supplying names with an unique instance number, to get the
  909.     result */
  910.   typcrec *tyo;
  911.   nminstrec *locnrd;
  912.  
  913.   wro(ty, 0L, &tyo, &locnrd);
  914.   /* 0 is dummy, because ty has an 'ALL' on the outside */
  915.   satistyp(tyo, false, false);
  916.   return (BuildALL(locnrd, tyo));
  917. }  /* writeout */
  918.  
  919. Local Void TypSymtoTypAtom(t, locs, btns)
  920. typ t;
  921. symbol locs;
  922. envrec *btns;
  923. {
  924.   /* the occurrences in t of 'TypSym n' with n bound by 
  925.      'BASETYPE n' are replaced by 'TypAtom n'. This for the
  926.      benefit of tha macro-expander (it needs not find out
  927.      bindings in types now)
  928.      locs: local type variables
  929.      btns: BASETYPE's, TYPEnamings in scope */
  930.   symbol nm;
  931.   typcrec *tc;
  932.   typ nxt;
  933.  
  934.   switch (t->tag) {
  935.  
  936.   case TAGTypSym:
  937.     nm = t->TypSym.sym;
  938.     if (!isin(nm, locs)) {
  939.       tc = lookup(btns, &nm);
  940.       if (tc != NULL) {
  941.      nxt = t->next;
  942.      if (tc->kind != kindINDIR) {
  943.        /* tc is an indir., because of the way extendbtns works */
  944.        error(10L, NULL, NULL, Buildsymbol( "TypSymtoTypAtom1",16L),NULL,false);
  945.      } else {
  946.        if (tc->INDIR.tcind->kind != kindALL)   /* added by convtype */
  947.          error(10L, NULL, NULL, Buildsymbol("TypSymtoTypAtom2",16L),NULL,false);
  948.        else {
  949.          if (tc->INDIR.tcind->ALL.tcall->kind == kindBASETY) {
  950.            t->tag = TAGTypAtom;
  951.            t->TypAtom.atomnm = nm;
  952.            t->next = nxt;
  953.          }
  954.        }
  955.      }
  956.       }
  957.     }
  958.     break;
  959.  
  960.   case TAGTypLocal:
  961.     TypSymtoTypAtom(t->TypLocal.loctyp, t->TypLocal.locsyms,
  962.                     btns);
  963.     break;
  964.  
  965.   case TAGTypFun:
  966.     TypSymtoTypAtom(t->TypFun.funpar, locs, btns);
  967.     TypSymtoTypAtom(t->TypFun.funres, locs, btns);
  968.     break;
  969.  
  970.   case TAGTypIn:
  971.     TypSymtoTypAtom(t->TypIn.ityp, locs, btns);
  972.     break;
  973.  
  974.   case TAGTypOut:
  975.     TypSymtoTypAtom(t->TypOut.otyp, locs, btns);
  976.     break;
  977.  
  978.   case TAGTypUni:
  979.     TypSymtoTypAtom(t->TypUni.uityp, locs, btns);
  980.     TypSymtoTypAtom(t->TypUni.uotyp, locs, btns);
  981.     break;
  982.  
  983.   case TAGTypNon:
  984.     TypSymtoTypAtom(t->TypNon.nontyp, locs, btns);
  985.     break;
  986.  
  987.   case TAGTypPwr:
  988.     TypSymtoTypAtom(t->TypPwr.pwrtyp, locs, btns);
  989.     break;
  990.  
  991.   case TAGTypProd:
  992.     t = t->TypProd.ptypes;
  993.     while (t != NULL) {
  994.       TypSymtoTypAtom(t, locs, btns);
  995.       t = t->next;
  996.     }
  997.     break;
  998.  
  999.   case TAGTypStar:
  1000.     TypSymtoTypAtom(t->TypStar.startyp, locs, btns);
  1001.     break;
  1002.  
  1003.   case TAGTypAtom:
  1004.   case TAGTypInt:
  1005.   case TAGTypBind:
  1006.   case TAGTypFlo:
  1007.   case TAGTypString:
  1008.   case TAGTypBool:
  1009.   case TAGTypAppset:   /* ready */
  1010.     break;
  1011.   }
  1012. }  /* TypSymtoTypAtom */
  1013.  
  1014. Local Void extendenvloc(elts, btns)
  1015. def elts;
  1016. envrec *btns;
  1017. { /* put types of ATOMs, DEFs and MACROs in curenv, given btns
  1018.      for names in the declared types */
  1019.   /* ! btns': envptr; btnslist: envlistptr */
  1020.   def hel;
  1021.   orig oo;
  1022.  
  1023.   hel = elts;
  1024.   /* ! btnslist:=nil */
  1025.   while (hel != NULL) {
  1026.     if (hel->tag == TAGDefVal) 
  1027.     { addcopy(hel->DefVal.defval, &nestednames);
  1028.       oo = nestednorig;
  1029.       nestednorig = hel->DefVal.valorig;   /* !' */
  1030.       /* ! if hel^.valas^.vtval^.tag=TAGVAtom then btns':=btns
  1031.            else begin btns' := extendbtns(..wat bij
  1032.            macro?..,btns); appendbtns(btns',btnslist) end
  1033.       */
  1034.       /* assumption: hel^.valas^.tag=TAGVType */
  1035.       update(&curenv, hel->DefVal.defval,
  1036.              writeout(convtype(hel->DefVal.valas->VType.vttyp,
  1037.                                btns, NULL)));
  1038.       if (adaptds)
  1039.      TypSymtoTypAtom(hel->DefVal.valas->VType.vttyp, NULL, btns);
  1040.       nestednorig = oo;
  1041.       nestednames = nestednames->next;
  1042.       if (hel->DefVal.valas->VType.vtval->tag == TAGVAtom)
  1043.      hel->DefVal.valas->VType.vtval->VAtom.atomnm 
  1044.                   = hel->DefVal.defval;
  1045.       /* make it point to the same, for making unique */
  1046.     } else 
  1047.     { if (hel->tag == TAGDefTyp && adaptds)
  1048.      TypSymtoTypAtom(hel->DefTyp.typas, NULL, btns);
  1049.     }
  1050.     hel = hel->next;
  1051.   }
  1052. }  /* extendenvloc */
  1053.  
  1054. typedef struct unkrec {
  1055.   struct unkrec *next;
  1056.   typcrec *unk;
  1057. } unkrec;
  1058.  
  1059. /* Local variables for replacelocssome: */
  1060. struct LOC_replacelocssome {
  1061.   boolean justcopy;
  1062.   nminstrec *alllocnames;
  1063.   unkrec *freshlocnames;
  1064. } ;
  1065.  
  1066. Local typcrec *freshcopy(t, LINK)
  1067. typcrec *t;
  1068. struct LOC_replacelocssome *LINK;
  1069. { /* replace each LOCname by a fresh name */
  1070.   nminstrec *hs;
  1071.   unkrec *hn;
  1072.  
  1073.   while (t->kind == kindINDIR) t = t->INDIR.tcind;
  1074.   switch (t->kind) {
  1075.  
  1076.   case kindLOC:
  1077.     if (!LINK->justcopy) {
  1078.       hs = LINK->alllocnames;
  1079.       hn = LINK->freshlocnames;
  1080.       while (!(Equalsymbol(hs->nm, t->LOC.locname) &&
  1081.             hs->inst == t->LOC.inst)) {
  1082.      hs = hs->next;
  1083.      hn = hn->next;
  1084.      if (hs==NULL)
  1085.      { error(10L, NULL, NULL, Buildsymbol( "freshcopy", 9L), NULL, false);
  1086.        return t;
  1087.        break; }
  1088.       }
  1089.       if (hn!=NULL) return hn->unk; 
  1090.     } else
  1091.       return t;
  1092.     break;
  1093.  
  1094.   case kindSINGLEARROW:
  1095.     return BuildSINGLEARROW(freshcopy(t->SINGLEARROW.tcarg, LINK),
  1096.                      freshcopy(t->SINGLEARROW.tcres, LINK));
  1097.     break;
  1098.  
  1099.   case kindSYSTY:
  1100.     return BuildSYSTY(t->SYSTY.sysdirs, 
  1101.                         freshcopy(t->SYSTY.syscomp, LINK));
  1102.     break;
  1103.  
  1104.   case kindCT:
  1105.     return BuildCT(freshcopy(t->CT.tcfirst, LINK),
  1106.                freshcopy(t->CT.tcrest, LINK));
  1107.     break;
  1108.  
  1109.   case kindUNKNOWN:
  1110.     if (LINK->justcopy)
  1111.       return BuildUNKNOWN(t->UNKNOWN.unknm, t->UNKNOWN.mustendemp,
  1112.                    t->UNKNOWN.mustconn);
  1113.     else
  1114.       return BuildUNKNOWN(newname(), t->UNKNOWN.mustendemp,
  1115.                    t->UNKNOWN.mustconn);
  1116.     break;
  1117.  
  1118.   case kindINT:
  1119.   case kindFLOAT:
  1120.   case kindBOOL:
  1121.   case kindSTRING:
  1122.   case kindEMPTYT:
  1123.   case kindBASETY:
  1124.   case kindAPS:
  1125.     return t;
  1126.     break;
  1127.  
  1128.   case kindSOME:
  1129.     if (LINK->justcopy)
  1130.       return BuildSOME(freshcopy(t->SOME.tcpart, LINK),
  1131.                                    t->SOME.somnr);
  1132.     else
  1133.       return BuildSOME(freshcopy(t->SOME.tcpart, LINK), 
  1134.                          newname());
  1135.     break;
  1136.  
  1137.   case kindALL:   /* should not occur here */
  1138.     error(10L, NULL, NULL, Buildsymbol( "freshcopy", 9L), NULL, false);
  1139.     return t;
  1140.     break;
  1141.   }
  1142. }  /* freshcopy */
  1143.  
  1144. /* Local typcrec *replacelocssome PP((typcrec *t, boolean justcopy_)) */
  1145. Local typcrec *replacelocssome(t, justcopy_) 
  1146. typcrec *t;
  1147. boolean justcopy_;
  1148. {
  1149.   /* if justcopy_, make a fresh copy of t; otherwise
  1150.      if t is a ALL type then replace all LOC names , UNKNOWN and 
  1151.      SOME numbers by fresh ones, since at each use a new value
  1152.      may be used for them */
  1153.   struct LOC_replacelocssome V;
  1154.   unkrec *hup;
  1155.  
  1156.   V.justcopy = justcopy_;
  1157.   while (t->kind == kindINDIR) t = t->INDIR.tcind;
  1158.   if (t->kind == kindALL)   /* generate new names */
  1159.   { V.alllocnames = t->ALL.locs;
  1160.     V.freshlocnames = NULL;
  1161.     while (V.alllocnames != NULL) 
  1162.     { hup = (unkrec *)malloc(sizeof(unkrec));
  1163.       hup->unk = BuildUNKNOWN(newname(), false, true);
  1164.       hup->next = V.freshlocnames;
  1165.       V.freshlocnames = hup;
  1166.       V.alllocnames = V.alllocnames->next;
  1167.     }
  1168.     V.alllocnames = t->ALL.locs;
  1169.     return (freshcopy(t->ALL.tcall, &V));
  1170.   } else {
  1171.     if (V.justcopy)
  1172.       return (freshcopy(t, &V));
  1173.     else
  1174.       return t;
  1175.   }
  1176. }  /* replacelocssome */
  1177.  
  1178. #define forcefptoval(f) new_VMacLambda(f,NULL)
  1179. /* forcefptoval(f) new_VMacLambda(f,NULL):
  1180.      forces an fp to look like a val by putting a TAGVMacLambda
  1181.      with empty mval field around it */
  1182.  
  1183. Local typcrec *typefp(iscon, fmp)
  1184. boolean iscon;
  1185. fp fmp;
  1186. { /* gives type of fp; adds types for names to curenv; type for
  1187.      name not overwritten if iscon (is formal connection) */
  1188.   typcrec *t1, *t2;
  1189.   symbol hn;
  1190.   boolean rb;
  1191.  
  1192.   switch (fmp->tag) {
  1193.  
  1194.   case TAGFpComp:
  1195.     t1 = typefp(iscon, fmp->FpComp.fprest);
  1196.     rb = restrictable(true, false, t1, forcefptoval(fmp->FpComp.fprest));
  1197.     /* must end in empty */
  1198.     return BuildCT(typefp(iscon, fmp->FpComp.fpfirst), t1);
  1199.     break;
  1200.  
  1201.   case TAGFpEmpty:
  1202.     return BuildSOME(BuildUNKNOWN(newname(), false, iscon),
  1203.                        newname());
  1204.     break;
  1205.  
  1206.   /* !! mog. foute inv. als iscon false */
  1207.   case TAGFpList:
  1208.     if (fmp->FpList.fplist == NULL) {
  1209.       return BuildSOME(BuildUNKNOWN(newname(), false, iscon),
  1210.                          newname());
  1211.       /* !! mog. foute inv. als iscon false */
  1212.     } else {      
  1213.       t1 = typefp(iscon, fmp->FpList.fplist);
  1214.       t2 = typefp(iscon, new_FpList(fmp->FpList.fplist->next));
  1215.       /* t1, t2 used so that name extension numbers are independent of the
  1216.      order in which the C implementation evaluates function arguments */
  1217.       return BuildCT(t1, t2);
  1218.     }
  1219.     break;
  1220.  
  1221.   case TAGFpName:
  1222.     if (iscon) {
  1223.       hn = fmp->FpName.fpsym;
  1224.       t1 = lookup(curenv, &hn);
  1225.       if (t1 == NULL) {
  1226.      t1 = BuildUNKNOWN(newname(), false, true);
  1227.      update(&curenv, hn, t1);
  1228.      return t1;
  1229.       } else {
  1230.      fmp->FpName.fpsym = hn;
  1231.      return t1;
  1232.       }
  1233.     } else {
  1234.       t1 = BuildUNKNOWN(newname(), false, false);
  1235.       update(&curenv, fmp->FpName.fpsym, t1);
  1236.       return t1;
  1237.     }
  1238.     break;
  1239.  
  1240.   case TAGFpStr:
  1241.     return BuildSTRING();
  1242.     break;
  1243.  
  1244.   case TAGFpInt:
  1245.     return BuildINT();
  1246.     break;
  1247.  
  1248.   case TAGFpFlo:
  1249.     return BuildFLOAT();
  1250.     break;
  1251.  
  1252.   case TAGFpBool:
  1253.     return BuildBOOL();
  1254.     break;
  1255.   }
  1256. }  /* typefp */
  1257.  
  1258. Local symbol unusedname()
  1259. { /* delivers string-name not appearing in the Glass volume */
  1260.   symbol hs;
  1261.  
  1262.   hs = Buildsymbol(specstr, 3L);
  1263.   addext(hs, newname());
  1264.   return hs;
  1265. }  /* unusedname */
  1266.  
  1267. Local Void addetapar(vl, nm)
  1268. val *vl;
  1269. symbol nm;
  1270. {/* change vl to application of vl to nm (distr. over where,
  1271.     cond.) */
  1272.   val fnc;
  1273.   if ((*vl)->tag == TAGVWhere) {
  1274.     addetapar(&(*vl)->VWhere.wval, nm);
  1275.     return;
  1276.   }
  1277.   if ((*vl)->tag == TAGVBuiltin) {
  1278.     if (cmp_string((*vl)->VBuiltin.oper, "->")==0) {
  1279.       addetapar(&(*vl)->VBuiltin.args->next, nm); /* then br. */
  1280.       /* else br. */
  1281.       addetapar(&(*vl)->VBuiltin.args->next->next, nm);
  1282.     }
  1283.     return;
  1284.   }
  1285.   fnc = (val)malloc(sizeof(*fnc));
  1286.   *fnc = **vl;
  1287.   fnc->next = NULL;
  1288.   (*vl)->tag = TAGVValApply;
  1289.   (*vl)->VValApply.avval = fnc;
  1290.   (*vl)->VValApply.avpar = new_VSym(new_orig("no_file", 0L), nm);
  1291. }  /* addetapar */
  1292.  
  1293. Local Void fcnamesuniq(notformcon, par, parnames, ncjustname)
  1294. boolean notformcon;
  1295. fp par;
  1296. symbol *parnames;
  1297. boolean ncjustname;
  1298. {
  1299.   /* check if par does not already appear in parnames (error);
  1300.      if notformcon add it to parnames
  1301.      if notformcon and ncjustname only TAGFpName allowed 
  1302.      (othw. error) */
  1303.   if (notformcon && ncjustname && par->tag != TAGFpName)
  1304.     error(19L, NULL, NULL, NULL, NULL, false);
  1305.   switch (par->tag) {
  1306.  
  1307.   case TAGFpComp:
  1308.     fcnamesuniq(notformcon,par->FpComp.fpfirst, parnames, false);
  1309.     fcnamesuniq(notformcon, par->FpComp.fprest, parnames, false);
  1310.     break;
  1311.  
  1312.   case TAGFpList:
  1313.     par = par->FpList.fplist;
  1314.     while (par != NULL) {
  1315.       fcnamesuniq(notformcon, par, parnames, false);
  1316.       par = par->next;
  1317.     }
  1318.     break;
  1319.  
  1320.   case TAGFpName:
  1321.     if (notformcon)
  1322.       addunequal(par->FpName.fpsym, parnames);
  1323.     else {
  1324.       if (isin(par->FpName.fpsym, *parnames))
  1325.      error(9L, NULL, NULL, par->FpName.fpsym, NULL, false);
  1326.     }
  1327.     break;
  1328.  
  1329.   case TAGFpEmpty:
  1330.   case TAGFpInt:
  1331.   case TAGFpBool:
  1332.   case TAGFpStr:   /* ok */
  1333.     break;
  1334.   }
  1335. }  /* fcnamesuniq */
  1336.  
  1337. Local Void supplyapsbrc(vl)
  1338. val vl;
  1339. {
  1340.   /* surround vl (with appset type) by appset brackets, if there
  1341.      are none. Distributed over conditional and where */
  1342.   val hv;
  1343.  
  1344.   switch (vl->tag) {
  1345.  
  1346.   case TAGVSysApply:
  1347.   case TAGVValApply:
  1348.     error(28,NULL,NULL,NULL,vl,true);
  1349.     hv = (val)malloc(sizeof(*hv));
  1350.     *hv = *vl;
  1351.     hv->next = NULL;
  1352.     vl->tag = TAGVAppset;
  1353.     vl->VAppset.aps = hv;
  1354.     break;
  1355.  
  1356.   case TAGVWhere:
  1357.     supplyapsbrc(vl->VWhere.wval);
  1358.     break;
  1359.  
  1360.   case TAGVBuiltin:
  1361.     if (cmp_string(vl->VBuiltin.oper, "->")==0) {
  1362.       supplyapsbrc(vl->VBuiltin.args->next);
  1363.       supplyapsbrc(vl->VBuiltin.args->next->next);
  1364.     }
  1365.     break;
  1366.  
  1367.   case TAGVSym:
  1368.   case TAGVInt:
  1369.   case TAGVFlo:
  1370.   case TAGVStr:
  1371.   case TAGVBool:
  1372.   case TAGVType:
  1373.   case TAGVSysLambda: case TAGVSysSigma:
  1374.   case TAGVList:
  1375.   case TAGVAppset:
  1376.   case TAGVAtom:
  1377.   case TAGVSyn:   /* ready */
  1378.     break;
  1379.   }
  1380. }  /* supplyapsbrc */
  1381.  
  1382. boolean seemsadir(vl)
  1383. val vl;
  1384. { /* heuristic to guess if the description was meant to be adirectional */
  1385. string op;
  1386.  
  1387. switch (vl->tag) {
  1388. case TAGVSysSigma:
  1389. case TAGVSyn:
  1390. case TAGVAppset:
  1391.   return true;
  1392. case TAGVWhere:
  1393.   return seemsadir(vl->VWhere.wval);
  1394. case TAGVBuiltin:
  1395.   {op = vl->VBuiltin.oper;
  1396.    if(cmp_string(op,"->")==0) 
  1397.    { return ((seemsadir(vl->VBuiltin.args->next)) ||
  1398.              (seemsadir(vl->VBuiltin.args->next->next)));
  1399.    } else {return false;}
  1400.   };
  1401. default:
  1402.   return false;
  1403. }
  1404. } /* seemsadir */
  1405.  
  1406. Local Void checkbody(dm, ty, btns, isdef, parnames)
  1407. val dm;
  1408. typcrec *ty;
  1409. envrec *btns;
  1410. boolean isdef;
  1411. symbol parnames;
  1412. { /* check if this alternative body dm has the type ty.
  1413.      btns: BT/TN holding here
  1414.      isdef: only single names allowed as (non-conn.) parameter
  1415.      parnames: names for (non-formal connection)parameters
  1416.                already encountered */
  1417.   symbol nm;
  1418.   val rest;
  1419.   fp etapar, fmp;
  1420.   typcrec *t1, *t2;
  1421.   errorrec *err, *errad;
  1422.   boolean adok, ado;
  1423.  
  1424.   while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
  1425.   if (ty->kind == kindSINGLEARROW || ty->kind == kindSYSTY) 
  1426.   { if (dm->tag != TAGVMacLambda)  /* add eta-parameter */
  1427.     { nm = unusedname();
  1428.       etapar = new_FpName(nm);
  1429.       rest = (val)malloc(sizeof(*rest));
  1430.       *rest = *dm;
  1431.       rest->next = NULL;
  1432.       addetapar(&rest, nm);
  1433.       dm->tag = TAGVMacLambda;
  1434.       dm->VMacLambda.mpar = etapar;
  1435.       dm->VMacLambda.mval = rest;
  1436.     }
  1437.   }
  1438.   if (ty->kind == kindSINGLEARROW)    /* dm->tag=TAGVMacLambda */
  1439.   { fcnamesuniq(true, dm->VMacLambda.mpar, &parnames, isdef);
  1440.     compat(typefp(false, dm->VMacLambda.mpar),
  1441.            ty->SINGLEARROW.tcarg, forcefptoval(dm->VMacLambda.mpar));
  1442.     checkbody(dm->VMacLambda.mval, ty->SINGLEARROW.tcres, btns, isdef,
  1443.               parnames);
  1444.     return;
  1445.   }
  1446.   mark_(&curenv);
  1447.   if (ty->kind == kindSYSTY)   /* dm^.tag=TAGVMacLambda */
  1448.   { fcnamesuniq(false, dm->VMacLambda.mpar, &parnames, false);
  1449.     ado = adaptds;
  1450.     adaptds = false;
  1451.      /* to prevent making names unique twice */
  1452.     err = errorlist;/* try if can be interpreted adirectionally*/
  1453.     t1 = BuildUNKNOWN(newname(),false,true);    
  1454.     compat(BuildSYSTY(BuildOd(BuildNON()), t1),
  1455.            replacelocssome(ty, true), dm);
  1456.     /* order: for directionsin the system type */
  1457.     compat(typefp(true, dm->VMacLambda.mpar),t1 ,
  1458.        forcefptoval(dm->VMacLambda.mpar));
  1459.     compat(BuildAPS(),
  1460.            typeval(makeadirwanted,dm->VMacLambda.mval,btns,0L),
  1461.            dm->VMacLambda.mval);
  1462.     adok = (errorlist == err);
  1463.     release_(&curenv, false); /* types for conn. names removed */
  1464.     adaptds = ado;
  1465.     mark_(&curenv);
  1466.     errad = errorlist;
  1467.     errorlist = err;/* try if can be interpreted unidirectionally */
  1468.     t1 = BuildUNKNOWN(newname(),false,true);    
  1469.     t2 = BuildUNKNOWN(newname(),false,true);    
  1470.     compat(BuildSYSTY(BuildCd(BuildOd(BuildIN()),
  1471.                BuildCd(BuildOd(BuildOUT()), BuildOd(BuildNON()))),
  1472.            BuildCT(t1,
  1473.              BuildCT(t2,BuildSOME(BuildUNKNOWN(newname(),false,true),newname())))), 
  1474.              ty, dm);
  1475.     compat(typefp(true, dm->VMacLambda.mpar),t1 ,
  1476.        forcefptoval(dm->VMacLambda.mpar));
  1477.     compat(t2,typeval(makedirwanted,dm->VMacLambda.mval,btns,0L),
  1478.        dm->VMacLambda.mval);
  1479.     if (adok) 
  1480.     { if (errorlist == err)    /* both adir and dir ok: warning */
  1481.       { error(2L, NULL, NULL, NULL, NULL, true);
  1482.         if (!takewarning && adaptds)
  1483.         { /* TAGVMacLambda fp rest -> TAGVSysLambda fp rest: */
  1484.           fmp = dm->VMacLambda.mpar;
  1485.           rest = dm->VMacLambda.mval;
  1486.           dm->tag = TAGVSysLambda;
  1487.           dm->VSysLambda.slpar = fmp;
  1488.           dm->VSysLambda.slval = rest;
  1489.         }
  1490.       } else  /* adir. ok, unidir not */
  1491.       { errorlist = err;
  1492.         supplyapsbrc(dm->VMacLambda.mval);
  1493.         if (adaptds) 
  1494.         { /* TAGVMacLambda fp rest -> TAGVSysSigma fp rest: */
  1495.           fmp = dm->VMacLambda.mpar;
  1496.           rest = dm->VMacLambda.mval;
  1497.           dm->tag = TAGVSysSigma;
  1498.           dm->VSysSigma.sspar = fmp;
  1499.           dm->VSysSigma.ssval = rest;
  1500.         }
  1501.       }
  1502.     } else 
  1503.       if (errorlist == err) /* unidir ok, adir not */
  1504.       {if (adaptds) 
  1505.         { /* VMacLambda f r -> VSysLambda f r */
  1506.         fmp = dm->VMacLambda.mpar;
  1507.           rest = dm->VMacLambda.mval;
  1508.           dm->tag = TAGVSysLambda;
  1509.           dm->VSysLambda.slpar = fmp;
  1510.           dm->VSysLambda.slval = rest;
  1511.         } 
  1512.       } else /* unidir and adir both wrong */
  1513.        { if (seemsadir(dm->VMacLambda.mval)) {errorlist = errad;};
  1514.          error(3L, NULL, NULL, NULL, NULL, true);
  1515.        }
  1516.   } 
  1517.   else
  1518.     compat(ty, typeval(makewanted(ty), dm, btns, 0L), dm);
  1519.     release_(&curenv, adaptds && uniq); /* remove conn. names */
  1520. }  /* checkbody */
  1521.  
  1522. Local Void checkdm(dm, ty, btns)
  1523. val dm;
  1524. typcrec *ty;
  1525. envrec *btns;
  1526. { /* check if def/macro dm has required type ty (and some simple checks)
  1527.      dm: TAGVMacAlts?is macro; is def
  1528.      ty: type of dm, with all local type names in front (ALL)
  1529.      btns BT/TNs holding on this level ( ! and local defs) */
  1530.   typcrec *typc;
  1531.   boolean isdef;
  1532.  
  1533.   if (dm->tag == TAGVMacAlts) {
  1534.     dm = dm->VMacAlts.alts;
  1535.     isdef = false;
  1536.   } else isdef = true;
  1537.     typc = ty; 
  1538.     while (typc->kind==kindINDIR) typc=typc->INDIR.tcind;
  1539.     if (typc->kind!=kindALL) 
  1540.     {error(10L,NULL,NULL,Buildsymbol("checkdm",7L),NULL,false);
  1541.      return;}
  1542.     while (dm != NULL) {
  1543.     mark_(&curenv);   /* before the parameters */
  1544.     checkbody(dm, replacelocssome(typc->ALL.tcall, true), btns, isdef, NULL);
  1545.     /* replace...: ALL removed, SOME/UNKNOWN numbers renewed,
  1546.        so that empty type stays that */
  1547.     release_(&curenv, adaptds && uniq);
  1548.     dm = dm->next;
  1549.   }
  1550. }  /* checkdm */
  1551.  
  1552. Local Void checkdms(elts, btns)
  1553. def elts;
  1554. envrec *btns;
  1555. { /* check each DEF/MACRO in the elts-list for cont.sens. corr.,
  1556.      given btns for names in the declared types */
  1557.   def hel;
  1558.   /* ! btns': envptr */
  1559.   symbol n;
  1560.   orig oo;
  1561.  
  1562.   hel = elts;
  1563.   /* ! btns':=btnslist */
  1564.   while (hel != NULL) {
  1565.     if (hel->tag == TAGDefVal) {
  1566.       if (hel->DefVal.valas->VType.vtval->tag != TAGVAtom)
  1567.       {   /* ass.: hel^.valas^.tag=TAGVType */
  1568.      n = hel->DefVal.defval;
  1569.      addcopy(n, &nestednames);
  1570.      oo = nestednorig;
  1571.      nestednorig = hel->DefVal.valorig;   /*! slist^.el */
  1572.      checkdm(hel->DefVal.valas->VType.vtval, lookup(curenv, &n), btns);
  1573.      hel->DefVal.defval = n;
  1574.      nestednames = nestednames->next;
  1575.      nestednorig = oo;
  1576.      /* ! ; btnslist:=btnslist^.next */
  1577.       }
  1578.     }
  1579.     hel = hel->next;
  1580.   }
  1581. }  /* checkdms */
  1582.  
  1583. /* Local variables for typeval: */
  1584. struct LOC_typeval {
  1585.   envrec *btns;
  1586.   long splitlevel;
  1587. } ;
  1588.  
  1589. /* Local variables for typeBuiltin: */
  1590. struct LOC_typeBuiltin {
  1591.   typcrec *Result;
  1592.   val args;
  1593.   typcrec *targ1, *targ2;
  1594. } ;
  1595.  
  1596. Local boolean try(ta1, ta2, restype, LINK)
  1597. typcrec *ta1, *ta2, *restype;
  1598. struct LOC_typeBuiltin *LINK;
  1599. {
  1600.   /* gives true if targ1 is compatible with ta1; if so checks if
  1601.      ta2 (if not nil) is compatible with targ2, and assigns
  1602.      restype to typeBuiltin */
  1603.   boolean Result;
  1604.   errorrec *er;
  1605.  
  1606.   er = errorlist;
  1607.   errorlist = NULL;
  1608.   compat(ta1, LINK->targ1, LINK->args);
  1609.   Result = (errorlist == NULL);
  1610.   if (errorlist != NULL) {
  1611.     errorlist = er;
  1612.     return Result;
  1613.   }
  1614.   errorlist = er;
  1615.   if (ta2 != NULL)
  1616.     compat(ta2, LINK->targ2, LINK->args->next);
  1617.   LINK->Result = restype;
  1618.   return Result;
  1619. }  /* try */
  1620.  
  1621. Local typcrec *typeBuiltin(appnon, vl, LINK)
  1622. adirindic appnon;
  1623. val vl;
  1624. struct LOC_typeval *LINK;
  1625. {
  1626.   /* deliver type of builtin operator op, with its arguments 
  1627.      (1, 2 or 3) in args; appnon: application in snd or third arg.
  1628.      to be interpreted adirectionally  */
  1629.   string op;
  1630.   struct LOC_typeBuiltin V;
  1631.   typcrec *targ3;
  1632.   boolean rb;
  1633.   long l;
  1634.   adirindic apn1, apn2, apn3;
  1635.  
  1636.   V.args = vl->VBuiltin.args;
  1637.   op=vl->VBuiltin.oper;
  1638.   if (cmp_string(op,"->")==0) {apn1 = makedirwanted; apn2 = apn3 = appnon;}
  1639.   else
  1640.   if (cmp_string(op,"[..]")==0) {apn1 = appnon; apn2 = apn3 = makedirwanted;}
  1641.   else
  1642.   if (cmp_string(op,":")==0) splitwanted(appnon,&apn1,&apn2);
  1643.   else apn1 = apn2 = makedirwanted;
  1644.   V.targ1 = typeval(apn1, V.args, LINK->btns, LINK->splitlevel);
  1645.   if (V.args->next != NULL) {
  1646.     V.targ2 = typeval(apn2, V.args->next, LINK->btns, LINK->splitlevel);
  1647.     if (V.args->next->next != NULL)
  1648.       targ3 = typeval(apn3, V.args->next->next, LINK->btns, LINK->splitlevel);
  1649.   }
  1650.   else {V.targ2 = NULL;}
  1651.   if ((cmp_string(op, "=")==0) | (cmp_string(op, "/=")==0)) {
  1652.     if (try(BuildINT(), BuildINT(), BuildBOOL(), &V))
  1653.       return V.Result;
  1654.     if (try(BuildFLOAT(), BuildFLOAT(), BuildBOOL(), &V))
  1655.       return V.Result;
  1656.     if (try(BuildBOOL(), BuildBOOL(), BuildBOOL(), &V))
  1657.       return V.Result;
  1658.     if (!try(BuildSTRING(), BuildSTRING(), BuildBOOL(), &V)) {
  1659.       error(6L, V.targ1, V.targ2, NULL, vl, false);
  1660.       return (BuildBOOL());
  1661.     }
  1662.     return V.Result;
  1663.   }
  1664.   if ((cmp_string(op,"+2")==0) | (cmp_string(op,"*")==0) |
  1665.       (cmp_string(op,"-2")==0) | (cmp_string(op,"^")==0) |
  1666.       (cmp_string(op,"MOD")==0)) {
  1667.     if (try(BuildINT(), BuildINT(), BuildINT(), &V))
  1668.       return V.Result;
  1669.     if (!try(BuildFLOAT(), BuildFLOAT(), BuildFLOAT(), &V)) {
  1670.       error(6L, V.targ1, V.targ2, NULL, vl, false);
  1671.       return (BuildUNKNOWN(newname(), false, false));
  1672.     }
  1673.     return V.Result;
  1674.   }
  1675.   if (cmp_string(op, "/")==0) {
  1676.     if (try(BuildINT(), BuildINT(), BuildFLOAT(), &V))
  1677.       return V.Result;
  1678.     if (!try(BuildFLOAT(), BuildFLOAT(), BuildFLOAT(), &V)) {
  1679.       error(6L, V.targ1,V.targ2, NULL, vl, false);
  1680.       return (BuildFLOAT());
  1681.     }
  1682.     return V.Result;
  1683.   }
  1684.   if (cmp_string(op,"DIV")==0) {
  1685.     if (try(BuildINT(), BuildINT(), BuildINT(), &V))
  1686.       return V.Result;
  1687.     if (!try(BuildFLOAT(), BuildFLOAT(), BuildINT(), &V)) {
  1688.       error(6L, V.targ1,V.targ2, NULL, vl, false);
  1689.       return (BuildINT());
  1690.     }
  1691.     return V.Result;
  1692.   }
  1693.   if ((cmp_string(op, "<")==0) | (cmp_string(op,"<=")==0) |
  1694.       (cmp_string(op,">")==0) | (cmp_string(op,">=")==0)) {
  1695.     if (try(BuildINT(), BuildINT(), BuildBOOL(), &V))
  1696.       return V.Result;
  1697.     if (!try(BuildFLOAT(), BuildFLOAT(), BuildBOOL(), &V)) {
  1698.       error(6L, V.targ1, V.targ2, NULL, vl, false);
  1699.       return (BuildBOOL());
  1700.     }
  1701.     return V.Result;
  1702.   }
  1703.   if ((cmp_string(op,"&")==0) | (cmp_string(op,"|")==0)) {
  1704.     if (!try(BuildBOOL(), BuildBOOL(), BuildBOOL(), &V)) {
  1705.       error(6L, V.targ1, V.targ2, NULL, vl,false);
  1706.       return (BuildBOOL());
  1707.     }
  1708.     return V.Result;
  1709.   }
  1710.   if (cmp_string(op,":")==0) {
  1711.     rb = restrictable(true, false, V.targ2, V.args->next);
  1712.     /* true: must end in empty! */
  1713.     return (BuildCT(V.targ1, V.targ2));
  1714.   }
  1715.   if ((cmp_string(op, "-1")==0) | (cmp_string(op,"+1")==0)) {
  1716.     if (try(BuildINT(), NULL, BuildINT(), &V))
  1717.       return V.Result;
  1718.     if (!try(BuildFLOAT(), NULL, BuildFLOAT(), &V)) {
  1719.       error(6L, V.targ1, V.targ2, NULL, vl, false);
  1720.       return (BuildUNKNOWN(newname(), false, false));
  1721.     }
  1722.     return V.Result;
  1723.   }
  1724.   if (cmp_string(op,"~")==0) {
  1725.     if (!try(BuildBOOL(), NULL, BuildBOOL(), &V)) {
  1726.       error(6L, V.targ1, V.targ2, NULL, vl, false);
  1727.       return (BuildBOOL());
  1728.     }
  1729.     return V.Result;
  1730.   }
  1731.   if (cmp_string(op,"->")==0) {
  1732.     compat(BuildBOOL(), V.targ1, V.args);
  1733.     return (upper(V.targ2, targ3, V.args->next->next));
  1734.     /* for the last arg., args^.next could have been taken */
  1735.   }
  1736.   if (cmp_string(op,"[..]")==0) {
  1737.     V.Result = BuildSOME(uppercomps(V.targ1, V.args), newname());
  1738.     /* !! this may introduce wrong fill-ins, if uppercomps
  1739.           contains UNKNOWN */
  1740.     compat(BuildINT(), V.targ2, V.args->next);
  1741.     compat(BuildINT(), targ3, V.args->next->next);
  1742.     return V.Result;
  1743.   }
  1744.   if (!cmp_string(op,"itof")==0) 
  1745.   { l=0; while (op[l]!='\0') l++;
  1746.     error(10L, NULL, NULL, Buildsymbol(op,l), NULL, false);
  1747.     return (BuildUNKNOWN(newname(), false, false));
  1748.   }
  1749.   if (!try(BuildINT(), NULL, BuildFLOAT(), &V)) {
  1750.       error(6L, V.targ1, V.targ2, NULL, vl, false);
  1751.     return (BuildFLOAT());
  1752.   }
  1753.   return V.Result;
  1754. }  /* typeBuiltin */
  1755.  
  1756. Local typcrec *typename(n)
  1757. symbol *n;
  1758. {
  1759.   /* find type of n in curenv; 
  1760.      if not there, give it any conn. type */
  1761.   typcrec *t;
  1762.  
  1763.   t = lookup(curenv, n);
  1764.   if (t == NULL) {
  1765.     t = BuildUNKNOWN(newname(), false, true);
  1766.     update(&curenv, *n, t);
  1767.     return t;
  1768.   } else
  1769.     return (replacelocssome(t, false));
  1770. }  /* typename */
  1771.  
  1772. Local typcrec *typeld(ld, btns, splitlevel)
  1773. def ld;
  1774. envrec *btns;
  1775. long splitlevel;
  1776. {
  1777.   /* if ld (appearing in where) is of the form "ns=e" or appset
  1778.      then check its type; result type is APS
  1779.      btns, splitlevel: same function as in typeval */
  1780.   typcrec *t1;
  1781.  
  1782.   if (ld->tag == TAGDefCon) /* appsets in where not (yet) in d.s. */
  1783.   { t1 = BuildUNKNOWN(newname(), false, true);
  1784.     compat(t1, typeval(makedirwanted, ld->DefCon.defcon, btns, splitlevel),
  1785.            ld->DefCon.defcon);
  1786.     compat(t1, typeval(makedirwanted, ld->DefCon.conas, btns, splitlevel),
  1787.            ld->DefCon.conas);
  1788.   }
  1789.   return (BuildAPS());
  1790. }  /* typeld */
  1791.  
  1792. Local Void splitcurenv(splitlevel, ce, le)
  1793. long splitlevel;
  1794. envrec **ce, **le;
  1795. {
  1796.   /* curenv contains:
  1797.        conn. names;mark;ADMnames_n;mark;conn.names_n;mark; 
  1798.        ... ;ADMnames_0; mark; connnames_0; mark;
  1799.        explicitly declared names
  1800.      ce will contain: 
  1801.        conn. names;conn. names_n;mark; ... ; ADMnames_0; mark;
  1802.        connnames_0; mark; explicitly declared names
  1803.      le will contain: 
  1804.        ADMnames_n;mark;...;ADMnames_0;explicitly declared names
  1805.      n = splitlevel
  1806.   */
  1807.   envrec *h, *h2, *hold;
  1808.   long i;
  1809.  
  1810.   hold = NULL;
  1811.   h = curenv;
  1812.   while (!ismark(h)) {
  1813.     hold = h;
  1814.     h = h->next;
  1815.   }
  1816.   h = h->next;
  1817.   *le = h;
  1818.   while (!ismark(h))
  1819.     h = h->next;
  1820.   if (hold == NULL)
  1821.     *ce = h->next;
  1822.   else {
  1823.     *ce = curenv;
  1824.     hold->next = h->next;
  1825.   }
  1826.   hold = h;
  1827.   h = h->next;
  1828.   for (i = 1; i <= splitlevel; i++) {
  1829.     while (!ismark(h))
  1830.       h = h->next;
  1831.     h = h->next;
  1832.     while (!ismark(h)) {
  1833.       h2 = (envrec *)malloc(sizeof(envrec));
  1834.       *h2 = *h;
  1835.       hold->next = h2;
  1836.       hold = h2;
  1837.       h = h->next;
  1838.     }
  1839.   }
  1840.   while (!ismark(h))
  1841.     h = h->next;
  1842.   hold->next = h->next;
  1843. }  /* splitcurenv */
  1844.  
  1845. Local typcrec *typeval(appnon, vl, btns_, splitlevel_)
  1846. adirindic appnon;
  1847. val vl;
  1848. envrec *btns_;
  1849. long splitlevel_;
  1850. {
  1851. /* gives type of vl in type-environment curenv;
  1852.    appnon is the appset type: system application taken as adirectional
  1853.    btns_: basetypes and typenamings holding in types found in vl
  1854.    splitlevel_: nr. of ATO/DEF/MAC typedecl. blockss to be
  1855.                selected if creating an environment with only
  1856.                explicit declarations */
  1857.  
  1858.   struct LOC_typeval V;
  1859.   typcrec *ta, *tf, *t1, *t2;
  1860.   errorrec *er;
  1861.   symbol hnm;
  1862.   envrec *conenv, *locenv;
  1863.   def hl;
  1864.   val hv, hv2;
  1865.   adirindic appfirst, apprest;
  1866.  
  1867.   V.btns = btns_;
  1868.   V.splitlevel = splitlevel_;
  1869.   switch (vl->tag) {
  1870.  
  1871.   case TAGVValApply:
  1872.     tf = typeval(makedirwanted, vl->VValApply.avval, V.btns,V.splitlevel);
  1873.     er = errorlist;
  1874.     errorlist = NULL;
  1875.     t1 = BuildUNKNOWN(newname(), false, false);
  1876.     t2 = BuildUNKNOWN(newname(), false, false);
  1877.     compat(BuildSINGLEARROW(t1, t2), tf, vl->VValApply.avval);
  1878.     if (errorlist == NULL) {   /* tf function type */
  1879.       errorlist = er;
  1880.       compat(t1, typeval(makewanted(t1),vl->VValApply.avpar,V.btns,
  1881.              V.splitlevel), 
  1882.          vl->VValApply.avpar);
  1883.       return t2;
  1884.     } 
  1885.       else { /* try if it is a system appl. */
  1886.       errorlist = NULL;
  1887.       t1 = BuildUNKNOWN(newname(), false, true);
  1888.       compat(BuildSYSTY(BuildOd(BuildNON()), t1), tf,vl->VValApply.avval);
  1889.       if (errorlist==NULL)
  1890.       { /* it IS a system application */
  1891.     if (adaptds)
  1892.     { /*  TAGVValApply s c -> TAGVSysApply s c: */
  1893.           hv = vl->VValApply.avval;
  1894.           hv2 = vl->VValApply.avpar;
  1895.           vl->tag = TAGVSysApply;
  1896.           vl->VSysApply.asval = hv;
  1897.           vl->VSysApply.aspar = hv2;
  1898.     }
  1899.        if (adirwanted(appnon)) 
  1900.        { errorlist = er;
  1901.          compat(t1, typeval(makedirwanted, vl->VValApply.avpar, V.btns, 
  1902.                 V.splitlevel), 
  1903.         vl->VValApply.avpar);
  1904.      return BuildAPS();
  1905.        } 
  1906.        else  /* appnon is not appset type, should be unidir. sys. appl. */
  1907.        {t1 = BuildUNKNOWN(newname(), false, true);
  1908.         t2 = BuildUNKNOWN(newname(), false, true);
  1909.         compat(BuildSYSTY(BuildCd(BuildOd(BuildIN()),
  1910.                         BuildCd(BuildOd(BuildOUT()),
  1911.                              BuildOd(BuildNON()))), BuildCT(t1,
  1912.                      BuildCT(t2,BuildSOME(BuildUNKNOWN(newname(),
  1913.                                                        false,
  1914.                                                        true),
  1915.                                           newname())))), 
  1916.                tf, vl->VValApply.avval);
  1917.        if (errorlist == NULL)  /* tf IS an unidir sys.type */
  1918.        { errorlist = er;
  1919.          compat(t1,
  1920.         typeval(makedirwanted,vl->VValApply.avpar,V.btns, V.splitlevel),
  1921.         vl->VValApply.avpar);
  1922.          return t2;
  1923.        } else
  1924.      { errorlist = er;
  1925.            error(5L, tf, NULL, NULL, vl->VValApply.avval, false);
  1926.            return BuildUNKNOWN(newname(), false, true);
  1927.          }
  1928.      }
  1929.     }
  1930.     else 
  1931.     { errorlist = NULL;
  1932.       ta = typeval(makedirwanted,vl->VValApply.avpar,V.btns,V.splitlevel);
  1933.       compat (BuildINT(), ta, vl->VValApply.avpar);
  1934.       if (errorlist == NULL)    /* indexing */
  1935.      {errorlist = er;
  1936.      if (adaptds)
  1937.      { /* TAGVValApply l i -> TAGVBuiltin "[]" [l,i]: */
  1938.        hv = vl->VValApply.avval;
  1939.        hv2 = vl->VValApply.avpar;
  1940.        hv->next = hv2;
  1941.        hv2->next = NULL;
  1942.        vl->tag = TAGVBuiltin;
  1943.        vl->VBuiltin.oper = "[]";
  1944.        vl->VBuiltin.args = hv;
  1945.      }
  1946.      return uppercomps(tf, vl->VValApply.avval);
  1947.      } else 
  1948.        { errorlist = er;
  1949.          error(6L, tf, ta, NULL, vl, false);
  1950.          return BuildUNKNOWN(newname(), false, false);
  1951.        }
  1952.      }
  1953.     }
  1954.     break;
  1955.  
  1956.   case TAGVSysApply:
  1957.     error(10L, NULL, NULL, Buildsymbol( "typeval", 7L), NULL, false);
  1958.     return BuildUNKNOWN(newname(), false, false);
  1959.     break;
  1960.  
  1961.   case TAGVSym:
  1962.     hnm = vl->VSym.sym;
  1963.     t1 = typename(&hnm);
  1964.     /* no test anymore if name in fc lud lhs and synonyms wasn't
  1965.        declared as something else */
  1966.     vl->VSym.sym = hnm;
  1967.     return t1;
  1968.     break;
  1969.  
  1970.   case TAGVInt:
  1971.     return BuildINT();
  1972.     break;
  1973.  
  1974.   case TAGVFlo:
  1975.     return BuildFLOAT();
  1976.     break;
  1977.  
  1978.   case TAGVStr:
  1979.     return BuildSTRING();
  1980.     break;
  1981.  
  1982.   case TAGVBool:
  1983.     return BuildBOOL();
  1984.     break;
  1985.  
  1986.   case TAGVSysLambda:
  1987.     mark_(&curenv);
  1988.     mark_(&curenv);
  1989.     /* simulate empty block of ATOM/DEF/MAC decls.,
  1990.        because splitcurenv assumes at least one A/D/M block */
  1991.     splitcurenv(V.splitlevel, &conenv, &locenv);
  1992.     curenv = locenv;
  1993.     t1 = typefp(true, vl->VSysLambda.slpar);
  1994.     t2 = typeval(makedirwanted, vl->VSysLambda.slval, V.btns, 0L);
  1995.     if (restrictable(false, true, t1, forcefptoval(vl->VSysLambda.slpar)) &
  1996.      restrictable(false, true, t2, vl->VSysLambda.slval))
  1997.       ta = BuildSYSTY(BuildCd(BuildOd(BuildIN()),
  1998.          BuildCd(BuildOd(BuildOUT()), BuildOd(BuildNON()))),
  1999.        BuildCT(t1, BuildCT(t2, BuildSOME(BuildUNKNOWN(newname(),
  2000.                                                      false,true),
  2001.                                          newname()))));
  2002.     else
  2003.       ta = BuildUNKNOWN(newname(), false, false);
  2004.     release_(&curenv, adaptds && uniq);
  2005.     /* the local connames of this lambda abstr. */
  2006.     curenv = conenv;
  2007.     return ta;
  2008.     break;
  2009.  
  2010.   case TAGVSysSigma:
  2011.     mark_(&curenv);
  2012.     mark_(&curenv);
  2013.     /* simulate empty block of ATOM/DEF/MAC decls.,
  2014.        because splitcurenv assumes at least one A/D/M block */
  2015.     splitcurenv(V.splitlevel, &conenv, &locenv);
  2016.     curenv = locenv;
  2017.     t1 = typefp(true, vl->VSysSigma.sspar);
  2018.     er = errorlist;
  2019.     compat(BuildAPS(), 
  2020.           typeval(makeadirwanted, vl->VSysSigma.ssval, V.btns, 0L),
  2021.           vl->VSysSigma.ssval);
  2022.     if (restrictable(false, true, t1, forcefptoval(vl->VSysSigma.sspar)) &&
  2023.      errorlist == er)
  2024.       ta = BuildSYSTY(BuildOd(BuildNON()), t1);
  2025.     else
  2026.       ta = BuildUNKNOWN(newname(), false, false);
  2027.     release_(&curenv, adaptds && uniq);
  2028.     /* the local connames of this sigma abstr. */
  2029.     curenv = conenv;
  2030.     return ta;
  2031.     break;
  2032.  
  2033.   case TAGVType:   /* does not appear here */
  2034.     error(10L, NULL, NULL, Buildsymbol( "typeval", 7L), NULL, false);
  2035.     return BuildUNKNOWN(newname(), false, false);
  2036.     break;
  2037.  
  2038.   case TAGVWhere:
  2039.     mark_(&curenv);   /* after  formcons and conn. names */
  2040.     mark_(&V.btns);
  2041.     V.btns = extendbtns(vl->VWhere.wdefs, V.btns);
  2042.     extendenvloc(vl->VWhere.wdefs, V.btns);
  2043.     mark_(&curenv);   /* after ATOM/DEF/Mac names */
  2044.     hl = vl->VWhere.wdefs;
  2045.     while (hl != NULL) {
  2046.       compat(BuildAPS(),typeld(hl,V.btns,V.splitlevel+1,&V), NULL);
  2047.       /* compat always correct, so nil does not matter */
  2048.       hl = hl->next;
  2049.     }
  2050.     ta = typeval(appnon, vl->VWhere.wval, V.btns, V.splitlevel + 1);
  2051.     splitcurenv(V.splitlevel, &conenv, &locenv);
  2052.     curenv = locenv;
  2053.     checkdms(vl->VWhere.wdefs, V.btns);
  2054.     release_(&V.btns, adaptds && uniq);
  2055.     release_(&curenv, adaptds && uniq);
  2056.      /* local ATOM/DEF/MACs removed */
  2057.     curenv = conenv;
  2058.     return ta;
  2059.     break;
  2060.  
  2061.   case TAGVList:
  2062.     if (vl->VList.l == NULL) {
  2063.       return BuildSOME(BuildUNKNOWN(newname(), false, false), newname());
  2064.       /* !! mog. foute inv. */
  2065.     } else {
  2066.       splitwanted(appnon,&appfirst,&apprest);
  2067.       t1 = typeval(appfirst, vl->VList.l, V.btns, V.splitlevel);
  2068.       t2 = typeval(apprest, new_VList(vl->VList.l->next), V.btns, V.splitlevel);
  2069.       /* t1, t2 used so that name extension numbers are independent of the
  2070.      order in which the C implementation evaluates function arguments */
  2071.       return BuildCT(t1,t2);
  2072.     }
  2073.     break;
  2074.  
  2075.   case TAGVAppset:
  2076.     t1 = BuildAPS();
  2077.     hv = vl->VAppset.aps;
  2078.     while (hv != NULL) {
  2079.       compat(t1, typeval(makeadirwanted,hv,V.btns,V.splitlevel), hv);
  2080.       hv = hv->next;
  2081.     }
  2082.     return t1;
  2083.     break;
  2084.  
  2085.   case TAGVAtom:   /* need not be treated here */
  2086.     error(10L, NULL, NULL, Buildsymbol( "typeval", 7L), NULL, false);
  2087.     return BuildUNKNOWN(newname(), false, false);
  2088.     break;
  2089.  
  2090.   case TAGVSyn:
  2091.     t1 = BuildUNKNOWN(newname(), false, true);
  2092.     hv = vl->VSyn.synlist;
  2093.     while (hv != NULL) {
  2094.       compat(t1,typeval(makedirwanted,hv,V.btns,V.splitlevel), hv);
  2095.       hv = hv->next;
  2096.     }
  2097.     return BuildAPS();
  2098.     break;
  2099.  
  2100.   case TAGVBuiltin:
  2101.     return typeBuiltin(appnon, vl, &V);
  2102.     break;
  2103.  
  2104.   case TAGVMacLambda:
  2105.     /* only encountered when a def/mac has more parameters
  2106.                    than types for them */
  2107.     error(4L, NULL, NULL, NULL, NULL, false);
  2108.     t1 =typeval(appnon,vl->VMacLambda.mval,V.btns,V.splitlevel);
  2109.     return BuildUNKNOWN(newname(), false, false);
  2110.     break;
  2111.  
  2112.   case TAGVMacAlts:   /* need not be treated here */
  2113.     error(10L, NULL, NULL, Buildsymbol( "typeval", 7L), NULL, false);
  2114.     return BuildUNKNOWN(newname(), false, false);
  2115.     break;
  2116.   }/* case */
  2117. }  /* typeval */
  2118.  
  2119. Void checkglasstext(glass)
  2120. def_list glass;
  2121. {  /* do simple context-sensitive and typing demand checks for a Glass volume;
  2122.      if errors found, deliver errors, otherwise changed data structure */
  2123.   envrec *btns;
  2124.   _PROCEDURE TEMP;
  2125.  
  2126.   adaptds = true;
  2127.   marker = Buildsymbol("",0L); /* initialisation of a constant */
  2128.   errordiscovered = false;
  2129.   forfull = true;
  2130.   namessupply = 0;
  2131.   nestednames = NULL;
  2132.   nestednorig = NULL;
  2133.   extsupply = 0;
  2134.   btns = emptyenv;
  2135.   mark_(&btns);
  2136.   btns = extendbtns(glass, btns);
  2137.   curenv = emptyenv;
  2138.   mark_(&curenv);
  2139.   extendenvloc(glass, btns);
  2140.   checkdms(glass, btns);
  2141.   release_(&btns, uniq);
  2142.   release_(&curenv, uniq);
  2143.   TEMP.proc = (Anyptr)unparsval;
  2144.   printerrors(TEMP, errorlist);
  2145. }  /* checkglasstext */
  2146.