1: ;;;
    2: ;;; stdlib.stub - r5rs scheme procedures
    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: stdlib.stub,v 1.132 2007/08/16 11:29:50 shirok Exp $
   34: ;;;
   35: 
   36: "
   37: #include <gauche/vminsn.h>
   38: #include <stdlib.h>
   39: #include <ctype.h>
   40: #include <math.h>
   41: 
   42: #ifndef M_PI
   43: #define M_PI 3.1415926535897932384
   44: #endif
   45: "
   46: 
   47: ;;
   48: ;; 6.1  Equivalence predicates
   49: ;;
   50: 
   51: (define-cproc eqv? (obj1 obj2)
   52:   (inliner EQV)
   53:   (call <boolean> "Scm_EqvP"))
   54: 
   55: (define-cproc eq? (obj1 obj2)
   56:   (inliner EQ)
   57:   (call <boolean> "SCM_EQ"))
   58: 
   59: (define-cproc equal? (obj1 obj2)
   60:   (call <boolean> "Scm_EqualP"))
   61: 
   62: ;;
   63: ;; 6.2  Numbers
   64: ;;
   65: 
   66: (define-cproc number? (obj)   (call <boolean> "SCM_NUMBERP"))
   67: (define-cproc complex? (obj)  (call <boolean> "SCM_NUMBERP"))
   68: (define-cproc real? (obj)     (call <boolean> "SCM_REALP"))
   69: (define-cproc rational? (obj) (call <boolean> "SCM_REALP"))
   70: (define-cproc integer? (obj)
   71:   (expr <boolean> (and (SCM_NUMBERP obj) (Scm_IntegerP obj))))
   72: 
   73: (define-cproc exact? (obj)    (call <boolean> "SCM_EXACTP"))
   74: (define-cproc inexact? (obj)  (call <boolean> "SCM_INEXACTP"))
   75: 
   76: (define-cproc = (arg0 arg1 &rest args)
   77:   (body <boolean>
   78:         (loop (cond 
   79:                ((not (Scm_NumEq arg0 arg1)) (result FALSE) (break))
   80:                ((SCM_NULLP args) (result TRUE) (break))
   81:                (else (set! arg1 (SCM_CAR args)
   82:                            args (SCM_CDR args)))))))
   83: 
   84: (define-cise-stmt numcmp
   85:   [(_ op)
   86:    `(loop (cond
   87:            ((not (,op (Scm_NumCmp arg0 arg1) 0)) (result FALSE) (break))
   88:            ((SCM_NULLP args) (result TRUE) (break))
   89:            (else (set! arg0 arg1
   90:                        arg1 (SCM_CAR args)
   91:                        args (SCM_CDR args)))))])
   92: 
   93: (define-cproc < (arg0 arg1 &rest args)  (body <boolean> (numcmp <)))
   94: (define-cproc <= (arg0 arg1 &rest args) (body <boolean> (numcmp <=)))
   95: (define-cproc > (arg0 arg1 &rest args)  (body <boolean> (numcmp >)))
   96: (define-cproc >= (arg0 arg1 &rest args) (body <boolean> (numcmp >=)))
   97: 
   98: (define-cproc zero? (obj::<number>)
   99:   (expr <boolean> (and (SCM_REALP obj) (== (Scm_Sign obj) 0))))
  100: 
  101: (define-cproc positive? (obj) (expr <boolean> (> (Scm_Sign obj) 0)))
  102: (define-cproc negative? (obj) (expr <boolean> (< (Scm_Sign obj) 0)))
  103: (define-cproc odd? (obj)      (call <boolean> "Scm_OddP"))
  104: (define-cproc even? (obj)     (call <boolean> "!Scm_OddP"))
  105: 
  106: (define-cproc max (arg0 &rest args)
  107:   (body <number> (Scm_MinMax arg0 args NULL (& SCM_RESULT))))
  108: (define-cproc min (arg0 &rest args)
  109:   (body <number> (Scm_MinMax arg0 args (& SCM_RESULT) NULL)))
  110: 
  111: (define-cproc + (&rest args)
  112:   (body <number>
  113:         (cond
  114:          ((not (SCM_PAIRP args)) (result (SCM_MAKE_INT 0)))
  115:          ((not (SCM_NUMBERP (SCM_CAR args)))
  116:           (Scm_Error "number required, but got %S" (SCM_CAR args))
  117:           (result SCM_UNDEFINED))       ;dummy
  118:          (else
  119:           (let* ((r :: ScmObj (SCM_CAR args)))
  120:             (for-each (lambda (v) (set! r (Scm_Add r v))) (SCM_CDR args))
  121:             (result r))))))
  122: 
  123: (define-cproc * (&rest args)
  124:   (body <number>
  125:         (cond
  126:          ((not (SCM_PAIRP args)) (result (SCM_MAKE_INT 1)))
  127:          ((not (SCM_NUMBERP (SCM_CAR args)))
  128:           (Scm_Error "number required, but got %S" (SCM_CAR args))
  129:           (result SCM_UNDEFINED))       ;dummy
  130:          (else
  131:           (let* ((r :: ScmObj (SCM_CAR args)))
  132:             (for-each (lambda (v) (set! r (Scm_Mul r v))) (SCM_CDR args))
  133:             (result r))))))
  134: 
  135: (define-cproc - (arg1 &rest args)
  136:   (body <number>
  137:         (if (SCM_NULLP args)
  138:           (result (Scm_Negate arg1))
  139:           (begin
  140:             (for-each (lambda (v) (set! arg1 (Scm_Sub arg1 v))) args)
  141:             (result arg1)))))
  142: 
  143: (define-cproc / (arg1 &rest args)
  144:   (body <number>
  145:         (if (SCM_NULLP args)
  146:           (result (Scm_Reciprocal arg1))
  147:           (begin
  148:             (for-each (lambda (v) (set! arg1 (Scm_Div arg1 v))) args)
  149:             (result arg1)))))
  150: 
  151: (define-cproc abs (obj) (call "Scm_Abs"))
  152: 
  153: (define-cproc quotient (n1 n2)  (expr "Scm_Quotient(n1, n2, NULL)"))
  154: (define-cproc remainder (n1 n2) (expr "Scm_Modulo(n1, n2, TRUE)"))
  155: (define-cproc modulo (n1 n2)    (expr "Scm_Modulo(n1, n2, FALSE)"))
  156: 
  157: (define-cproc %gcd (n1 n2)    (call "Scm_Gcd"))
  158: (define-cproc numerator (n)   (call "Scm_Numerator"))
  159: (define-cproc denominator (n) (call "Scm_Denominator"))
  160: ;; gcd, lcd - in gauche/numerical.scm
  161: 
  162: (define-cproc floor (v)    (expr <number> (Scm_Round v SCM_ROUND_FLOOR)))
  163: (define-cproc ceiling (v)  (expr <number> (Scm_Round v SCM_ROUND_CEIL)))
  164: (define-cproc truncate (v) (expr <number> (Scm_Round v SCM_ROUND_TRUNC)))
  165: (define-cproc round (v)    (expr <number> (Scm_Round v SCM_ROUND_ROUND)))
  166: 
  167: ;; rationalize - not implemented
  168: 
  169: 
  170: ;; Transcedental functions.  Complex numbers are handled in Scheme.
  171: 
  172: (define-cproc %exp (x::<real>) (call <real> "exp"))
  173: 
  174: (define-cproc %log (x)
  175:   (body <number>
  176:         (unless (SCM_REALP x)
  177:           (Scm_Error "real number required, but got %S" x))
  178:         (if (< (Scm_Sign x) 0)
  179:           (result (Scm_MakeComplex (log (- (Scm_GetDouble x))) M_PI))
  180:           ;; NB: I intentionally delegate handling of the case x==0.0 to the
  181:           ;; system log() function.  Most systems should yield NaN or Inf.
  182:           (result (Scm_MakeFlonum (log (Scm_GetDouble x)))))))
  183: 
  184: (define-cproc %sin (x::<real>) (call <real> "sin"))
  185: (define-cproc %cos (x::<real>) (call <real> "cos"))
  186: (define-cproc %tan (x::<real>) (call <real> "tan"))
  187: (define-cproc %asin (x::<real>)
  188:   (body <number>
  189:         (cond
  190:          ((> x 1.0)
  191:           (result (Scm_MakeComplex (/ M_PI 2.0)
  192:                                    (- (log (+ x (sqrt (- (* x x) 1.0))))))))
  193:          ((< x -1.0)
  194:           (result (Scm_MakeComplex (/ (- M_PI) 2.0)
  195:                                    (- (log (- (- x) (sqrt (- (* x x) 1.0))))))))
  196:          (else
  197:           (result (Scm_MakeFlonum (asin x)))))))
  198: (define-cproc %acos (x::<real>)
  199:   (body <number>
  200:         (cond
  201:          ((> x 1.0)
  202:           (result (Scm_MakeComplex 0 (log (+ x (sqrt (- (* x x) 1.0)))))))
  203:          ((< x -1.0)
  204:           (result (Scm_MakeComplex 0 (log (+ x (sqrt (- (* x x) 1.0)))))))
  205:          (else
  206:           (result (Scm_MakeFlonum (acos x)))))))
  207: 
  208: (define-cproc %atan (z::<real> &optional x)
  209:   (body <double>
  210:         (if (SCM_UNBOUNDP x)
  211:           (result (atan z))
  212:           (begin
  213:             (unless (SCM_REALP x)
  214:               (Scm_Error "real number required for x, but got %S" x))
  215:             (result (atan2 z (Scm_GetDouble x)))))))
  216: 
  217: (define-cproc %sinh (x::<real>) (call <real> "sinh"))
  218: (define-cproc %cosh (x::<real>) (call <real> "cosh"))
  219: (define-cproc %tanh (x::<real>) (call <real> "tanh"))
  220: ;; NB: asinh and acosh are not in POSIX.
  221: 
  222: (define-cproc %sqrt (x::<real>)
  223:   (body <top>
  224:         (if (< x 0)
  225:           (result (Scm_MakeComplex 0.0 (sqrt (- x))))
  226:           (result (Scm_MakeFlonum (sqrt x))))))
  227: 
  228: (define-cproc %expt (x y) (call "Scm_Expt"))
  229: 
  230: (define-cproc make-rectangular (a::<real> b::<real>)
  231:   (call "Scm_MakeComplex"))
  232: 
  233: (define-cproc make-polar (r::<real> t::<real>)
  234:   (call "Scm_MakeComplexPolar"))
  235: 
  236: (define-cproc %complex->real/imag (z)
  237:   "if (SCM_EXACTP(z)) { SCM_RETURN(Scm_Values2(z, SCM_MAKE_INT(0))); }
  238:   else if (SCM_FLONUMP(z)) { SCM_RETURN(Scm_Values2(z, Scm_MakeFlonum(0.0))); }
  239:   else if (!SCM_COMPNUMP(z)) {
  240:     Scm_Error(\"number required, but got %S\", z);
  241:     SCM_RETURN(SCM_UNDEFINED);
  242:   } else { SCM_RETURN(Scm_Values2(Scm_MakeFlonum(SCM_COMPNUM_REAL(z)), Scm_MakeFlonum(SCM_COMPNUM_IMAG(z))));}")
  243: 
  244: ;; we don't use Scm_RealPart and Scm_ImagPart, for preserving exactness
  245: ;; and avoiding extra allocation.
  246: (define-cproc real-part (z::<number>)
  247:   (body <top>
  248:         (if (SCM_REALP z)
  249:           (result z)
  250:           (result (Scm_MakeFlonum (SCM_COMPNUM_REAL z))))))
  251: 
  252: (define-cproc imag-part (z::<number>)
  253:   (body <top>
  254:         (cond
  255:          ((SCM_EXACTP z) (result (SCM_MAKE_INT 0)))
  256:          ((SCM_REALP z)  (result (Scm_MakeFlonum 0.0)))
  257:          (else (result (Scm_MakeFlonum (SCM_COMPNUM_IMAG z)))))))
  258: 
  259: (define-cproc magnitude (z)  (call <double> "Scm_Magnitude"))
  260: (define-cproc angle (z)      (call <double> "Scm_Angle"))
  261: 
  262: (define-cproc exact->inexact (obj) (call "Scm_ExactToInexact"))
  263: (define-cproc inexact->exact (obj) (call "Scm_InexactToExact"))
  264: 
  265: (define-cproc number->string (obj
  266:                               &optional (radix::<fixnum> 10) (use-upper? #f))
  267:   (expr <top> (Scm_NumberToString obj radix (not (SCM_FALSEP use_upperP)))))
  268: 
  269: (define-cproc string->number (obj::<string> &optional (radix::<fixnum> 10))
  270:   (expr <top> (Scm_StringToNumber obj radix FALSE)))
  271: 
  272: ;;
  273: ;; 6.3.1  Booleans
  274: ;;
  275: 
  276: (define-cproc not (obj)
  277:   (inliner NOT)
  278:   (call <boolean> "SCM_FALSEP"))
  279: 
  280: (define-cproc boolean? (obj)
  281:   (call <boolean> "SCM_BOOLP"))
  282: 
  283: ;;
  284: ;; 6.3.2  Pairs and lists
  285: ;;
  286: 
  287: (define-cproc pair? (obj)
  288:   (inliner PAIRP)
  289:   (call <boolean> "SCM_PAIRP"))
  290: 
  291: (define-cproc cons (obj1 obj2)
  292:   (inliner CONS)
  293:   (call "Scm_Cons"))
  294: 
  295: (define-cproc car (obj::<pair>)
  296:   (inliner CAR)
  297:   (call "SCM_CAR")
  298:   (setter set-car!))
  299: 
  300: (define-cproc cdr (obj::<pair>)
  301:   (inliner CDR)
  302:   (call "SCM_CDR")
  303:   (setter set-cdr!))
  304: 
  305: (define-cproc set-car! (obj::<pair> value)
  306:   (call <void> "SCM_SET_CAR"))
  307: 
  308: (define-cproc set-cdr! (obj::<pair> value)
  309:   (call <void> "SCM_SET_CDR"))
  310: 
  311: "#define CXR_SETTER(PRE, pre, tail) \\
  312:   ScmObj cell = Scm_C##tail##r(obj); \\
  313:   if (!SCM_PAIRP(cell)) Scm_Error(\"can't set c\" #pre #tail \"r of %S\", obj); \\
  314:   SCM_SET_C##PRE##R(cell, value); SCM_RETURN(SCM_UNDEFINED);
  315: "
  316: 
  317: (define-cproc caar (obj)
  318:   (inliner CAAR)
  319:   (call "Scm_Caar")
  320:   (setter (obj value) "CXR_SETTER(A, a, a);"))
  321: (define-cproc cadr (obj)
  322:   (inliner CADR)
  323:   (call "Scm_Cadr")
  324:   (setter (obj value) "CXR_SETTER(A, a, d);"))
  325: (define-cproc cdar (obj)
  326:   (inliner CDAR)
  327:   (call "Scm_Cdar")
  328:   (setter (obj value) "CXR_SETTER(D, d, a);"))
  329: (define-cproc cddr (obj)
  330:   (inliner CDDR)
  331:   (call "Scm_Cddr")
  332:   (setter (obj value) "CXR_SETTER(D, d, d);"))
  333: ;; NB: caaar ... cddddr are in autoloaded Scheme file now.
  334: 
  335: (define-cproc null? (obj)
  336:   (inliner NULLP)
  337:   (call <boolean> "SCM_NULLP"))
  338: 
  339: (define-cproc list? (obj)
  340:   (call <boolean> "SCM_PROPER_LIST_P"))
  341: 
  342: (define-cproc list (&rest args)
  343:   (inliner LIST)
  344:   (expr "args"))
  345: 
  346: (define-cproc length (list)
  347:   (inliner LENGTH)
  348:   (body <long>
  349:         (let* ((len :: long (Scm_Length list)))
  350:           (if (< len 0) (Scm_Error "bad list: %S" list))
  351:           (result len))))
  352: 
  353: (define-cproc length+ (list) ;; srfi-1
  354:   (body <top>
  355:         (let* ((i :: int (Scm_Length list)))
  356:           (if (< i 0) (result SCM_FALSE) (result (Scm_MakeInteger i))))))
  357: 
  358: (define-cproc append (&rest lists)
  359:   (inliner APPEND)
  360:   (call "Scm_Append"))
  361: 
  362: (define-cproc reverse (list::<list>)
  363:   (inliner REVERSE)
  364:   (call "Scm_Reverse"))
  365: 
  366: (define-cproc list-tail (list k::<fixnum> &optional fallback)
  367:   (call "Scm_ListTail"))
  368: 
  369: (define-cproc list-ref (list k::<fixnum> &optional fallback)
  370:   (call "Scm_ListRef"))
  371: 
  372: (define-cproc memq (obj list::<list>)
  373:   (inliner MEMQ)
  374:   (call "Scm_Memq"))
  375: 
  376: (define-cproc memv (obj list::<list>)
  377:   (inliner MEMV)
  378:   (call "Scm_Memv"))
  379: 
  380: (define-cproc member (obj list::<list>)
  381:   (expr <top> (Scm_Member obj list SCM_CMP_EQUAL)))
  382: 
  383: (define-cproc assq (obj alist::<list>)
  384:   (inliner ASSQ)
  385:   (call "Scm_Assq"))
  386: 
  387: (define-cproc assv (obj alist::<list>)
  388:   (inliner ASSV)
  389:   (call "Scm_Assv"))
  390: 
  391: (define-cproc assoc (obj alist::<list>)
  392:   (expr <top> (Scm_Assoc obj alist SCM_CMP_EQUAL)))
  393: 
  394: ;;
  395: ;; 6.3.3  Symbols
  396: ;;
  397: 
  398: (define-cproc symbol? (obj)
  399:   (inliner SYMBOLP)
  400:   (call <boolean> "SCM_SYMBOLP"))
  401: 
  402: (define-cproc symbol->string (obj::<symbol>)
  403:   (expr <top> (SCM_OBJ (SCM_SYMBOL_NAME obj))))
  404: 
  405: (define-cproc string->symbol (obj::<string>)
  406:   (call "Scm_Intern"))
  407: 
  408: ;;
  409: ;; 6.3.4  Characters
  410: ;;
  411: 
  412: (define-cproc char? (obj)
  413:   (inliner CHARP)
  414:   (call <boolean> "SCM_CHARP"))
  415: 
  416: (define-cproc char=? (c1::<char> c2::<char>)  (expr <boolean> "c1 == c2"))
  417: (define-cproc char<? (c1::<char> c2::<char>)  (expr <boolean> "c1 < c2"))
  418: (define-cproc char>? (c1::<char> c2::<char>)  (expr <boolean> "c1 > c2"))
  419: (define-cproc char<=? (c1::<char> c2::<char>) (expr <boolean> "c1 <= c2"))
  420: (define-cproc char>=? (c1::<char> c2::<char>) (expr <boolean> "c1 >= c2"))
  421: 
  422: (define-cise-expr char-ci-cmp
  423:   [(_ op) `(,op (SCM_CHAR_UPCASE c1) (SCM_CHAR_UPCASE c2))])
  424: 
  425: (define-cproc char-ci=? (c1::<char> c2::<char>)
  426:   (expr <boolean> (char-ci-cmp ==)))
  427: (define-cproc char-ci<? (c1::<char> c2::<char>)
  428:   (expr <boolean> (char-ci-cmp <)))
  429: (define-cproc char-ci<=? (c1::<char> c2::<char>)
  430:   (expr <boolean> (char-ci-cmp <=)))
  431: (define-cproc char-ci>? (c1::<char> c2::<char>)
  432:   (expr <boolean> (char-ci-cmp >)))
  433: (define-cproc char-ci>=? (c1::<char> c2::<char>)
  434:   (expr <boolean> (char-ci-cmp >=)))
  435: 
  436: (define-cproc char-alphabetic? (c::<char>)
  437:   (expr <boolean> (and (SCM_CHAR_ASCII_P c) (isalpha c))))
  438: (define-cproc char-numeric? (c::<char>)
  439:   (expr <boolean> (and (SCM_CHAR_ASCII_P c) (isdigit c))))
  440: (define-cproc char-whitespace? (c::<char>)
  441:   (expr <boolean> (and (SCM_CHAR_ASCII_P c) (isspace c))))
  442: (define-cproc char-upper-case? (c::<char>)
  443:   (call <boolean> "SCM_CHAR_UPPER_P"))
  444: (define-cproc char-lower-case? (c::<char>)
  445:   (call <boolean> "SCM_CHAR_LOWER_P"))
  446: 
  447: (define-cproc char->integer (c::<char>) (expr <long> "(signed long)c"))
  448: (define-cproc integer->char (c::<int>)  (expr <char> "(ScmChar)c"))
  449: 
  450: (define-cproc char-upcase (c::<char>)   (call <char> "SCM_CHAR_UPCASE"))
  451: (define-cproc char-downcase (c::<char>) (call <char> "SCM_CHAR_DOWNCASE")) 
  452: 
  453: ;;
  454: ;; 6.3.5 Strings
  455: ;;
  456: 
  457: (define-cproc string? (obj)
  458:   (inliner STRINGP)
  459:   (call <boolean> "SCM_STRINGP"))
  460: 
  461: (define-cproc make-string (len::<fixnum> &optional (c::<char> #\ ))
  462:   (call "Scm_MakeFillString"))
  463: 
  464: (define-cproc string (&rest chars)
  465:   (call "Scm_ListToString"))
  466: 
  467: (define-cproc string-length (str::<string>)
  468:   (expr <fixnum> (SCM_STRING_BODY_LENGTH (SCM_STRING_BODY str))))
  469: 
  470: ;; NB: string-set! is moved to scmlib.scm, so we can't declare setter here.
  471: ;; It is set in scmlib.scm.
  472: (define-cproc string-ref (str::<string> k::<fixnum> &optional fallback)
  473:   (body <top>
  474:         (let* ((r :: ScmChar (Scm_StringRef str k (SCM_UNBOUNDP fallback))))
  475:           (result (?: (== r SCM_CHAR_INVALID) fallback (SCM_MAKE_CHAR r))))))
  476: 
  477: (define-cise-expr strcmp
  478:   [(_ op) `(,op (Scm_StringCmp s1 s2) 0)])
  479: (define-cise-expr strcmp-ci
  480:   [(_ op) `(,op (Scm_StringCiCmp s1 s2) 0)])
  481:         
  482: (define-cproc string=? (s1::<string> s2::<string>)
  483:   (call <boolean> "Scm_StringEqual"))
  484: (define-cproc string<? (s1::<string> s2::<string>)
  485:   (expr <boolean> (strcmp <)))
  486: (define-cproc string<=? (s1::<string> s2::<string>)
  487:   (expr <boolean> (strcmp <=)))
  488: (define-cproc string>? (s1::<string> s2::<string>)
  489:   (expr <boolean> (strcmp >)))
  490: (define-cproc string>=? (s1::<string> s2::<string>)
  491:   (expr <boolean> (strcmp >=)))
  492: 
  493: (define-cproc string-ci=? (s1::<string> s2::<string>)
  494:   (expr <boolean> (strcmp-ci ==)))
  495: (define-cproc string-ci<? (s1::<string> s2::<string>)
  496:   (expr <boolean> (strcmp-ci <)))
  497: (define-cproc string-ci<=? (s1::<string> s2::<string>)
  498:   (expr <boolean> (strcmp-ci <=)))
  499: (define-cproc string-ci>? (s1::<string> s2::<string>)
  500:   (expr <boolean> (strcmp-ci >)))
  501: (define-cproc string-ci>=? (s1::<string> s2::<string>)
  502:   (expr <boolean> (strcmp-ci >=)))
  503: 
  504: (define-cproc substring (str::<string> start::<fixnum> end::<fixnum>)
  505:   (expr <top> (Scm_Substring str start end FALSE)))
  506: 
  507: (define-cproc string-append (&rest args)
  508:   (call "Scm_StringAppend"))
  509: 
  510: (define-cproc string->list (str::<string> &optional start end)
  511:   (expr <top>
  512:         (Scm_StringToList (SCM_STRING (Scm_MaybeSubstring str start end)))))
  513: 
  514: (define-cproc list->string (list::<list>)
  515:   (call "Scm_ListToString"))
  516: 
  517: (define-cproc string-copy (str::<string> &optional start end)
  518:   (expr <top>
  519:         (Scm_CopyString (SCM_STRING (Scm_MaybeSubstring str start end)))))
  520: 
  521: ;;
  522: ;; 6.3.6  Vectors
  523: ;;
  524: 
  525: (define-cproc vector? (obj)
  526:   (inliner VECTORP)
  527:   (call <boolean> "SCM_VECTORP"))
  528: 
  529: (define-cproc make-vector (k::<fixnum> &optional fill)
  530:   (call "Scm_MakeVector"))
  531: 
  532: (define-cproc vector (&rest args)
  533:   (inliner VEC)
  534:   (expr <top> (Scm_ListToVector args 0 -1)))
  535: 
  536: (define-cproc vector-length (vec::<vector>)
  537:   (inliner VEC-LEN)
  538:   (call <fixnum> "SCM_VECTOR_SIZE"))
  539: 
  540: (define-cproc vector-ref (vec::<vector> k::<integer> &optional fallback)
  541:   (setter vector-set!)
  542:   (body <top>
  543:         (cond ((or (SCM_BIGNUMP k)
  544:                    (< (SCM_INT_VALUE k) 0)
  545:                    (>= (SCM_INT_VALUE k) (SCM_VECTOR_SIZE vec)))
  546:                (when (SCM_UNBOUNDP fallback)
  547:                  (Scm_Error "vector-ref index out of range: %S" k))
  548:                (result fallback))
  549:               (else
  550:                (result (SCM_VECTOR_ELEMENT vec (SCM_INT_VALUE k)))))))
  551: 
  552: (define-cproc vector-set! (vec::<vector> k::<integer> obj)
  553:   (body <void>
  554:         (if (or (SCM_BIGNUMP k)
  555:                 (< (SCM_INT_VALUE k) 0)
  556:                 (>= (SCM_INT_VALUE k) (SCM_VECTOR_SIZE vec)))
  557:           (Scm_Error "vector-set! index out of range: %S" k)
  558:           (set! (SCM_VECTOR_ELEMENT vec (SCM_INT_VALUE k)) obj))))
  559: 
  560: (define-cproc vector->list (vec::<vector>
  561:                             &optional (start::<fixnum> 0) (end::<fixnum> -1))
  562:   (call "Scm_VectorToList"))
  563: 
  564: (define-cproc list->vector (list::<list>
  565:                             &optional (start::<fixnum> 0) (end::<fixnum> -1))
  566:   (call "Scm_ListToVector"))
  567: 
  568: (define-cproc vector-fill! (vec::<vector> fill
  569:                             &optional (start::<fixnum> 0) (end::<fixnum> -1))
  570:   (call <void> "Scm_VectorFill"))
  571: 
  572: ;;
  573: ;; 6.4  Control Features
  574: ;;
  575: 
  576: (define-cproc procedure? (obj) (call <boolean> "SCM_PROCEDUREP"))
  577: 
  578: (define-cproc apply (proc arg1 &rest args)
  579:   (inliner APPLY)
  580:   (body <top>
  581:         (let* ((head :: ScmObj)
  582:                (tail :: ScmObj))
  583:           (cond ((SCM_NULLP args) (result (Scm_VMApply proc arg1)))
  584:                 (else
  585:                  (set! head (Scm_Cons arg1 SCM_NIL)
  586:                        tail head)
  587:                  (pair-for-each (lambda (cp)
  588:                                   (when (SCM_NULLP (SCM_CDR cp))
  589:                                     (SCM_APPEND head tail (SCM_CAR cp))
  590:                                     (break))
  591:                                   (unless (SCM_PAIRP (SCM_CDR cp))
  592:                                     (Scm_Error "improper list not allowed: %S"
  593:                                                (SCM_CDR cp)))
  594:                                   (SCM_APPEND1 head tail (SCM_CAR cp)))
  595:                                 args)
  596:                  (result (Scm_VMApply proc head))))
  597:           )))
  598: 
  599: (define-cproc map (proc args::<list> &rest moreargs)
  600:   (call "Scm_Map"))
  601: 
  602: (define-cproc for-each (proc args::<list> &rest moreargs)
  603:   (call "Scm_ForEach"))
  604:           
  605: (define-cproc force (p)
  606:   (call "Scm_Force"))
  607: 
  608: (define-cproc call-with-current-continuation (proc)
  609:   (call "Scm_VMCallCC"))
  610: 
  611: (define-cproc values (&rest args)
  612:   (inliner VALUES)
  613:   (call "Scm_Values"))
  614: 
  615: ;; call-with-values - defined in scmlib.scm
  616: 
  617: (define-cproc dynamic-wind (pre body post)
  618:   (call "Scm_VMDynamicWind"))
  619: 
  620: (define-cproc eval (expr env)
  621:   (call "Scm_VMEval"))
  622: 
  623: ;; for now, just return a module.
  624: (define-cproc null-environment (version::<fixnum>)
  625:   (body <top>
  626:         (when (!= version 5)
  627:           (Scm_Error "unknown rNrs version: %d" version))
  628:         (result (SCM_OBJ (Scm_NullModule)))))
  629: (define-cproc scheme-report-environment (version::<fixnum>)
  630:   (body <top>
  631:         (when (!= version 5)
  632:           (Scm_Error "unknown rNrs version: %d" version))
  633:         (result (SCM_OBJ (Scm_SchemeModule)))))
  634: (define-cproc interaction-environment ()
  635:   (expr <top> (SCM_OBJ (Scm_UserModule))))
  636: 
  637: ;;
  638: ;; 6.6.1  Ports
  639: ;;
  640:   
  641: ;; open-input-file, open-output-file, and various call-with-* and
  642: ;; with-* are defined in scmlib.scm.
  643: 
  644: (define-cproc input-port? (obj)  (call <boolean> "SCM_IPORTP"))
  645: (define-cproc output-port? (obj) (call <boolean> "SCM_OPORTP"))
  646: (define-cproc port? (obj)        (call <boolean> "SCM_PORTP"))
  647: 
  648: (define-cproc current-input-port (&optional newport)
  649:   (body <top>
  650:         (cond
  651:          ((SCM_IPORTP newport)
  652:           (result (Scm_SetCurrentInputPort (SCM_PORT newport))))
  653:          ((not (SCM_UNBOUNDP newport))
  654:           (Scm_TypeError "current-input-port" "input port" newport)
  655:           (result SCM_UNDEFINED))
  656:          (else
  657:           (result (SCM_OBJ SCM_CURIN))))
  658:        ))
  659: 
  660: (define-cproc current-output-port (&optional newport)
  661:   (body <top>
  662:         (cond
  663:          ((SCM_OPORTP newport)
  664:           (result (Scm_SetCurrentOutputPort (SCM_PORT newport))))
  665:          ((not (SCM_UNBOUNDP newport))
  666:           (Scm_TypeError "current-output-port" "output port" newport)
  667:           (result SCM_UNDEFINED))
  668:          (else
  669:           (result (SCM_OBJ SCM_CUROUT))))))
  670: 
  671: (define-cproc close-input-port (port::<port>)
  672:   (call <void> "Scm_ClosePort"))
  673: 
  674: (define-cproc close-output-port (port::<port>)
  675:   (call <void> "Scm_ClosePort"))
  676: 
  677: ;;
  678: ;; 6.6.2  Input
  679: ;;
  680: 
  681: (define-cproc read (&optional (port::<input-port> (current-input-port)))
  682:   (expr <top> (Scm_Read (SCM_OBJ port))))
  683: 
  684: (define-cproc read-char (&optional (port::<input-port> (current-input-port)))
  685:   (inliner READ-CHAR)
  686:   (body <top>
  687:          (let* ((ch :: int))
  688:            (SCM_GETC ch port)
  689:            (result (?: (== ch EOF) SCM_EOF (SCM_MAKE_CHAR ch))))))
  690: 
  691: (define-cproc peek-char (&optional (port::<input-port> (current-input-port)))
  692:   (inliner PEEK-CHAR)
  693:   (body <top>
  694:         (let* ((ch :: ScmChar (Scm_Peekc port)))
  695:           (result (?: (== ch SCM_CHAR_INVALID) SCM_EOF (SCM_MAKE_CHAR ch))))))
  696: 
  697: (define-cproc eof-object? (obj)
  698:   (inliner EOFP)
  699:   (call <boolean> "SCM_EOFP"))
  700: 
  701: (define-cproc char-ready? (&optional (port::<input-port> (current-input-port)))
  702:   (call <boolean> "Scm_CharReady"))
  703: 
  704: ;;
  705: ;; 6.6.3  Output
  706: ;;
  707: 
  708: (define-cproc write (obj &optional (port::<output-port> (current-output-port)))
  709:   (body <void> (Scm_Write obj (SCM_OBJ port) SCM_WRITE_WRITE)))
  710: 
  711: (define-cproc display (obj &optional (port::<output-port> (current-output-port)))
  712:   (body <void> (Scm_Write obj (SCM_OBJ port) SCM_WRITE_DISPLAY)))
  713: 
  714: (define-cproc newline (&optional (port::<output-port> (current-output-port)))
  715:   (body <void> (SCM_PUTC #\newline port)))
  716: 
  717: (define-cproc write-char (ch::<char>
  718:                           &optional
  719:                           (port::<output-port> (current-output-port)))
  720:   (inliner WRITE-CHAR)
  721:   (body <void> (SCM_PUTC ch port)))
  722: 
  723: ;;
  724: ;; 6.6.4  System Interface
  725: ;;
  726: 
  727: ; load : defined in load.c
  728: ; transcript-on
  729: ; transcript-off
  730: 
  731: ;; Local variables:
  732: ;; mode: scheme
  733: ;; end: