1: ;;;
    2: ;;; extlib.stub - extra built-ins
    3: ;;;  
    4: ;;;   Copyright (c) 2000-2007  Shiro Kawai  <shiro@acm.org>
    5: ;;;   
    6: ;;;   Redistribution and use in source and binary forms, with or without
    7: ;;;   modification, are permitted provided that the following conditions
    8: ;;;   are met:
    9: ;;;   
   10: ;;;   1. Redistributions of source code must retain the above copyright
   11: ;;;      notice, this list of conditions and the following disclaimer.
   12: ;;;  
   13: ;;;   2. Redistributions in binary form must reproduce the above copyright
   14: ;;;      notice, this list of conditions and the following disclaimer in the
   15: ;;;      documentation and/or other materials provided with the distribution.
   16: ;;;  
   17: ;;;   3. Neither the name of the authors nor the names of its contributors
   18: ;;;      may be used to endorse or promote products derived from this
   19: ;;;      software without specific prior written permission.
   20: ;;;  
   21: ;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22: ;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23: ;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
   24: ;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
   25: ;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
   26: ;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
   27: ;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
   28: ;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
   29: ;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
   30: ;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
   31: ;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
   32: ;;;  
   33: ;;; $Id: extlib.stub,v 1.302 2007/08/28 10:15:43 shirok Exp $
   34: ;;;
   35: 
   36: "
   37: #include <fcntl.h>
   38: #include <gauche/arch.h>
   39: #include <gauche/class.h>
   40: #include <gauche/vminsn.h>
   41: #include <gauche/regexp.h>
   42: #include <gauche/bignum.h>
   43: "
   44: 
   45: ;;
   46: ;; Macros
   47: ;;
   48: 
   49: (define-cproc macroexpand (form)
   50:   (expr <top> (Scm_VMMacroExpand form SCM_NIL FALSE)))
   51: (define-cproc macroexpand-1 (form)
   52:   (expr <top> (Scm_VMMacroExpand form SCM_NIL TRUE)))
   53: 
   54: ;;
   55: ;; 6.1  Equivalence predicates
   56: ;;
   57: 
   58: ;; to pass the cmpmode argument
   59: (define-symbol eq?    "sym_eq")
   60: (define-symbol eqv?   "sym_eqv")
   61: (define-symbol equal? "sym_equal")
   62: 
   63: "static int getcmpmode(ScmObj opt)
   64:  { if (SCM_UNBOUNDP(opt) || opt == sym_equal) return SCM_CMP_EQUAL;
   65:    if (opt == sym_eq) return SCM_CMP_EQ;
   66:    if (opt == sym_eqv) return SCM_CMP_EQV;
   67:    Scm_Error(\"unrecognized compare mode: %S\", opt);
   68:    return 0; /* dummy */ }"
   69: 
   70: (define-cproc compare (x y) (call <fixnum> "Scm_Compare"))
   71: 
   72: ;;
   73: ;; 6.2  Numbers
   74: ;;
   75: 
   76: (define-cproc ash (num cnt::<fixnum>) (call "Scm_Ash"))
   77: 
   78: (define-cproc lognot (x) (call "Scm_LogNot"))
   79: 
   80: (define-cise-stmt logop
   81:   [(_ fn)
   82:    `(let* ((r (,fn x y)))
   83:       (for-each (lambda (v) (set! r (,fn r v))) args)
   84:       (result r))])
   85: 
   86: (define-cproc logand (x y &rest args) (body <top> (logop Scm_LogAnd)))
   87: (define-cproc logior (x y &rest args) (body <top> (logop Scm_LogIor)))
   88: (define-cproc logxor (x y &rest args) (body <top> (logop Scm_LogXor)))
   89: 
   90: (define-cproc logcount (n)
   91:   (body <int>
   92:         (cond
   93:          [(SCM_EQ n (SCM_MAKE_INT 0)) (result 0)]
   94:          [(SCM_INTP n)
   95:           (let* ((z :: ScmBits (cast ScmBits (cast long (SCM_INT_VALUE n)))))
   96:             (if (> (SCM_INT_VALUE n) 0)
   97:               (result (Scm_BitsCount1 (& z) 0 SCM_WORD_BITS))
   98:               (result (Scm_BitsCount0 (& z) 0 SCM_WORD_BITS))))]
   99:          [(SCM_BIGNUMP n)
  100:           (result (Scm_BignumLogCount (SCM_BIGNUM n)))]
  101:          [else
  102:           (SCM_TYPE_ERROR n "exact integer")
  103:           (result 0)])))
  104: 
  105: (define-cproc fixnum? (x) (call <boolean> "SCM_INTP"))
  106: (define-cproc bignum? (x) (call <boolean> "SCM_BIGNUMP"))
  107: (define-cproc flonum? (x) (call <boolean> "SCM_FLONUMP"))
  108: 
  109: ;; As of 0.8.8 we started to support exact rational numbers.  Some existing
  110: ;; code may count on exact integer division to be coerced to flonum
  111: ;; if it isn't produce a whole number, and such programs start
  112: ;; running very slowly on 0.8.8 by introducing unintentional exact
  113: ;; rational arithmetic.
  114: ;;
  115: ;; For the smooth transition, we provide the original behavior as
  116: ;; inexact-/.  If the program uses compat.no-rational, '/' is overridden
  117: ;; by inexact-/ and the old code behaves the same.
  118: (define-cproc inexact-/ (arg1 &rest args)
  119:   (body <top>
  120:         (cond ((SCM_NULLP args)
  121:                (result (Scm_ReciprocalInexact arg1)))
  122:               (else
  123:                (for-each (lambda (x) (set! arg1 (Scm_DivInexact arg1 x))) args)
  124:                (result arg1)))))
  125: 
  126: ;; Inexact arithmetics.  Useful for speed-sensitive code to avoid
  127: ;; accidental use of bignum or ratnum.   We might want to optimize
  128: ;; these more, even adding special VM insns for them.
  129: (define-cproc +. (&rest args)
  130:   (body <top>
  131:         (let* ((a '0.0))
  132:           (for-each (lambda (x) (set! a (Scm_Add a (Scm_ExactToInexact x))))
  133:                     args)
  134:           (result a))))
  135: (define-cproc *. (&rest args)
  136:   (body <top>
  137:         (let* ((a '1.0))
  138:           (for-each (lambda (x) (set! a (Scm_Mul a (Scm_ExactToInexact x))))
  139:                     args)
  140:           (result a))))
  141: (define-cproc -. (arg1 &rest args)
  142:   (body <top>
  143:         (cond
  144:          ((SCM_NULLP args) (result (Scm_Negate (Scm_ExactToInexact arg1))))
  145:          (else (for-each (lambda (x)
  146:                            (set! arg1 (Scm_Sub arg1 (Scm_ExactToInexact x))))
  147:                          args)
  148:                (result arg1)))))
  149: (define-cproc /. (arg1 &rest args)
  150:   (body <top>
  151:         (cond
  152:          ((SCM_NULLP args) (result (Scm_Reciprocal (Scm_ExactToInexact arg1))))
  153:          (else (for-each (lambda (x)
  154:                            (set! arg1 (Scm_Div arg1 (Scm_ExactToInexact x))))
  155:                          args)
  156:                (result arg1)))))
  157: 
  158: (define-cproc clamp (x &optional (min #f) (max #f))
  159:   (body <top>
  160:         (let* ((r x) (maybe_exact :: int (SCM_EXACTP x)))
  161:           (unless (SCM_REALP x) (SCM_TYPE_ERROR x "real number"))
  162:           (cond ((SCM_EXACTP min)
  163:                  (when (< (Scm_NumCmp x min) 0) (set! r min)))
  164:                 ((SCM_FLONUMP min)
  165:                  (set! maybe_exact FALSE)
  166:                  (when (< (Scm_NumCmp x min) 0) (set! r min)))
  167:                 ((not (SCM_FALSEP min))
  168:                  (SCM_TYPE_ERROR min "real number or #f")))
  169:           (cond ((SCM_EXACTP max)
  170:                  (when (> (Scm_NumCmp x max) 0) (set! r max)))
  171:                 ((SCM_FLONUMP max)
  172:                  (set! maybe_exact FALSE)
  173:                  (when (> (Scm_NumCmp x max) 0) (set! r max)))
  174:                 ((not (SCM_FALSEP max))
  175:                  (SCM_TYPE_ERROR max "real number or #f")))
  176:           (if (and (not maybe_exact) (SCM_EXACTP r))
  177:             (return (Scm_ExactToInexact r))
  178:             (return r)))))
  179: 
  180: (define-cproc floor->exact (num)
  181:   (expr <top> (Scm_RoundToExact num SCM_ROUND_FLOOR)))
  182: (define-cproc ceiling->exact (num)
  183:   (expr <top> (Scm_RoundToExact num SCM_ROUND_CEIL)))
  184: (define-cproc truncate->exact (num)
  185:   (expr <top> (Scm_RoundToExact num SCM_ROUND_TRUNC)))
  186: (define-cproc round->exact (num)
  187:   (expr <top> (Scm_RoundToExact num SCM_ROUND_ROUND)))
  188: 
  189: (define-cproc decode-float (num)        ;from ChezScheme
  190:   (body <top>
  191:         (cond ((SCM_FLONUMP num)
  192:                (let* ((exp :: int) (sign :: int)
  193:                       (f (Scm_DecodeFlonum (SCM_FLONUM_VALUE num)
  194:                                            (& exp) (& sign)))
  195:                       (v (Scm_MakeVector 3 '#f)))
  196:                  (set! (SCM_VECTOR_ELEMENT v 0) f
  197:                        (SCM_VECTOR_ELEMENT v 1) (Scm_MakeInteger exp)
  198:                        (SCM_VECTOR_ELEMENT v 2) (Scm_MakeInteger sign))
  199:                  (result v)))
  200:               ((SCM_INTP num)
  201:                (let* ((v (Scm_MakeVector 3 '#f)))
  202:                  (set! (SCM_VECTOR_ELEMENT v 0) (Scm_Abs num)
  203:                        (SCM_VECTOR_ELEMENT v 1) (Scm_MakeInteger 0)
  204:                        (SCM_VECTOR_ELEMENT v 2) (Scm_MakeInteger (Scm_Sign num)))
  205:                  (result v)))
  206:               (else
  207:                (SCM_TYPE_ERROR num "real number")
  208:                (result SCM_UNDEFINED)))))
  209: 
  210: ;; just for debug...
  211: (when "SCM_DEBUG_HELPER"
  212:   (define-cproc %bignum-dump (obj)
  213:     (body <void>
  214:           (when (SCM_BIGNUMP obj)
  215:             (Scm_DumpBignum (SCM_BIGNUM obj) SCM_CUROUT)))))
  216: 
  217: (define-cproc min&max (arg0 &rest args)
  218:   (body (<top> <top>)
  219:         (Scm_MinMax arg0 args (& SCM_RESULT0) (& SCM_RESULT1))))
  220: 
  221: (define-cproc quotient&remainder (n1 n2)
  222:   (body (<top> <top>)
  223:         (set! SCM_RESULT0 (Scm_Quotient n1 n2 (& SCM_RESULT1)))))
  224: 
  225: ;;
  226: ;; 6.3.1  Booleans
  227: ;;
  228: 
  229: ;; a convenient coercer
  230: (define-cproc boolean (obj)
  231:   (call <boolean> "!SCM_FALSEP"))
  232: 
  233: ;;
  234: ;; 6.3.2  Pairs and lists
  235: ;;
  236: 
  237: (define-cproc proper-list? (obj)        ; SRFI-1
  238:   (call <boolean> "SCM_PROPER_LIST_P"))
  239: 
  240: (define-cproc dotted-list? (obj)        ; SRFI-1
  241:   (call <boolean> "SCM_DOTTED_LIST_P"))
  242: 
  243: (define-cproc circular-list? (obj)      ; SRFI-1
  244:   (call <boolean> "SCM_CIRCULAR_LIST_P"))
  245: 
  246: (define-cproc make-list (len::<fixnum> &optional (fill #f)) ; SRFI-1
  247:   (call "Scm_MakeList"))
  248: 
  249: (define-cproc acons (caa cda cd)
  250:   (call "Scm_Acons"))
  251: 
  252: (define-cproc last-pair (list)          ; SRFI-1
  253:   (call "Scm_LastPair"))
  254: 
  255: (define-cproc list-copy (list)          ; SRFI-1
  256:   (call "Scm_CopyList"))
  257: 
  258: (define-cproc list* (&rest args)
  259:   (inliner LIST-STAR)
  260:   (body <top>
  261:         (let* ((head '()) (tail '()))
  262:           (when (SCM_PAIRP args)
  263:             (pair-for-each (lambda (cp)
  264:                              (unless (SCM_PAIRP (SCM_CDR cp))
  265:                                (if (SCM_NULLP head)
  266:                                  (set! head (SCM_CAR cp))
  267:                                  (SCM_SET_CDR tail (SCM_CAR cp)))
  268:                                (break))
  269:                              (SCM_APPEND1 head tail (SCM_CAR cp)))
  270:                            args))
  271:           (result head))))
  272: 
  273: (define-cproc %delete (obj list::<list> &optional cmpmode)
  274:   (expr <top> (Scm_Delete obj list (getcmpmode cmpmode))))
  275: 
  276: (define-cproc %delete! (obj list::<list> &optional cmpmode)
  277:   (expr <top> (Scm_DeleteX obj list (getcmpmode cmpmode))))
  278: 
  279: (define-cproc %delete-duplicates (list::<list> &optional cmpmode)
  280:   (expr <top> (Scm_DeleteDuplicates list (getcmpmode cmpmode))))
  281: 
  282: (define-cproc %delete-duplicates! (list::<list> &optional cmpmode)
  283:   (expr <top> (Scm_DeleteDuplicatesX list (getcmpmode cmpmode))))
  284: 
  285: (define-cproc %alist-delete (elt list::<list> &optional cmpmode)
  286:   (expr <top> (Scm_AssocDelete elt list (getcmpmode cmpmode))))
  287: 
  288: (define-cproc %alist-delete! (elt list::<list> &optional cmpmode)
  289:   (expr <top> (Scm_AssocDeleteX elt list (getcmpmode cmpmode))))
  290: 
  291: (define-cproc append! (&rest list)
  292:   (body <top>
  293:         (let* ((h '()) (t '()))
  294:           (pair-for-each (lambda (cp)
  295:                            ;; allow non-list argument at the last position
  296:                            (when (and (not (SCM_PAIRP (SCM_CAR cp)))
  297:                                       (SCM_NULLP (SCM_CDR cp)))
  298:                              (if (SCM_NULLP h)
  299:                                (set! h (SCM_CAR cp))
  300:                                (SCM_SET_CDR t (SCM_CAR cp)))
  301:                              (break))
  302:                            (SCM_APPEND h t (SCM_CAR cp)))
  303:                          list)
  304:           (result h))))
  305: 
  306: (define-cproc reverse! (list)
  307:   (call "Scm_ReverseX"))
  308: 
  309: ;; Scheme version of 'sort' handles the case when comparison function
  310: ;; is given.
  311: (define-cproc %sort (seq)
  312:   (body <top>
  313:         (cond
  314:          ((SCM_VECTORP seq)
  315:           (let* ((r (Scm_VectorCopy (SCM_VECTOR seq) 0 -1 SCM_UNDEFINED)))
  316:             (Scm_SortArray (SCM_VECTOR_ELEMENTS r) (SCM_VECTOR_SIZE r) '#f)
  317:             (result r)))
  318:          ((>= (Scm_Length seq) 0)
  319:           (result (Scm_SortList seq '#f)))
  320:          (else
  321:           (SCM_TYPE_ERROR seq "proper list or vector")
  322:           (result SCM_UNDEFINED)))))
  323: 
  324: (define-cproc %sort! (seq)
  325:   (body <top>
  326:         (cond
  327:          ((SCM_VECTORP seq)
  328:           (Scm_SortArray (SCM_VECTOR_ELEMENTS seq) (SCM_VECTOR_SIZE seq) '#f)
  329:           (result seq))
  330:          ((>= (Scm_Length seq) 0)
  331:           (result (Scm_SortListX seq '#f)))
  332:          (else
  333:           (SCM_TYPE_ERROR seq "proper list or vector")
  334:           (result SCM_UNDEFINED)))))
  335: 
  336: (define-cproc monotonic-merge (start sequences::<list>)
  337:   (call "Scm_MonotonicMerge"))
  338: 
  339: ;;
  340: ;; 6.3.3  Symbols
  341: ;;
  342: 
  343: (define-cproc gensym (&optional (prefix::<string>? #f))
  344:   (call "Scm_Gensym"))
  345: 
  346: ;; keywords
  347: (define-cproc keyword? (obj) (call <boolean> "SCM_KEYWORDP"))
  348: 
  349: (define-cproc make-keyword (name)
  350:   (body <top>
  351:         (let* ((sname :: ScmString* NULL))
  352:           (cond ((SCM_STRINGP name) (set! sname (SCM_STRING name)))
  353:                 ((SCM_SYMBOLP name) (set! sname (SCM_SYMBOL_NAME name)))
  354:                 (else (SCM_TYPE_ERROR name "string or symbol")))
  355:           (result (Scm_MakeKeyword sname)))))
  356: 
  357: (define-cproc get-keyword (key list &optional fallback)
  358:   (call "Scm_GetKeyword"))
  359: 
  360: (define-cproc delete-keyword (key list)
  361:   (call "Scm_DeleteKeyword"))
  362: 
  363: (define-cproc delete-keyword! (key list)
  364:   (call "Scm_DeleteKeywordX"))
  365: 
  366: (define-cproc keyword->string (key::<keyword>)
  367:   (expr "SCM_OBJ(SCM_KEYWORD_NAME(key))"))
  368: 
  369: ;; identifiers
  370: (define-cproc identifier? (obj)
  371:   (inliner IDENTIFIERP)
  372:   (call <boolean> "SCM_IDENTIFIERP"))
  373: 
  374: (define-cproc identifier->symbol (obj::<identifier>)
  375:   (expr "SCM_OBJ(SCM_IDENTIFIER(obj)->name)"))
  376: 
  377: ;;
  378: ;; 6.3.4  Characters
  379: ;;
  380: 
  381: (define-cproc digit->integer (ch::<char> &optional (radix::<fixnum> 10))
  382:   (body <top>
  383:         (let* ((r :: int))
  384:           (when (or (< radix 2) (> radix 36))
  385:             (Scm_Error "radix must be between 2 and 36, but got %d" radix))
  386:           (set! r (Scm_DigitToInt ch radix))
  387:           (result (?: (>= r 0) (SCM_MAKE_INT r) '#f)))))
  388: 
  389: (define-cproc integer->digit (n::<fixnum> &optional (radix::<fixnum> 10))
  390:   (body <top>
  391:         (let* ((r :: ScmChar))
  392:           (when (or (< radix 2) (> radix 36))
  393:             (Scm_Error "radix must be between 2 and 36, but got %d" radix))
  394:           (set! r (Scm_IntToDigit n radix))
  395:           (result (?: (== r SCM_CHAR_INVALID) '#f (SCM_MAKE_CHAR r))))))
  396: 
  397: (define-cproc ucs->char (n::<int>)
  398:   (body <top>
  399:         (let* ((ch :: ScmChar (Scm_UcsToChar n)))
  400:           (result (?: (== ch SCM_CHAR_INVALID) '#f (SCM_MAKE_CHAR ch))))))
  401: 
  402: (define-cproc char->ucs (c::<char>)
  403:   (body <top>
  404:         (let* ((ucs :: int (Scm_CharToUcs c)))
  405:           (result (?: (< ucs 0) '#f (Scm_MakeInteger ucs))))))
  406: 
  407: (define-cproc gauche-character-encoding ()
  408:   (call "Scm_CharEncodingName"))
  409: 
  410: (define-cproc supported-character-encodings ()
  411:   (expr <top> (Scm_CStringArrayToList (Scm_SupportedCharacterEncodings) -1 0)))
  412: 
  413: (define-cproc supported-character-encoding? (encoding::<const-cstring>)
  414:   (call <boolean> "Scm_SupportedCharacterEncodingP"))
  415: 
  416: ;; character sets (SRFI-14)
  417: ;;   not all of srfi-14 functions are defined in C.  you need to load
  418: ;;   srfi-14.scm to get a full set of functions.
  419: 
  420: (define-constant *char-code-max* (c "Scm_MakeInteger(SCM_CHAR_MAX)"))
  421: 
  422: (define-cproc char-set? (obj) (call <boolean> "SCM_CHARSETP"))
  423: 
  424: "static void char_set_add(ScmCharSet *cs, ScmObj chars)
  425:  {  ScmObj cp; ScmChar ch;
  426:   SCM_FOR_EACH(cp, chars) {
  427:     if (!SCM_CHARP(SCM_CAR(cp)))
  428:       Scm_Error(\"character required, but got %S\", SCM_CAR(cp));
  429:     ch = SCM_CHAR_VALUE(SCM_CAR(cp));
  430:     Scm_CharSetAddRange(cs, ch, ch);
  431:   }
  432:  }"
  433: 
  434: (define-cproc %char-set-equal? (x::<char-set> y::<char-set>)
  435:   (call <boolean> "Scm_CharSetEq"))
  436: 
  437: (define-cproc %char-set<=? (x::<char-set> y::<char-set>)
  438:   (call <boolean> "Scm_CharSetLE"))
  439: 
  440: (define-cproc char-set (&rest chars)
  441:   (body <char-set>
  442:         (let* ((cs :: ScmCharSet* (SCM_CHARSET (Scm_MakeEmptyCharSet))))
  443:           (char_set_add cs chars)
  444:           (result cs))))
  445: 
  446: (define-cproc char-set-copy (cs::<char-set>)
  447:   (call "Scm_CharSetCopy"))
  448: 
  449: (define-cproc read-char-set (port::<input-port>
  450:                              &keyword (error::<boolean> #t)
  451:                                       (posix-bracket::<boolean> #t))
  452:   (expr <top> (Scm_CharSetRead port NULL error posix-bracket)))
  453: 
  454: (define-cproc %char-set-add-chars! (cs::<char-set> chars::<list>)
  455:   (body <char-set>
  456:         (char_set_add cs chars)
  457:         (result cs)))
  458: 
  459: (define-cproc %char-set-add-range! (cs::<char-set> from to)
  460:   (body <top>
  461:         (let* ((f :: long -1) (t :: long -1))
  462:           (cond ((SCM_INTP from) (set! f (SCM_INT_VALUE from)))
  463:                 ((SCM_CHARP from) (set! f (SCM_CHAR_VALUE from))))
  464:           (when (< f 0)
  465:             (SCM_TYPE_ERROR from "character or positive exact integer"))
  466:           (when (> f SCM_CHAR_MAX)
  467:             (Scm_Error "'from' argument out of range: %S" from))
  468:           (cond ((SCM_INTP to) (set! t (SCM_INT_VALUE to)))
  469:                 ((SCM_CHARP to) (set! t (SCM_CHAR_VALUE to))))
  470:           (when (< t 0)
  471:             (SCM_TYPE_ERROR to "character or positive exact integer"))
  472:           (when (> t SCM_CHAR_MAX)
  473:             (Scm_Error "'to' argument out of range: %S" to))
  474:           (result (Scm_CharSetAddRange cs (cast ScmChar f) (cast ScmChar t)))))
  475:   )
  476:           
  477: (define-cproc %char-set-add! (dst::<char-set> src::<char-set>)
  478:   (call "Scm_CharSetAdd"))
  479: 
  480: (define-cproc char-set-contains? (cs::<char-set> ch::<char>)
  481:   (call <boolean> "Scm_CharSetContains"))
  482: 
  483: (define-cproc %char-set-complement! (cs::<char-set>)
  484:   (call "Scm_CharSetComplement"))
  485: 
  486: (define-cproc %char-set-ranges (cs::<char-set>)
  487:   (call "Scm_CharSetRanges"))
  488: 
  489: (define-cproc %char-set-predefined (num::<fixnum>)
  490:   (call "Scm_GetStandardCharSet"))
  491: 
  492: ;; for debug
  493: (when "SCM_DEBUG_HELPER"
  494:   (define-cproc %char-set-dump (cs::<char-set>)
  495:     (body <void> (Scm_CharSetDump cs SCM_CUROUT)))
  496:   )
  497: 
  498: ;;
  499: ;; 6.3.5 Strings
  500: ;;
  501: 
  502: (define-cproc string-incomplete? (obj)    ;gauche specific
  503:   (expr <boolean> "SCM_STRINGP(obj)&&SCM_STRING_INCOMPLETE_P(obj)"))
  504: (define-cproc string-immutable? (obj)   ;gauche specific
  505:   (expr <boolean> "SCM_STRINGP(obj)&&SCM_STRING_IMMUTABLE_P(obj)"))
  506: 
  507: ;; DEPRECATED, only kept for backward compatibility.
  508: ;; We allocate a new string and swap the body, in order to avoid MT-hazard.
  509: ;; (So it is _not_ allocation-free, and we no longer have reason to keep
  510: ;; this procedure.)
  511: (define-cproc string-incomplete->complete! (str::<string>)
  512:   (body <top>
  513:         (let* ((s (Scm_StringIncompleteToComplete str SCM_ILLEGAL_CHAR_REJECT
  514:                                                   (SCM_CHAR 0))))
  515:           (unless (SCM_FALSEP s) (set! (-> str body) (SCM_STRING_BODY s)))
  516:           (result s))))
  517: ;         "ScmObj s = Scm_StringIncompleteToComplete(str, SCM_ILLEGAL_CHAR_REJECT, SCM_CHAR(0));"
  518: ;         "if (!SCM_FALSEP(s)) str->body = SCM_STRING_BODY(s);"
  519: ;         "SCM_RESULT = s;"))
  520: 
  521: (define-cproc string-complete->incomplete (str::<string>)
  522:   (call "Scm_StringCompleteToIncomplete"))
  523: 
  524: (define-cproc string-incomplete->complete (str::<string>
  525:                                            &optional (handling #f))
  526:   (body <top>
  527:         (let* ((h :: int 0)
  528:                (sub :: ScmChar (SCM_CHAR 0)))
  529:           (cond ((SCM_EQ handling ':omit) (set! h SCM_ILLEGAL_CHAR_OMIT))
  530:                 ((SCM_FALSEP handling)    (set! h SCM_ILLEGAL_CHAR_REJECT))
  531:                 ((SCM_CHARP handling)     (set! h SCM_ILLEGAL_CHAR_REPLACE)
  532:                                           (set! sub (SCM_CHAR_VALUE handling)))
  533:                 (else
  534:                  (SCM_TYPE_ERROR handling ":omit, #f, or a character")))
  535:           (result (Scm_StringIncompleteToComplete str h sub)))))
  536: 
  537: (define-cproc string-size (str::<string>)
  538:   (expr <fixnum> (SCM_STRING_BODY_SIZE (SCM_STRING_BODY str))))
  539: 
  540: (define-cproc make-byte-string (size::<fixnum> &optional (byte::<fixnum> 0))
  541:   (body <top>
  542:         (let* ((s :: char*))
  543:           (when (< size 0) (Scm_Error "size out of bound: %d" size))
  544:           (set! s (SCM_NEW_ATOMIC2 (C: char*) size))
  545:           (memset s byte size)
  546:           (result (Scm_MakeString s size size SCM_STRING_INCOMPLETE)))))
  547: 
  548: (define-cproc string-byte-ref (str::<string> k::<fixnum> &optional fallback)
  549:   (body <top>
  550:         (let* ((r :: int (Scm_StringByteRef str k (SCM_UNBOUNDP fallback))))
  551:           (result (?: (< r 0) fallback (SCM_MAKE_INT r))))))
  552: 
  553: (define-cproc byte-substring (str::<string> start::<fixnum> end::<fixnum>)
  554:   (expr <top> (Scm_Substring str start end TRUE)))
  555: 
  556: (define-cproc %string-replace-body! (target::<string> source::<string>)
  557:   (expr <top> (Scm_StringReplaceBody target (SCM_STRING_BODY source))))
  558: 
  559: (define-cproc %maybe-substring (str::<string> &optional start end)
  560:   (call "Scm_MaybeSubstring"))
  561: 
  562: (define-cproc string-join (strs::<list>
  563:                            &optional (delim::<string> " ") (grammer infix))
  564:   (body
  565:    <top>
  566:    (let* ((gm :: int 0))
  567:      (cond
  568:       ((SCM_EQ grammer 'infix) (set! gm SCM_STRING_JOIN_INFIX))
  569:       ((SCM_EQ grammer 'strict-infix) (set! gm SCM_STRING_JOIN_STRICT_INFIX))
  570:       ((SCM_EQ grammer 'suffix) (set! gm SCM_STRING_JOIN_SUFFIX))
  571:       ((SCM_EQ grammer 'prefix) (set! gm SCM_STRING_JOIN_PREFIX))
  572:       (else (SCM_TYPE_ERROR grammer "one of the symbols infix, strict-infix, suffix, or prefix")))
  573:      (result (Scm_StringJoin strs delim gm)))))
  574: 
  575: (define-cproc %hash-string (str::<string> bound) ; for SRFI-13
  576:   (body <ulong>
  577:         (let* ((modulo :: u_long 0))
  578:           (cond ((SCM_UNDEFINEDP bound) (set! modulo SCM_SMALL_INT_MAX))
  579:                 ((SCM_INTP bound) (set! modulo (SCM_INT_VALUE bound)))
  580:                 ((SCM_BIGNUMP bound)
  581:                  (set! modulo (Scm_BignumToUI (SCM_BIGNUM bound) SCM_CLAMP_BOTH
  582:                                               NULL))))
  583:           (when (== modulo 0) (Scm_Error "argument out of domain: %S" bound))
  584:           (result (Scm_HashString str modulo)))))
  585: 
  586: ;; see lib/gauche/string for generic string-split
  587: (define-cproc %string-split-by-char (s::<string> ch::<char>)
  588:   (call "Scm_StringSplitByChar"))
  589: 
  590: ;; primitive scanner
  591: (define-cproc string-scan (s1::<string> s2 &optional (mode index))
  592:   (body <top>
  593:         (let* ((rmode :: int 0))
  594:           (cond
  595:            ((SCM_EQ mode 'index)   (set! rmode SCM_STRING_SCAN_INDEX))
  596:            ((SCM_EQ mode 'before)  (set! rmode SCM_STRING_SCAN_BEFORE))
  597:            ((SCM_EQ mode 'after)   (set! rmode SCM_STRING_SCAN_AFTER))
  598:            ((SCM_EQ mode 'before*) (set! rmode SCM_STRING_SCAN_BEFORE2))
  599:            ((SCM_EQ mode 'after*)  (set! rmode SCM_STRING_SCAN_AFTER2))
  600:            ((SCM_EQ mode 'both)    (set! rmode SCM_STRING_SCAN_BOTH))
  601:            (else (Scm_Error "bad value in mode argumet: %S, must be one of 'index, 'before, 'after, 'before*, 'after* or 'both." mode)))
  602:           (cond
  603:            ((SCM_STRINGP s2)
  604:             (result (Scm_StringScan s1 (SCM_STRING s2) rmode)))
  605:            ((SCM_CHARP s2)
  606:             (result (Scm_StringScanChar s1 (SCM_CHAR_VALUE s2) rmode)))
  607:            (else
  608:             (Scm_Error "bad type of argument for s2: %S, must be either string or character" s2)
  609:             (result SCM_UNDEFINED))))))
  610:                                        
  611: ;; string pointer
  612: (define-type <string-pointer> "ScmStringPointer*" "string pointer"
  613:   "SCM_STRING_POINTERP" "SCM_STRING_POINTER")
  614: 
  615: (define-cproc make-string-pointer (str::<string>
  616:                                    &optional (index::<fixnum> 0)
  617:                                              (start::<fixnum> 0)
  618:                                              (end::<fixnum> -1))
  619:   (call "Scm_MakeStringPointer"))
  620: (define-cproc string-pointer? (obj)
  621:   (call <boolean> "SCM_STRING_POINTERP"))
  622: 
  623: (define-cproc string-pointer-ref (sp::<string-pointer>)
  624:   (call "Scm_StringPointerRef"))
  625: (define-cproc string-pointer-next! (sp::<string-pointer>)
  626:   (call "Scm_StringPointerNext"))
  627: (define-cproc string-pointer-prev! (sp::<string-pointer>)
  628:   (call "Scm_StringPointerPrev"))
  629: (define-cproc string-pointer-set! (sp::<string-pointer> index::<fixnum>)
  630:   (call "Scm_StringPointerSet"))
  631: (define-cproc string-pointer-substring (sp::<string-pointer>
  632:                                         &keyword (after #f))
  633:   (expr <top> (Scm_StringPointerSubstring sp (not (SCM_FALSEP after)))))
  634: (define-cproc string-pointer-index (sp::<string-pointer>)
  635:   (expr <int> (-> sp index)))
  636: (define-cproc string-pointer-copy (sp::<string-pointer>)
  637:   (call "Scm_StringPointerCopy"))
  638: (define-cproc string-pointer-byte-index (sp::<string-pointer>)
  639:   (expr <int> (cast int (- (-> sp current) (-> sp start)))))
  640: 
  641: (if "SCM_DEBUG_HELPER"
  642:     (define-cproc %string-pointer-dump (sp::<string-pointer>)
  643:       (call <void> "Scm_StringPointerDump"))
  644:     )
  645: 
  646: ;; Regexp
  647: (define-cproc regexp? (obj)    (call <boolean> "SCM_REGEXPP"))
  648: (define-cproc regmatch? (obj)  (call <boolean> "SCM_REGMATCHP"))
  649: 
  650: (define-cproc string->regexp (str::<string> &keyword (case-fold #f))
  651:   (body <top>
  652:         (let* ((flags :: int
  653:                       (?: (SCM_BOOL_VALUE case-fold) SCM_REGEXP_CASE_FOLD 0)))
  654:           (result (Scm_RegComp str flags)))))
  655: (define-cproc regexp->string (regexp::<regexp>)
  656:   (expr <top> (?: (-> regexp pattern) (SCM_OBJ (-> regexp pattern)) '#f)))
  657: (define-cproc regexp-case-fold? (regexp::<regexp>)
  658:   (expr <boolean> (logand (-> regexp flags) SCM_REGEXP_CASE_FOLD)))
  659: 
  660: (define-cproc regexp-parse (str::<string> &keyword (case-fold #f))
  661:   (body <top>
  662:         (let* ((flags :: int
  663:                       (?: (SCM_BOOL_VALUE case-fold) SCM_REGEXP_CASE_FOLD 0)))
  664:           (result (Scm_RegComp str (logior flags SCM_REGEXP_PARSE_ONLY))))))
  665: (define-cproc regexp-compile (ast)
  666:   (call "Scm_RegCompFromAST"))
  667: (define-cproc regexp-optimize (ast)
  668:   (call "Scm_RegOptimizeAST"))
  669: 
  670: (define-cproc rxmatch (regexp str::<string>)
  671:   (body <top>
  672:         (let* ((rx :: ScmRegexp* NULL))
  673:           (cond ((SCM_STRINGP regexp)
  674:                  (set! rx (SCM_REGEXP (Scm_RegComp (SCM_STRING regexp) 0))))
  675:                 ((SCM_REGEXPP regexp)
  676:                  (set! rx (SCM_REGEXP regexp)))
  677:                 (else (SCM_TYPE_ERROR regexp "regexp")))
  678:           (result (Scm_RegExec rx str)))))
  679: 
  680: (define-cise-stmt rxmatchop
  681:   [(_ (exp ...)) (template exp)]
  682:   [(_ fn)        (template `(,fn (SCM_REGMATCH match) obj))]
  683:   :where
  684:   (define (template result)
  685:     `(cond ((SCM_FALSEP match) (result '#f))
  686:            ((SCM_REGMATCHP match) (result ,result))
  687:            (else (SCM_TYPE_ERROR match "regmatch object or #f")
  688:                  (result SCM_UNDEFINED)))))
  689: 
  690: (define-cproc rxmatch-substring (match &optional (obj 0)) 
  691:   (body <top> (rxmatchop Scm_RegMatchSubstr)))
  692: (define-cproc rxmatch-start (match &optional (obj 0))
  693:   (body <top> (rxmatchop Scm_RegMatchStart)))
  694: (define-cproc rxmatch-end (match &optional (obj 0))
  695:   (body <top> (rxmatchop Scm_RegMatchEnd)))
  696: (define-cproc rxmatch-before (match &optional (obj 0))
  697:   (body <top> (rxmatchop Scm_RegMatchBefore)))
  698: (define-cproc rxmatch-after (match &optional (obj 0))
  699:   (body <top> (rxmatchop Scm_RegMatchAfter)))
  700: (define-cproc rxmatch-num-matches (match)
  701:   (body <top> (rxmatchop (SCM_MAKE_INT (-> (SCM_REGMATCH match) numMatches)))))
  702: 
  703: ;; for debug
  704: (when "SCM_DEBUG_HELPER"
  705:   (define-cproc %regexp-dump (rx::<regexp>)
  706:     (call <void> "Scm_RegDump"))
  707:   (define-cproc %regmatch-dump (rm::<regmatch>)
  708:     (call <void> "Scm_RegMatchDump"))
  709:   )
  710: 
  711: ;;
  712: ;; 6.3.6  Vectors
  713: ;;
  714: 
  715: (define-cproc vector-copy (v::<vector>
  716:                            &optional
  717:                            (start::<fixnum> 0) (end::<fixnum> -1) fill)
  718:   (call "Scm_VectorCopy"))
  719: 
  720: ;; weak vector
  721: (define-cproc make-weak-vector (size::<fixnum>)
  722:   (call "Scm_MakeWeakVector"))
  723: 
  724: (define-cproc weak-vector-length (wv::<weak-vector>)
  725:   (expr <int> "wv->size"))
  726: 
  727: (define-cproc weak-vector-ref (wv::<weak-vector> index::<fixnum>
  728:                                &optional fallback)
  729:   (call "Scm_WeakVectorRef"))
  730:   
  731: (define-cproc weak-vector-set! (wv::<weak-vector> index::<fixnum> val)
  732:   (call "Scm_WeakVectorSet"))
  733: 
  734: ;;
  735: ;; 6.4  Control Features
  736: ;;
  737: 
  738: (define-cproc setter (proc) ;SRFI-17
  739:   (inliner SETTER)
  740:   (call "Scm_Setter")
  741:   (setter (proc::<procedure> setter::<procedure>)
  742:           (body <void> (Scm_SetterSet proc setter FALSE))))
  743: 
  744: (define-cproc has-setter? (proc)
  745:   (call <boolean> "Scm_HasSetter"))
  746: 
  747: (define-cproc identity (val)            ;sometimes useful
  748:   (expr "val"))