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 / string.d < prev    next >
Encoding:
Text File  |  1994-05-07  |  13.7 KB  |  611 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.     string.d
  23.  
  24.     string routines
  25. */
  26.  
  27. #include "include.h"
  28.  
  29. object Kstart1;
  30. object Kend1;
  31. object Kstart2;
  32. object Kend2;
  33. object Kinitial_element;
  34.  
  35. object
  36. alloc_simple_string(l)
  37. int l;
  38. {
  39.     object x;
  40.  
  41.     x = alloc_object(t_string);
  42.     x->st.st_hasfillp = FALSE;
  43.     x->st.st_adjustable = FALSE;
  44.     x->st.st_displaced = Cnil;
  45.     x->st.st_dim = x->st.st_fillp = l;
  46.     x->st.st_self = NULL;
  47.     return(x);
  48. }
  49.  
  50. /*
  51.     Make_simple_string(s) makes a simple string from C string s.
  52. */
  53. object
  54. make_simple_string(s)
  55. char *s;
  56. {
  57.     int l, i;
  58.     char *p;
  59.     object x;
  60.     vs_mark;
  61.  
  62.     for (l = 0;  s[l] != '\0';  l++)
  63.         ;
  64.     x = alloc_simple_string(l);
  65.     vs_push(x);
  66.     p = alloc_relblock(l);
  67.     for (i = 0;  i < l;  i++)
  68.         p[i] = s[i];
  69.     x->st.st_self = p;
  70.     vs_reset;
  71.     return(x);
  72. }
  73.  
  74. /*
  75.     This correponds to string= (just the string equality).
  76. */
  77. bool
  78. string_eq(x, y)
  79. object x, y;
  80. {
  81.     int i, j;
  82.  
  83. /*
  84.     if (type_of(x) != t_string || type_of(y) != t_string)
  85.         error("string expected");
  86. */
  87.     i = x->st.st_fillp;
  88.     j = y->st.st_fillp;
  89.     if (i != j)
  90.         return(FALSE);
  91.     for (i = 0;  i < j;  i++)
  92.         if (x->st.st_self[i] != y->st.st_self[i])
  93.             return(FALSE);
  94.     return(TRUE);
  95. }
  96.  
  97. /*
  98.     This corresponds to string-equal
  99.     (string equality ignoring the case).
  100. */
  101. bool
  102. string_equal(x, y)
  103. object x, y;
  104. {
  105.     int i, j;
  106.     char *p, *q;
  107.  
  108. /*
  109.     if (type_of(x) != t_string || type_of(y) != t_string)
  110.         error("string expected");
  111. */
  112.     i = x->st.st_fillp;
  113.     j = y->st.st_fillp;
  114.     if (i != j)
  115.         return(FALSE);
  116.     p = x->st.st_self;
  117.     q = y->st.st_self;
  118.     for (i = 0;  i < j;  i++)
  119.         if ((isLower(p[i]) ? p[i] - ('a' - 'A') : p[i])
  120.          != (isLower(q[i]) ? q[i] - ('a' - 'A') : q[i]))
  121.             return(FALSE);
  122.     return(TRUE);
  123. }
  124.  
  125. /*
  126.     Copy_simple_string(x) copies string x to a simple string.
  127. */
  128. object
  129. copy_simple_string(x)
  130. object x;
  131. {
  132.     object y;
  133.     int i;
  134.     vs_mark;
  135.  
  136.     vs_push(x);
  137. /*
  138.     if (type_of(x) != t_string)
  139.         error("string expected");
  140. */
  141.     y = alloc_object(t_string);
  142.     y->st.st_dim = y->st.st_fillp = x->st.st_fillp;
  143.     y->st.st_hasfillp = FALSE;
  144.     y->st.st_adjustable = FALSE;
  145.     y->st.st_displaced = Cnil;
  146.     y->st.st_self = NULL;
  147.     vs_push(y);
  148.     y->st.st_self = alloc_relblock(x->st.st_fillp);
  149.     for (i = 0;  i < x->st.st_fillp;  i++)
  150.         y->st.st_self[i] = x->st.st_self[i];
  151.     vs_reset;
  152.     return(y);
  153. }
  154.  
  155. object
  156. coerce_to_string(x)
  157. object x;
  158. {
  159.     object y;
  160.     int i;
  161.     vs_mark;
  162.  
  163.     switch (type_of(x)) {
  164.     case t_symbol:
  165.         y = alloc_simple_string(x->s.s_fillp);
  166.         vs_push(y);
  167.         if (x->s.s_self < heap_end)
  168.             y->st.st_self = x->s.s_self;
  169.         else {
  170.             y->st.st_self = alloc_relblock(x->s.s_fillp);
  171.             for (i = 0;  i < x->s.s_fillp;  i++)
  172.                 y->st.st_self[i] = x->s.s_self[i];
  173.         }
  174.         vs_reset;
  175.         return(y);
  176.  
  177.     case t_fixnum:
  178.         x = coerce_to_character(x);
  179.         vs_push(x);
  180.  
  181.     case t_character:
  182.         y = alloc_simple_string(1);
  183.         vs_push(y);
  184.         y->st.st_self = alloc_relblock(1);
  185.         y->st.st_self[0] = char_code(x);
  186.         vs_reset;
  187.         return(y);
  188.  
  189.     case t_string:
  190.         return(x);
  191.     }
  192.     FEerror("~S cannot be coerced to a string.", 1, x);
  193. }
  194.  
  195. @(defun char (s i)
  196.     int j;
  197. @
  198.     check_type_string(&s);
  199.     if (type_of(i) != t_fixnum)
  200.         illegal_index(s, i);
  201.     if ((j = fix(i)) < 0 || j >= s->st.st_fillp)
  202.         illegal_index(s, i);
  203.     @(return `code_char(s->ust.ust_self[j])`)
  204. @)
  205.  
  206. siLchar_set()
  207. {
  208.     int j;
  209.  
  210.     check_arg(3);
  211.     check_type_string(&vs_base[0]);
  212.     if (type_of(vs_base[1]) != t_fixnum)
  213.         illegal_index(vs_base[0], vs_base[1]);
  214.     if ((j = fix(vs_base[1])) < 0 || j >= vs_base[0]->st.st_fillp)
  215.         illegal_index(vs_base[0], vs_base[1]);
  216.     check_type_character(&vs_base[2]);
  217.     vs_base[0]->st.st_self[j] = char_code(vs_base[2]);
  218.     vs_base += 2;
  219. }
  220.  
  221. get_string_start_end(string, start, end, ps, pe)
  222. object string, start, end;
  223. int *ps, *pe;
  224. {
  225.     if (start == Cnil)
  226.         *ps = 0;
  227.     else if (type_of(start) != t_fixnum)
  228.         goto E;
  229.     else {
  230.         *ps = fix(start);
  231.         if (*ps < 0)
  232.             goto E;
  233.     }
  234.     if (end == Cnil) {
  235.         *pe = string->st.st_fillp;
  236.         if (*pe < *ps)
  237.             goto E;
  238.     } else if (type_of(end) != t_fixnum)
  239.         goto E;
  240.     else {
  241.         *pe = fix(end);
  242.         if (*pe < *ps || *pe > string->st.st_fillp)
  243.             goto E;
  244.     }
  245.     return;
  246.  
  247. E:
  248.     FEerror("~S and ~S are illegal as :START and :END~%\
  249. for the string ~S.", 3, start, end, string);
  250. }
  251.  
  252. @(defun string_eq (string1 string2
  253.            &key start1 end1 start2 end2)
  254.     int s1, e1, s2, e2;
  255. @
  256.     string1 = coerce_to_string(string1);
  257.     string2 = coerce_to_string(string2);
  258.     get_string_start_end(string1, start1, end1, &s1, &e1);
  259.     get_string_start_end(string2, start2, end2, &s2, &e2);
  260.     if (e1 - s1 != e2 - s2)
  261.         @(return Cnil)
  262.     while (s1 < e1)
  263.         if (string1->st.st_self[s1++] !=
  264.             string2->st.st_self[s2++])
  265.             @(return Cnil)
  266.     @(return Ct)
  267. @)
  268.  
  269. @(defun string_equal (string1 string2
  270.               &key start1 end1 start2 end2)
  271.     int s1, e1, s2, e2;
  272.     int i1, i2;
  273. @
  274.     string1 = coerce_to_string(string1);
  275.     string2 = coerce_to_string(string2);
  276.     get_string_start_end(string1, start1, end1, &s1, &e1);
  277.     get_string_start_end(string2, start2, end2, &s2, &e2);
  278.     if (e1 - s1 != e2 - s2)
  279.         @(return Cnil)
  280.     while (s1 < e1) {
  281.         i1 = string1->st.st_self[s1++];
  282.         i2 = string2->st.st_self[s2++];
  283.         if (isLower(i1))
  284.             i1 -= 'a' - 'A';
  285.         if (isLower(i2))
  286.             i2 -= 'a' - 'A';
  287.         if (i1 != i2)
  288.             @(return Cnil)
  289.     }
  290.     @(return Ct)
  291. @)
  292.  
  293.  
  294. static int sign, boundary;
  295.  
  296. @(defun string_cmp (string1 string2
  297.             &key start1 end1 start2 end2)
  298.     int s1, e1, s2, e2;
  299.     int i1, i2;
  300.     int s;
  301. @
  302.     string1 = coerce_to_string(string1);
  303.     string2 = coerce_to_string(string2);
  304.     get_string_start_end(string1, start1, end1, &s1, &e1);
  305.     get_string_start_end(string2, start2, end2, &s2, &e2);
  306.     while (s1 < e1) {
  307.         if (s2 == e2)
  308.             @(return `sign>0 ? Cnil : make_fixnum(s1)`)
  309.         i1 = string1->ust.ust_self[s1];
  310.         i2 = string2->ust.ust_self[s2];
  311.         if (sign == 0) {
  312.             if (i1 != i2)
  313.                 @(return `make_fixnum(s1)`)
  314.         } else {
  315.             s = sign*(i2-i1);
  316.             if (s > 0)
  317.                 @(return `make_fixnum(s1)`)
  318.             if (s < 0)
  319.                 @(return Cnil)
  320.         }
  321.         s1++;
  322.         s2++;
  323.     }
  324.     if (s2 == e2)
  325.         @(return `boundary==0 ? make_fixnum(s1) : Cnil`)
  326.     @(return `sign>=0 ? make_fixnum(s1) : Cnil`)
  327. @)
  328.  
  329. Lstring_l()  { sign =  1;  boundary = 1;  Lstring_cmp(); }
  330. Lstring_g()  { sign = -1;  boundary = 1;  Lstring_cmp(); }
  331. Lstring_le() { sign =  1;  boundary = 0;  Lstring_cmp(); }
  332. Lstring_ge() { sign = -1;  boundary = 0;  Lstring_cmp(); }
  333. Lstring_neq() { sign = 0;  boundary = 1;  Lstring_cmp(); }
  334.  
  335. @(defun string_compare (string1 string2
  336.             &key start1 end1 start2 end2)
  337.     int s1, e1, s2, e2;
  338.     int i1, i2;
  339.     int s;
  340. @
  341.     string1 = coerce_to_string(string1);
  342.     string2 = coerce_to_string(string2);
  343.     get_string_start_end(string1, start1, end1, &s1, &e1);
  344.     get_string_start_end(string2, start2, end2, &s2, &e2);
  345.     while (s1 < e1) {
  346.         if (s2 == e2)
  347.             @(return `sign>0 ? Cnil : make_fixnum(s1)`)
  348.         i1 = string1->ust.ust_self[s1];
  349.         if (isLower(i1))
  350.             i1 -= 'a' - 'A';
  351.         i2 = string2->ust.ust_self[s2];
  352.         if (isLower(i2))
  353.             i2 -= 'a' - 'A';
  354.         if (sign == 0) {
  355.             if (i1 != i2)
  356.                 @(return `make_fixnum(s1)`)
  357.         } else {
  358.             s = sign*(i2-i1);
  359.             if (s > 0)
  360.                 @(return `make_fixnum(s1)`)
  361.             if (s < 0)
  362.                 @(return Cnil)
  363.         }
  364.         s1++;
  365.         s2++;
  366.     }
  367.     if (s2 == e2)
  368.         @(return `boundary==0 ? make_fixnum(s1) : Cnil`)
  369.     @(return `sign>=0 ? make_fixnum(s1) : Cnil`)
  370. @)
  371.  
  372. Lstring_lessp()         { sign =  1; boundary = 1;  Lstring_compare(); }
  373. Lstring_greaterp()      { sign = -1; boundary = 1;  Lstring_compare(); }
  374. Lstring_not_greaterp()  { sign =  1; boundary = 0;  Lstring_compare(); }
  375. Lstring_not_lessp()     { sign = -1; boundary = 0;  Lstring_compare(); }
  376. Lstring_not_equal()    { sign =  0; boundary = 1;  Lstring_compare(); }
  377.  
  378.  
  379. @(defun make_string (size
  380.              &key (initial_element `code_char(' ')`)
  381.              &aux x)
  382.     int i;
  383. @
  384.     while (type_of(size) != t_fixnum || fix(size) < 0)
  385.         size
  386.         = wrong_type_argument(TSnon_negative_integer, size);
  387.         /*  bignum not allowed, this is PRACTICAL!!  */
  388.     while (type_of(initial_element) != t_character ||
  389.            char_bits(initial_element) != 0 ||
  390.            char_font(initial_element) != 0)
  391.         initial_element
  392.         = wrong_type_argument(Sstring_char, initial_element);
  393.     x = alloc_simple_string(fix(size));
  394.     x->st.st_self = alloc_relblock(fix(size));
  395.     for (i = 0;  i < fix(size);  i++)
  396.         x->st.st_self[i] = char_code(initial_element);
  397.     @(return x)
  398. @)
  399.  
  400. bool
  401. member_char(c, char_bag)
  402. int c;
  403. object char_bag;
  404. {
  405.     int i, f;
  406.  
  407.     switch (type_of(char_bag)) {
  408.     case t_symbol:
  409.     case t_cons:
  410.         while (!endp(char_bag)) {
  411.             if (type_of(char_bag->c.c_car) == t_character
  412.                  &&    c == char_code(char_bag->c.c_car))
  413.                 return(TRUE);
  414.             char_bag = char_bag->c.c_cdr;
  415.         }
  416.         return(FALSE);
  417.  
  418.     case t_vector:
  419.         for (i = 0, f = char_bag->v.v_fillp;  i < f;  i++) {
  420.             if (type_of(char_bag->v.v_self[i]) != t_character
  421.               && c == char_code(char_bag->v.v_self[i]))
  422.                 return(TRUE);
  423.         }
  424.         return(FALSE);
  425.  
  426.     case t_string:
  427.         for (i = 0, f = char_bag->st.st_fillp;  i < f;  i++) {
  428.             if (c == char_bag->st.st_self[i])
  429.                 return(TRUE);
  430.         }
  431.         return(FALSE);
  432.  
  433.     case t_bitvector:
  434.         return(FALSE);
  435.  
  436.     default:
  437.         FEerror("~S is not a sequence.", 1, char_bag);
  438.     }
  439. }
  440.  
  441. static bool left_trim;
  442. static bool right_trim;
  443.  
  444. Lstring_trim() { left_trim = right_trim = TRUE; Lstring_trim0(); }
  445. Lstring_left_trim() { left_trim = TRUE; right_trim = FALSE; Lstring_trim0(); }
  446. Lstring_right_trim() { left_trim = FALSE; right_trim = TRUE; Lstring_trim0();}
  447.  
  448. @(defun string_trim0 (char_bag strng &aux res)
  449.     int i, j, k;
  450. @
  451.     strng = coerce_to_string(strng);
  452.     i = 0;
  453.     j = strng->st.st_fillp - 1;
  454.     if (left_trim)
  455.         for (;  i <= j;  i++)
  456.             if (!member_char(strng->st.st_self[i], char_bag))
  457.                 break;
  458.     if (right_trim)
  459.         for (;  j >= i;  --j)
  460.             if (!member_char(strng->st.st_self[j], char_bag))
  461.                 break;
  462.     k = j - i + 1;
  463.     res = alloc_simple_string(k);
  464.     res->st.st_self = alloc_relblock(k);
  465.     for (j = 0;  j < k;  j++)
  466.         res->st.st_self[j] = strng->st.st_self[i + j];
  467.     @(return res)
  468. @)
  469.  
  470. static char_upcase(c, bp)
  471. int c, *bp;
  472. {
  473.     if (isLower(c))
  474.         return(c - ('a' - 'A'));
  475.     else
  476.         return(c);
  477. }
  478.  
  479. static char_downcase(c, bp)
  480. int c, *bp;
  481. {
  482.     if (isUpper(c))
  483.         return(c + ('a' - 'A'));
  484.     else
  485.         return(c);
  486. }
  487.  
  488. static char_capitalize(c, bp)
  489. int c, *bp;
  490. {
  491.     if (isLower(c)) {
  492.         if (*bp)
  493.             c -= 'a' - 'A';
  494.         *bp = FALSE;
  495.     } else if (isUpper(c)) {
  496.         if (!*bp)
  497.             c += 'a' - 'A';
  498.         *bp = FALSE;
  499.     } else if (!isDigit(c))
  500.         *bp = TRUE;
  501.     return(c);
  502. }
  503.  
  504. static (*casefun)();
  505.  
  506.  
  507. @(defun string_case (strng &key start end &aux conv)
  508.     int s, e, i;
  509.     bool b;
  510. @
  511.     strng = coerce_to_string(strng);
  512.     get_string_start_end(strng, start, end, &s, &e);
  513.     conv = copy_simple_string(strng);
  514.     b = TRUE;
  515.     for (i = s;  i < e;  i++)
  516.         conv->st.st_self[i] =
  517.         (*casefun)(conv->st.st_self[i], &b);
  518.     @(return conv)
  519. @)
  520.  
  521. Lstring_upcase()     { casefun =     char_upcase;  Lstring_case(); }
  522. Lstring_downcase()   { casefun =   char_downcase;  Lstring_case(); }
  523. Lstring_capitalize() { casefun = char_capitalize;  Lstring_case(); }
  524.  
  525.  
  526. @(defun nstring_case (strng &key start end)
  527.     int s, e, i;
  528.     bool b;
  529. @
  530.     check_type_string(&strng);
  531.     get_string_start_end(strng, start, end, &s, &e);
  532.     b = TRUE;
  533.     for (i = s;  i < e;  i++)
  534.         strng->st.st_self[i] =
  535.         (*casefun)(strng->st.st_self[i], &b);
  536.     @(return strng)
  537. @)
  538.  
  539. Lnstring_upcase()     { casefun =     char_upcase;  Lnstring_case(); }
  540. Lnstring_downcase()   { casefun =   char_downcase;  Lnstring_case(); }
  541. Lnstring_capitalize() { casefun = char_capitalize;  Lnstring_case(); }
  542.  
  543.  
  544. @(defun string (x)
  545. @
  546.     @(return `coerce_to_string(x)`)
  547. @)
  548.  
  549. siLstring_concatenate()
  550. {
  551.     int narg, i, l, m;
  552.     object *v;
  553.  
  554.     narg = vs_top - vs_base;
  555.     for (i = 0, l = 0;  i < narg;  i++) {
  556.         vs_base[i] = coerce_to_string(vs_base[i]);
  557.         l += vs_base[i]->st.st_fillp;
  558.     }
  559.     v = vs_top;
  560.     vs_push(alloc_simple_string(l));
  561.     (*v)->st.st_self = alloc_relblock(l);
  562.     for (i = 0, l = 0;  i < narg;  i++)
  563.         for (m = 0;  m < vs_base[i]->st.st_fillp;  m++)
  564.             (*v)->st.st_self[l++]
  565.             = vs_base[i]->st.st_self[m];
  566.     vs_base[0] = *v;
  567.     vs_top = vs_base + 1;
  568. }
  569.  
  570. init_string_function()
  571. {
  572.     Kstart1 = make_keyword("START1");
  573.     Kend1 = make_keyword("END1");
  574.     Kstart2 = make_keyword("START2");
  575.     Kend2 = make_keyword("END2");
  576.     Kinitial_element = make_keyword("INITIAL-ELEMENT");
  577.     Kstart = make_keyword("START");
  578.     Kend = make_keyword("END");
  579.  
  580.     make_function("CHAR", Lchar);
  581.     make_si_function("CHAR-SET", siLchar_set);
  582.     make_function("SCHAR", Lchar);
  583.     make_si_function("SCHAR-SET", siLchar_set);
  584.     make_function("STRING=", Lstring_eq);
  585.     make_function("STRING-EQUAL", Lstring_equal);
  586.     make_function("STRING<", Lstring_l);
  587.     make_function("STRING>", Lstring_g);
  588.     make_function("STRING<=", Lstring_le);
  589.     make_function("STRING>=", Lstring_ge);
  590.     make_function("STRING/=", Lstring_neq);
  591.     make_function("STRING-LESSP", Lstring_lessp);
  592.     make_function("STRING-GREATERP", Lstring_greaterp);
  593.     make_function("STRING-NOT-LESSP", Lstring_not_lessp);
  594.     make_function("STRING-NOT-GREATERP", Lstring_not_greaterp);
  595.     make_function("STRING-NOT-EQUAL", Lstring_not_equal);
  596.     make_function("MAKE-STRING", Lmake_string);
  597.     make_function("STRING-TRIM", Lstring_trim);
  598.     make_function("STRING-LEFT-TRIM", Lstring_left_trim);
  599.     make_function("STRING-RIGHT-TRIM", Lstring_right_trim);
  600.     make_function("STRING-UPCASE", Lstring_upcase);
  601.     make_function("STRING-DOWNCASE", Lstring_downcase);
  602.     make_function("STRING-CAPITALIZE", Lstring_capitalize);
  603.     make_function("NSTRING-UPCASE", Lnstring_upcase);
  604.     make_function("NSTRING-DOWNCASE", Lnstring_downcase);
  605.     make_function("NSTRING-CAPITALIZE", Lnstring_capitalize);
  606.     make_function("STRING", Lstring);
  607.  
  608.     make_si_function("STRING-CONCATENATE",
  609.              siLstring_concatenate);
  610. }
  611.