home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / sequence.d < prev    next >
Encoding:
Text File  |  1994-05-07  |  10.5 KB  |  548 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19. */
  20.  
  21. /*
  22.     sequence.d
  23.  
  24.     sequence routines
  25. */
  26.  
  27. #include "include.h"
  28.  
  29. #undef endp
  30.  
  31. #define    endp(obje)    ((enum type)((endp_temp = (obje))->d.t) == t_cons ? \
  32.              FALSE : endp_temp == Cnil ? TRUE : \
  33.              (bool)FEwrong_type_argument(Slist, endp_temp))
  34.  
  35. object endp_temp;
  36.  
  37. /*
  38.     I know the following name is not good.
  39. */
  40. object
  41. alloc_simple_vector(l, aet)
  42. int l;
  43. enum aelttype aet;
  44. {
  45.     object x;
  46.  
  47.     x = alloc_object(t_vector);
  48.     x->v.v_hasfillp = FALSE;
  49.     x->v.v_adjustable = FALSE;
  50.     x->v.v_displaced = Cnil;
  51.     x->v.v_dim = x->v.v_fillp = l;
  52.     x->v.v_self = NULL;
  53.     x->v.v_elttype = (short)aet;
  54.     return(x);
  55. }
  56.  
  57. object
  58. alloc_simple_bitvector(l)
  59. int l;
  60. {
  61.     object x;
  62.  
  63.     x = alloc_object(t_bitvector);
  64.     x->bv.bv_hasfillp = FALSE;
  65.     x->bv.bv_adjustable = FALSE;
  66.     x->bv.bv_displaced = Cnil;
  67.     x->bv.bv_dim = x->bv.bv_fillp = l;
  68.     x->bv.bv_offset = 0;
  69.     x->bv.bv_self = NULL;
  70.     return(x);
  71. }
  72.  
  73. Lelt()
  74. {
  75.     check_arg(2);
  76.     vs_base[0] = elt(vs_base[0], fixint(vs_base[1]));
  77.     vs_pop;
  78. }
  79.  
  80. object
  81. elt(seq, index)
  82. object seq;
  83. int index;
  84. {
  85.     int i;
  86.     object l;
  87.  
  88.     if (index < 0) {
  89.         vs_push(make_fixnum(index));
  90.         FEerror("Negative index: ~D.", 1, vs_head);
  91.     }
  92.     switch (type_of(seq)) {
  93.     case t_cons:
  94.         for (i = index, l = seq;  i > 0;  --i)
  95.             if (endp(l))
  96.                 goto E;
  97.             else
  98.                 l = l->c.c_cdr;
  99.         if (endp(l))
  100.             goto E;
  101.         return(l->c.c_car);
  102.  
  103.     case t_vector:
  104.     case t_bitvector:
  105.         if (index >= seq->v.v_fillp)
  106.             goto E;
  107.         return(aref(seq, index));
  108.  
  109.     case t_string:
  110.         if (index >= seq->st.st_fillp)
  111.             goto E;
  112.         return(code_char(seq->ust.ust_self[index]));
  113.  
  114.     default:
  115.         if (seq == Cnil) goto E;
  116.         FEerror("~S is not a sequence.", 1, seq);
  117.     }
  118.  
  119. E:
  120.     vs_push(make_fixnum(index));
  121.     FEerror("The index, ~D, is too large", 1, vs_head);
  122. }
  123.  
  124. siLelt_set()
  125. {
  126.     check_arg(3);
  127.     vs_base[0] = elt_set(vs_base[0], fixint(vs_base[1]), vs_base[2]);
  128.     vs_pop;
  129.     vs_pop;
  130. }
  131.  
  132. object
  133. elt_set(seq, index, val)
  134. object seq;
  135. int index;
  136. object val;
  137. {
  138.     int i;
  139.     object l;
  140.  
  141.     if (index < 0) {
  142.         vs_push(make_fixnum(index));
  143.         FEerror("Negative index: ~D.", 1, vs_head);
  144.     }
  145.     switch (type_of(seq)) {
  146.     case t_cons:
  147.         for (i = index, l = seq;  i > 0;  --i)
  148.             if (endp(l))
  149.                 goto E;
  150.             else
  151.                 l = l->c.c_cdr;
  152.         if (endp(l))
  153.             goto E;
  154.         return(l->c.c_car = val);
  155.  
  156.     case t_vector:
  157.     case t_bitvector:
  158.         if (index >= seq->v.v_fillp)
  159.             goto E;
  160.         return(aset(seq, index, val));
  161.  
  162.     case t_string:
  163.         if (index >= seq->st.st_fillp)
  164.             goto E;
  165.         if (type_of(val) != t_character)
  166.             FEerror("~S is not a character.", 1, val);
  167.         seq->st.st_self[index] = val->ch.ch_code;
  168.         return(val);
  169.  
  170.     default:
  171.         if (seq == Cnil) goto E;
  172.         FEerror("~S is not a sequence.", 1, seq);
  173.     }
  174.  
  175. E:
  176.     vs_push(make_fixnum(index));
  177.     FEerror("The index, ~D, is too large", 1, vs_head);
  178. }
  179.  
  180. @(defun subseq (sequence start &optional end &aux x)
  181.     int s, e;
  182.     int i, j;
  183. @
  184.     s = fixnnint(start);
  185.     if (end == Cnil)
  186.         e = -1;
  187.     else
  188.         e = fixnnint(end);
  189.     switch (type_of(sequence)) {
  190.     case t_symbol:
  191.         if (sequence == Cnil) {
  192.             if (s > 0)
  193.                 goto ILLEGAL_START_END;
  194.             if (e > 0)
  195.                 goto ILLEGAL_START_END;
  196.             @(return Cnil)
  197.         }
  198.         FEwrong_type_argument(Ssequence, sequence);
  199.  
  200.     case t_cons:
  201.         if (e >= 0)
  202.             if ((e -= s) < 0)
  203.                 goto ILLEGAL_START_END;
  204.         while (s-- > 0) {
  205.             if (type_of(sequence) != t_cons)
  206.                 goto ILLEGAL_START_END;
  207.             sequence = sequence->c.c_cdr;
  208.         }
  209.         if (e < 0)
  210.             @(return `copy_list(sequence)`)
  211.         for (i = 0;  i < e;  i++) {
  212.             if (type_of(sequence) != t_cons)
  213.                 goto ILLEGAL_START_END;
  214.             vs_check_push(sequence->c.c_car);
  215.             sequence = sequence->c.c_cdr;
  216.         }
  217.         vs_push(Cnil);
  218.         while (e-- > 0)
  219.             stack_cons();
  220.         x = vs_pop;
  221.         @(return x)
  222.  
  223.     case t_vector:
  224.         if (s > sequence->v.v_fillp)
  225.             goto ILLEGAL_START_END;
  226.         if (e < 0)
  227.             e = sequence->v.v_fillp;
  228.         else if (e < s || e > sequence->v.v_fillp)
  229.             goto ILLEGAL_START_END;
  230.         x = alloc_simple_vector(e - s, sequence->v.v_elttype);
  231.         array_allocself(x, FALSE,0);
  232.         switch (sequence->v.v_elttype) {
  233.         case aet_object:
  234.         case aet_fix:
  235.         case aet_sf:
  236.             for (i = s, j = 0;  i < e;  i++, j++)
  237.                 x->v.v_self[j] = sequence->v.v_self[i];
  238.             break;
  239.  
  240.         case aet_lf:
  241.             for (i = s, j = 0;  i < e;  i++, j++)
  242.                 x->lfa.lfa_self[j] =
  243.                 sequence->lfa.lfa_self[i];
  244.             break;
  245.  
  246.         case aet_short:
  247.         case aet_ushort:
  248.             for (i = s, j = 0;  i < e;  i++, j++)
  249.                 USHORT(x, j) = USHORT(sequence, i);
  250.             break;
  251.         case aet_char:
  252.         case aet_uchar:
  253.             for (i = s, j = 0;  i < e;  i++, j++)    
  254.               x->st.st_self[j] = sequence->st.st_self[i];
  255.             break;
  256.     
  257.         }
  258.         @(return x)
  259.  
  260.  
  261.     case t_string:
  262.         if (s > sequence->st.st_fillp)
  263.             goto ILLEGAL_START_END;
  264.         if (e < 0)
  265.             e = sequence->st.st_fillp;
  266.         else if (e < s || e > sequence->st.st_fillp)
  267.             goto ILLEGAL_START_END;
  268.         x = alloc_simple_string(e - s);
  269.         x->st.st_self = alloc_relblock(e - s);
  270.         for (i = s, j = 0;  i < e;  i++, j++)
  271.             x->st.st_self[j] = sequence->st.st_self[i];
  272.         @(return x)
  273.  
  274.     case t_bitvector:
  275.         if (s > sequence->bv.bv_fillp)
  276.             goto ILLEGAL_START_END;
  277.         if (e < 0)
  278.             e = sequence->bv.bv_fillp;
  279.         else if (e < s || e > sequence->bv.bv_fillp)
  280.             goto ILLEGAL_START_END;
  281.         x = alloc_simple_bitvector(e - s);
  282.         x->bv.bv_self = alloc_relblock((e-s+7)/8);
  283.         s += sequence->bv.bv_offset;
  284.         e += sequence->bv.bv_offset;
  285.         for (i = s, j = 0;  i < e;  i++, j++)
  286.             if (sequence->bv.bv_self[i/8]&(0200>>i%8))
  287.                 x->bv.bv_self[j/8]
  288.                 |= 0200>>j%8;
  289.             else
  290.                 x->bv.bv_self[j/8]
  291.                 &= ~(0200>>j%8);
  292.         @(return x)
  293.  
  294.     default:
  295.         FEwrong_type_argument(Ssequence, vs_base[0]);
  296.     }
  297.  
  298. ILLEGAL_START_END:
  299.     FEerror("~S and ~S are illegal as :START and :END~%\
  300. for the sequence ~S.", 3, start, end, sequence);
  301. @)
  302.  
  303. Lcopy_seq()
  304. {
  305.     check_arg(1);
  306.     vs_push(small_fixnum(0));
  307.     Lsubseq();
  308. }
  309.  
  310. int
  311. length(x)
  312. object x;
  313. {
  314.     int i;
  315.  
  316.     switch (type_of(x)) {
  317.     case t_symbol:
  318.         if (x == Cnil)
  319.             return(0);
  320.         FEwrong_type_argument(Ssequence, x);
  321.  
  322.     case t_cons:
  323.  
  324. #define cendp(obj) ((type_of(obj)!=t_cons))
  325.         for (i = 0;  !cendp(x);  i++, x = x->c.c_cdr)
  326.             ;
  327.         if (x==Cnil) return(i);
  328.         FEwrong_type_argument(Slist,x);
  329.  
  330.  
  331.     case t_vector:
  332.     case t_string:
  333.     case t_bitvector:
  334.         return(x->v.v_fillp);
  335.  
  336.     default:
  337.         FEwrong_type_argument(Ssequence, x);
  338.     }
  339. }
  340.  
  341. Llength()
  342. {
  343.     check_arg(1);
  344.     vs_base[0] = make_fixnum(length(vs_base[0]));
  345. }
  346.  
  347. Lreverse()
  348. {
  349.     check_arg(1);
  350.     vs_base[0] = reverse(vs_base[0]);
  351. }
  352.  
  353. object
  354. reverse(seq)
  355. object seq;
  356. {
  357.     object x, y, *v;
  358.     int i, j, k;
  359.  
  360.     switch (type_of(seq)) {
  361.     case t_symbol:
  362.         if (seq == Cnil)
  363.             return(Cnil);
  364.         FEwrong_type_argument(Ssequence, seq);
  365.  
  366.     case t_cons:
  367.         v = vs_top;
  368.         vs_push(Cnil);
  369.         for (x = seq;  !endp(x);  x = x->c.c_cdr)
  370.             *v = make_cons(x->c.c_car, *v);
  371.         return(vs_pop);
  372.  
  373.     case t_vector:
  374.         x = seq;
  375.         k = x->v.v_fillp;
  376.         y = alloc_simple_vector(k, x->v.v_elttype);
  377.         vs_push(y);
  378.         array_allocself(y, FALSE,0);
  379.         switch (x->v.v_elttype) {
  380.         case aet_object:
  381.         case aet_fix:
  382.         case aet_sf:
  383.             for (j = k - 1, i = 0;  j >=0;  --j, i++)
  384.                 y->v.v_self[j] = x->v.v_self[i];
  385.             break;
  386.  
  387.         case aet_lf:
  388.             for (j = k - 1, i = 0;  j >=0;  --j, i++)
  389.                 y->lfa.lfa_self[j] = x->lfa.lfa_self[i];
  390.             break;
  391.  
  392.         case aet_short:
  393.         case aet_ushort:
  394.             for (j = k - 1, i = 0;  j >=0;  --j, i++)
  395.                 USHORT(y, j) = USHORT(x, i);
  396.             break;
  397.         case aet_char:
  398.         case aet_uchar:
  399.             goto TYPE_STRING;
  400.         }
  401.         return(vs_pop);
  402.  
  403.     case t_string:
  404.         x = seq;
  405.         y = alloc_simple_string(x->st.st_fillp);
  406.         TYPE_STRING:
  407.         vs_push(y);
  408.         y->st.st_self
  409.         = alloc_relblock(x->st.st_fillp);
  410.         for (j = x->st.st_fillp - 1, i = 0;  j >=0;  --j, i++)
  411.             y->st.st_self[j] = x->st.st_self[i];
  412.         return(vs_pop);
  413.  
  414.     case t_bitvector:
  415.         x = seq;
  416.         y = alloc_simple_bitvector(x->bv.bv_fillp);
  417.         vs_push(y);
  418.         y->bv.bv_self
  419.         = alloc_relblock((x->bv.bv_fillp+7)/8);
  420.         for (j = x->bv.bv_fillp - 1, i = x->bv.bv_offset;
  421.              j >=0;
  422.              --j, i++)
  423.             if (x->bv.bv_self[i/8]&(0200>>i%8))
  424.                 y->bv.bv_self[j/8] |= 0200>>j%8;
  425.             else
  426.                 y->bv.bv_self[j/8] &= ~(0200>>j%8);
  427.         return(vs_pop);
  428.  
  429.     default:
  430.         FEwrong_type_argument(Ssequence, seq);
  431.     }
  432. }
  433.  
  434. Lnreverse()
  435. {
  436.     check_arg(1);
  437.     vs_base[0] = nreverse(vs_base[0]);
  438. }
  439.  
  440. object
  441. nreverse(seq)
  442. object seq;
  443. {
  444.     object x, y, z;
  445.     int i, j, k;
  446.  
  447.     switch (type_of(seq)) {
  448.     case t_symbol:
  449.         if (seq == Cnil)
  450.             return(Cnil);
  451.         FEwrong_type_argument(Ssequence, seq);
  452.  
  453.     case t_cons:
  454.         for (x = Cnil, y = seq;  !endp(y->c.c_cdr);) {
  455.             z = y;
  456.             y = y->c.c_cdr;
  457.             z->c.c_cdr = x;
  458.             x = z;
  459.         }
  460.         y->c.c_cdr = x;
  461.         return(y);
  462.  
  463.     case t_vector:
  464.         x = seq;
  465.         k = x->v.v_fillp;
  466.         switch (x->v.v_elttype) {
  467.         case aet_object:
  468.         case aet_fix:
  469.         case aet_sf:
  470.             for (i = 0, j = k - 1;  i < j;  i++, --j) {
  471.                 y = x->v.v_self[i];
  472.                 x->v.v_self[i] = x->v.v_self[j];
  473.                 x->v.v_self[j] = y;
  474.             }
  475.             return(seq);
  476.  
  477.         case aet_lf:
  478.             for (i = 0, j = k - 1;  i < j;  i++, --j) {
  479.                 longfloat y;
  480.                 y = x->lfa.lfa_self[i];
  481.                 x->lfa.lfa_self[i] = x->lfa.lfa_self[j];
  482.                 x->lfa.lfa_self[j] = y;
  483.             }
  484.             return(seq);
  485.  
  486.         case aet_short:
  487.         case aet_ushort:
  488.             for (i = 0, j = k - 1;  i < j;  i++, --j) {
  489.                 unsigned short y;
  490.                 y = USHORT(x, i);
  491.                 USHORT(x, i) = USHORT(x, j);
  492.                 USHORT(x, y) = y;
  493.             }
  494.             return(seq);
  495.         case aet_char:
  496.         case aet_uchar:
  497.             goto TYPE_STRING;
  498.         }
  499.  
  500.     case t_string:
  501.         x = seq;
  502.     TYPE_STRING:    
  503.         for (i = 0, j = x->st.st_fillp - 1;  i < j;  i++, --j) {
  504.             k = x->st.st_self[i];
  505.             x->st.st_self[i] = x->st.st_self[j];
  506.             x->st.st_self[j] = k;
  507.         }
  508.         return(seq);
  509.  
  510.     case t_bitvector:
  511.         x = seq;
  512.         for (i = x->bv.bv_offset,
  513.              j = x->bv.bv_fillp + x->bv.bv_offset - 1;
  514.              i < j;
  515.              i++, --j) {
  516.             k = x->bv.bv_self[i/8]&(0200>>i%8);
  517.             if (x->bv.bv_self[j/8]&(0200>>j%8))
  518.                 x->bv.bv_self[i/8]
  519.                 |= 0200>>i%8;
  520.             else
  521.                 x->bv.bv_self[i/8]
  522.                 &= ~(0200>>i%8);
  523.             if (k)
  524.                 x->bv.bv_self[j/8]
  525.                 |= 0200>>j%8;
  526.             else
  527.                 x->bv.bv_self[j/8]
  528.                 &= ~(0200>>j%8);
  529.         }
  530.         return(seq);
  531.  
  532.     default:
  533.         FEwrong_type_argument(Ssequence, seq);
  534.     }
  535. }
  536.  
  537.  
  538. init_sequence_function()
  539. {
  540.     make_function("ELT", Lelt);
  541.     make_si_function("ELT-SET", siLelt_set);
  542.     make_function("SUBSEQ", Lsubseq);
  543.     make_function("COPY-SEQ", Lcopy_seq);
  544.     make_function("LENGTH", Llength);
  545.     make_function("REVERSE", Lreverse);
  546.     make_function("NREVERSE", Lnreverse);
  547. }
  548.