home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume10 / ifp / part03 / interp / F_subseq.c < prev   
Encoding:
C/C++ Source or Header  |  1987-07-05  |  7.4 KB  |  328 lines
  1.  
  2. /****** F_subseq.c ****************************************************/
  3. /**                                                                  **/
  4. /**                    University of Illinois                        **/
  5. /**                                                                  **/
  6. /**                Department of Computer Science                    **/
  7. /**                                                                  **/
  8. /**   Tool: IFP                         Version: 0.5                 **/
  9. /**                                                                  **/
  10. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  11. /**                                                                  **/
  12. /**   Revised by: Arch D. Robison       Date:  Apr 28, 1986          **/
  13. /**                                                                  **/
  14. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  15. /**                            Prof. W. J. Kubitz                    **/
  16. /**                                                                  **/
  17. /**                                                                  **/
  18. /**------------------------------------------------------------------**/
  19. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  20. /**                       All Rights Reserved.                       **/
  21. /**********************************************************************/
  22.  
  23. #include <stdio.h>    /* defines NULL */
  24. #include "struct.h"
  25. #include "node.h"
  26.  
  27. /*
  28.  * ListIndex
  29.  *
  30.  * Check an argument to make sure it is of the form <sequence integer>
  31.  *
  32.  * Input
  33.  *      InOut = argument
  34.  *
  35.  * Output
  36.  *      *L = sequence or array if no error
  37.  *      result = -1 if error occurred, index otherwise
  38.  */
  39. private long ListIndex (InOut,L)
  40.    ObjectPtr InOut;
  41.    ListPtr *L;
  42.    {
  43.       register ListPtr P;
  44.       FPint N;
  45.  
  46.       if (!PairTest (InOut, SEQUENCE, NUMERIC)) {
  47.      FunError ("not <sequence number>",InOut);
  48.      return -1;
  49.       } else {
  50.      P = InOut->List;
  51.      *L = P->Val.List;
  52.      P = P->Next;
  53.      switch (GetFPInt (&P->Val,&N)) {
  54.         default: /* actually case 0, but we need to keep lint happy */
  55.            if (N >= 0) return N;
  56.            else {
  57.           FunError ("negative index",InOut);
  58.           return -1;
  59.            }
  60.         case 1: 
  61.            FunError ("index not integral",InOut); 
  62.            return -1;
  63.         case 2:
  64.            FunError ("index too big",InOut);
  65.            return -1;
  66.      }
  67.       }
  68.    }
  69.  
  70. #define SCATTER_STORE 0
  71.  
  72. #if SCATTER_STORE
  73. /*
  74.  * F_Scatter
  75.  *
  76.  * Scatter store function
  77.  *
  78.  * Input
  79.  *      <<D1 D2 ... Dn> <<V1 I1> <V2 I2> ... <Vm Im>>>
  80.  *
  81.  * Output
  82.  *      <E1 E2 ... En>
  83.  *
  84.  * Ek = Dk if there is no Ij == k
  85.  *      Vj if Ij == k
  86.  *
  87.  * Result is BOTTOM if Ij==Ik for j!=k or Ij < 1 or Ij > n
  88.  *
  89.  * Perversions: uses LRef field for markers
  90.  */
  91. private F_Scatter (InOut)
  92.    ObjectPtr InOut;
  93.    {
  94.       register ListPtr P1,P2,Q,R;
  95.       register long N;
  96.       FPint M;
  97.  
  98.       if (!PairTest (InOut,1<<LIST,1<<LIST))
  99.      FunError ("not <sequence sequence>",InOut);
  100.  
  101.       else {
  102.  
  103.      Copy2Top (&InOut->List); /* only need fresh first element */
  104.      P1 = InOut->List;
  105.      R = P1->Val.List;
  106.      N = ListLength (R);
  107.  
  108.      for (P1 = P1->Next->Val.List; P1!=NULL; P1=P1->Next) {
  109.         if (!PairTest (&P1->Val,~0,NUMERIC)) {
  110.            FunError ("invalid store pair",InOut);
  111.            return;
  112.         }
  113.         P2 = P1->Val.List;
  114.         if (GetFPInt (&P2->Next->Val,&M) || M < 1 || M > N) {
  115.            FunError ("invalid index",InOut);
  116.            return;
  117.         }
  118.         for (Q=R; --M; Q=Q->Next) continue;
  119.         if (++Q->LRef > 2) {
  120.            for (Q=R; Q!=NULL; Q=Q->Next) Q->LRef = 1;
  121.            FunError ("duplicate index",InOut);
  122.            return;
  123.         }
  124.         RepObject (&Q->Val,&P2->Val);
  125.      }
  126.      for (Q=R; Q!=NULL; Q=Q->Next) Q->LRef = 1;
  127.      RepObject (InOut,&InOut->List->Val);
  128.       }
  129.    }
  130. #endif
  131.  
  132. /*
  133.  * F_Pick
  134.  * 
  135.  * Pick the nth element of a sequence
  136.  *
  137.  * Input
  138.  *      InOut = pointer to <sequence number>
  139.  */
  140. private F_Pick (InOut)
  141.    ObjectPtr InOut;
  142.    {
  143.       register FPint N;
  144.       ListPtr P; 
  145.  
  146.       if ((N = ListIndex (InOut,&P)) >= 0) {
  147.      if (N <= 0) {
  148.         FunError ("non-positive index",InOut);
  149.      } else if (P == NULL) FunError ("empty sequence",InOut);
  150.      else {
  151.         while (--N > 0)
  152.            if ((P = P->Next) == NULL) {
  153.           FunError ("index out of bounds",InOut);
  154.           return;
  155.            }
  156.         RepObject (InOut,&P->Val);
  157.      }
  158.       }
  159.    }
  160.  
  161.  
  162. /*
  163.  * F_Repeat
  164.  *
  165.  * Create a repetition of an item.
  166.  *
  167.  * E.g. <x 8> == <x x x x x x x x>
  168.  */
  169. private F_Repeat (InOut)
  170.    register ObjectPtr InOut;
  171.    {
  172.       FPint N;
  173.       register ListPtr P;
  174.  
  175.       if (!PairTest (InOut,~0,NUMERIC))
  176.      FunError ("not <object number>",InOut);
  177.  
  178.       else {
  179.      P = InOut->List;
  180.      switch (GetFPInt (&P->Next->Val,&N)) {
  181.         case 1:
  182.            FunError ("repetition value not integer",InOut);
  183.            break;
  184.         case 2:
  185.            FunError ("repetition value too big",InOut);
  186.            break;
  187.         case 0:
  188.            if (N < 0) FunError ("negative repetition",InOut);
  189.            else {
  190.           P = Repeat (&P->Val,(long) N);
  191.           DelLPtr (InOut->List);
  192.           InOut->List = P;
  193.            }
  194.            break;
  195.         }
  196.       }
  197.    }
  198.  
  199.  
  200. /*
  201.  * F_RDrop
  202.  *
  203.  * Drop the last n elements from a sequence
  204.  *
  205.  * Input
  206.  *      InOut = pointer to <sequence number>
  207.  */
  208. private F_RDrop (InOut)
  209.    ObjectPtr InOut;
  210.    {
  211.       register FPint N;
  212.       ListPtr P,Result;
  213.       register ListPtr R;
  214.  
  215.       if ((N = ListIndex (InOut,&P)) >= 0) 
  216.      if ((N = ListLength (P) - N) < 0) 
  217.         FunError ("sequence too short",InOut);
  218.      else {
  219.         Result = NULL;
  220.         NewList (&Result,N);
  221.         for (R = Result; R!=NULL; P=P->Next,R=R->Next) 
  222.            CopyObject (&R->Val,&P->Val);
  223.         DelLPtr (InOut->List);
  224.         InOut->List = Result;
  225.      }
  226.    }
  227.  
  228.  
  229. /*
  230.  * F_LDrop
  231.  *
  232.  * Drop the first n elements from a sequence
  233.  *
  234.  * Input
  235.  *      InOut = pointer to <sequence number>
  236.  */
  237. private F_LDrop (InOut)
  238.    ObjectPtr InOut;
  239.    {
  240.       register FPint N;   
  241.       ListPtr P; 
  242.  
  243.       if ((N = ListIndex (InOut,&P)) >= 0) {
  244.      for (; --N >= 0; P = P->Next)
  245.         if (P == NULL) {
  246.            FunError ("sequence too short",InOut);
  247.            return;
  248.         }
  249.      RepLPtr (&InOut->List,P);
  250.       }
  251.    }
  252.  
  253.  
  254. /*
  255.  * F_LTake
  256.  *
  257.  * Take the first n elements from a sequence
  258.  *
  259.  * Input
  260.  *      InOut = pointer to <sequence number>
  261.  */
  262. private F_LTake (InOut)
  263.    ObjectPtr InOut;
  264.    {
  265.       register long N;
  266.       ListPtr P,Result;
  267.       register ListPtr R;
  268.  
  269.       if ((N = ListIndex (InOut,&P)) >= 0) {
  270.      Result = NULL;
  271.      NewList (&Result,N);
  272.      for (R = Result; R!=NULL; P=P->Next, R=R->Next)
  273.         if (P != NULL)
  274.            CopyObject (&R->Val,&P->Val);
  275.         else {
  276.            FunError ("sequence too short",InOut);
  277.            DelLPtr (Result);
  278.            return;
  279.         } 
  280.      DelLPtr (InOut->List);
  281.      InOut->List = Result;
  282.       }
  283.    }
  284.  
  285.  
  286. /*
  287.  * F_RTake
  288.  *
  289.  * Take the last n elements from a sequence
  290.  *
  291.  * Input
  292.  *      InOut = pointer to <sequence number>
  293.  */
  294. private F_RTake (InOut)
  295.    ObjectPtr InOut;
  296.    {
  297.       register FPint N;
  298.       ListPtr P;
  299.  
  300.       if ((N = ListIndex (InOut,&P)) >= 0) 
  301.      if ((N = ListLength (P) - N) < 0)
  302.         FunError ("sequence too short",InOut);
  303.      else {
  304.         while (--N >=0) P = P->Next;
  305.         RepLPtr (&InOut->List,P);
  306.      }
  307.    }
  308.  
  309. private OpDef SubSeqOps [] = {
  310.    {"dropl",    -1,     F_LDrop},
  311.    {"dropr",    -1,     F_RDrop},
  312.    {"pick",     -1,     F_Pick},
  313.    {"repeat",   -1,     F_Repeat},
  314.    {"takel",    -1,     F_LTake},
  315.    {"taker",    -1,     F_RTake}
  316. #if SCATTER_STORE
  317.    {"scatter",  -1,     F_Scatter},
  318. #endif
  319. };
  320.  
  321. void D_subseq ()
  322.    {
  323.       GroupDef (SubSeqOps, OpCount (SubSeqOps), SysNode);
  324.    }
  325.  
  326. /************************** end of F_subseq **************************/
  327.  
  328.