1: ;;;
    2: ;;; scmlib.scm - more Scheme libraries
    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: scmlib.scm,v 1.14 2007/07/01 08:03:09 shirok Exp $
   34: ;;;
   35: 
   36: ;; This file contains builtin library functions that are easier to be
   37: ;; written in Scheme instead of as stubs.
   38: ;;
   39: 
   40: (select-module gauche)
   41: 
   42: ;;;=======================================================
   43: ;;; List utilities
   44: ;;;
   45: 
   46: ;; R5RS cxr's
   47: 
   48: ;; NB: we avoid using getter-with-setter here, since
   49: ;;   - The current compiler doesn't take advantage of locked setters
   50: ;;   - Using getter-with-setter loses the inferred closure name
   51: ;; But this may change in future, of course.
   52: (define-syntax %define-cxr
   53:   (syntax-rules ()
   54:     ((_ name a b)
   55:      (begin
   56:        (define-inline (name x) (a (b x)))
   57:        (define-in-module scheme name name)
   58:        (set! (setter name) (lambda (x v) (set! (a (b x)) v)))))))
   59: 
   60: (%define-cxr caaar  car  caar)
   61: (%define-cxr caadr  car  cadr)
   62: (%define-cxr cadar  car  cdar)
   63: (%define-cxr caddr  car  cddr)
   64: (%define-cxr cdaar  cdr  caar)
   65: (%define-cxr cdadr  cdr  cadr)
   66: (%define-cxr cddar  cdr  cdar)
   67: (%define-cxr cdddr  cdr  cddr)
   68: (%define-cxr caaaar caar caar)
   69: (%define-cxr caaadr caar cadr)
   70: (%define-cxr caadar caar cdar)
   71: (%define-cxr caaddr caar cddr)
   72: (%define-cxr cadaar cadr caar)
   73: (%define-cxr cadadr cadr cadr)
   74: (%define-cxr caddar cadr cdar)
   75: (%define-cxr cadddr cadr cddr)
   76: (%define-cxr cdaaar cdar caar)
   77: (%define-cxr cdaadr cdar cadr)
   78: (%define-cxr cdadar cdar cdar)
   79: (%define-cxr cdaddr cdar cddr)
   80: (%define-cxr cddaar cddr caar)
   81: (%define-cxr cddadr cddr cadr)
   82: (%define-cxr cdddar cddr cdar)
   83: (%define-cxr cddddr cddr cddr)
   84: 
   85: ;; Some srfi-1 functions that are used in the compiler
   86: ;; (hence we need to define here)
   87: 
   88: (define-inline (null-list? l)
   89:   (cond ((null? l))
   90:         ((pair? l) #f)
   91:         (else (error "argument must be a list, but got:" l))))
   92: 
   93: (with-module gauche.internal
   94:   (define (%zip-nary-args arglists . seed)
   95:     (let loop ((as arglists)
   96:                (cars '())
   97:                (cdrs '()))
   98:       (cond ((null? as)
   99:              (values (reverse! (if (null? seed) cars (cons (car seed) cars)))
  100:                      (reverse! cdrs)))
  101:             ((null? (car as)) (values #f #f)) ;;exhausted
  102:             ((pair? (car as))
  103:              (loop (cdr as) (cons (caar as) cars) (cons (cdar as) cdrs)))
  104:             (else
  105:              (error "argument lists contained an improper list ending with:"
  106:                     (car as))))))
  107:   )
  108: 
  109: (define (any pred lis . more)
  110:   (if (null? more)
  111:     (and (not (null-list? lis))
  112:          (let loop ((head (car lis)) (tail (cdr lis)))
  113:            (cond ((null-list? tail) (pred head)) ; tail call
  114:                  ((pred head))
  115:                  (else (loop (car tail) (cdr tail))))))
  116:     (let loop ((liss (cons lis more)))
  117:       (receive (cars cdrs)
  118:           ((with-module gauche.internal %zip-nary-args) liss)
  119:         (cond ((not cars) #f)
  120:               ((apply pred cars))
  121:               (else (loop cdrs)))))))
  122: 
  123: (define (fold kons knil lis . more)
  124:   (if (null? more)
  125:     (let loop ((lis lis) (knil knil))
  126:       (if (null-list? lis) knil (loop (cdr lis) (kons (car lis) knil))))
  127:     (let loop ((liss (cons lis more)) (knil knil))
  128:       (receive (cars cdrs)
  129:           ((with-module gauche.internal %zip-nary-args) liss knil)
  130:         (if cars
  131:           (loop cdrs (apply kons cars))
  132:           knil)))))
  133: 
  134: (define (fold-right kons knil lis . more)
  135:   (if (null? more)
  136:     (let rec ((lis lis))
  137:       (if (null-list? lis)
  138:         knil
  139:         (kons (car lis) (rec (cdr lis)))))
  140:     (let rec ((liss (cons lis more)))
  141:       (receive (cars cdrs)
  142:           ((with-module gauche.internal %zip-nary-args) liss)
  143:         (if cars
  144:           (apply kons (append! cars (list (rec cdrs))))
  145:           knil)))))
  146: 
  147: (define (find pred lis)
  148:   (let loop ((lis lis))
  149:     (cond ((not (pair? lis)) #f)
  150:           ((pred (car lis)) (car lis))
  151:           (else (loop (cdr lis))))))
  152: 
  153: (define (split-at lis i)
  154:   (let loop ((i i) (rest lis) (r '()))
  155:     (cond ((= i 0) (values (reverse! r) rest))
  156:           ((null? rest) (error "given list is too short:" lis))
  157:           (else (loop (- i 1) (cdr rest) (cons (car rest) r))))))
  158: 
  159: ;;;=======================================================
  160: ;;; string stuff
  161: ;;;
  162: 
  163: ;; String mutators.
  164: ;; They are just for backward compatibility, and they are expensive
  165: ;; anyway, so we provide them here instead of natively.
  166: 
  167: (define-in-module scheme (string-set! str k ch)
  168:   (check-arg string? str)
  169:   (check-arg integer? k)
  170:   (check-arg exact? k)
  171:   (check-arg char? ch)
  172:   (let ((len (string-length str)))
  173:     (when (or (< k 0) (<= len k))
  174:       (error "string index out of range:" k))
  175:     (%string-replace-body! str
  176:                            (string-append (substring str 0 k)
  177:                                           (string ch)
  178:                                           (substring str (+ k 1) len)))))
  179: 
  180: (set! (setter string-ref) string-set!)
  181: 
  182: (define (string-byte-set! str k b)
  183:   (check-arg string? str)
  184:   (check-arg integer? k)
  185:   (check-arg exact? k)
  186:   (check-arg integer? b)
  187:   (let ((siz (string-size str))
  188:         (out (open-output-string :private? #t)))
  189:     (when (or (< k 0) (<= siz k))
  190:       (error "string index out of range:" k))
  191:     (display (byte-substring str 0 k) out)
  192:     (write-byte b out)
  193:     (display (byte-substring str (+ k 1) siz) out)
  194:     (%string-replace-body! str (get-output-byte-string out))))
  195: 
  196: (set! (setter string-byte-ref) string-byte-set!)
  197: 
  198: (define (string-fill! str c . opts)
  199:   (check-arg string? str)
  200:   (check-arg char? c)
  201:   (let1 len (string-length str)
  202:     (let-optionals* opts ((start 0)
  203:                           (end   len))
  204:       (when (or (< start 0) (< len start))
  205:         (error "start index out of range:" start))
  206:       (when (or (< end 0) (< len end))
  207:         (error "end index out of range:" end))
  208:       (when (< end start)
  209:         (errorf "end index ~s is smaller than start index ~s" end start))
  210:       (if (and (= start 0) (= end len))
  211:         (%string-replace-body! str (make-string len c))
  212:         (%string-replace-body! str
  213:                                (string-append (substring str 0 start)
  214:                                               (make-string (- end start) c)
  215:                                               (substring str end len)))))))
  216: 
  217: (define-reader-ctor 'string-interpolate
  218:   (lambda (s) (string-interpolate s))) ;;lambda is required to delay loading
  219: 
  220: ;;;=======================================================
  221: ;;; call/cc alias
  222: ;;;
  223: (define-in-module scheme call/cc call-with-current-continuation)
  224: 
  225: ;;;=======================================================
  226: ;;; error stuff, in terms of the condition system
  227: ;;;
  228: (define-values (error errorf)
  229:   (let ()
  230:     (define (compose-error-message msg args) ;; srfi-23 style message
  231:       (let1 p (open-output-string)
  232:         (display msg p)
  233:         (let loop ((args args))
  234:           (if (null? args)
  235:             (get-output-string p)
  236:             (begin (display " " p)
  237:                    (write/ss (car args) p)
  238:                    (loop (cdr args)))))))
  239:     (define (scan-keys args)
  240:       (let loop ((args args)
  241:                  (keys '()))
  242:         (if (and (not (null? args))
  243:                  (keyword? (car args))
  244:                  (not (null? (cdr args))))
  245:           (loop (cddr args) (list* (cadr args) (car args) keys))
  246:           (values (reverse! keys) args))))
  247:     
  248:     (define (error msg . args)
  249:       (raise
  250:        (cond
  251:         ((is-a? msg <condition-meta>)
  252:          (receive (keys msgs) (scan-keys args)
  253:            (if (null? msgs)
  254:              (apply make msg keys)
  255:              (apply make msg
  256:                     :message (compose-error-message (car msgs) (cdr msgs))
  257:                     keys))))
  258:         (else (make <error> :message (compose-error-message msg args))))))
  259: 
  260:     (define (errorf fmt . args)
  261:       (raise
  262:        (cond
  263:         ((is-a? fmt <condition-meta>)
  264:          (receive (keys msgs) (scan-keys args)
  265:            (if (null? msgs)
  266:              (apply make fmt keys)
  267:              (apply make fmt
  268:                     :message (apply format/ss #f msgs)
  269:                     keys))))
  270:         (else (make <error> :message (apply format/ss #f fmt args))))))
  271: 
  272:     (values error errorf)))
  273: 
  274: (define <exception> <condition>) ;; backward compatibility
  275: 
  276: ;;;=======================================================
  277: ;;; symbol-bound? (deprecated)
  278: ;;;
  279: (define (symbol-bound? name . maybe-module)
  280:   (global-variable-bound? (get-optional maybe-module #f) name))
  281: 
  282: ;;;=======================================================
  283: ;;; call-with-values
  284: ;;;
  285: (define-in-module scheme (call-with-values producer consumer)
  286:   (receive vals (producer) (apply consumer vals)))
  287: 
  288: ;;;=======================================================
  289: ;;; signal utility
  290: ;;;
  291: (define (sys-sigset . signals)
  292:   (if (null? signals)
  293:     (make <sys-sigset>)
  294:     (apply sys-sigset-add! (make <sys-sigset>) signals)))
  295: 
  296: ;;;=======================================================
  297: ;;; srfi-17
  298: ;;;
  299: (define (getter-with-setter get set)
  300:   (let ((proc (lambda x (apply get x))))
  301:     (set! (setter proc) set)
  302:     proc))
  303: 
  304: ;;;=======================================================
  305: ;;; srfi-38
  306: ;;;
  307: 
  308: (define read-with-shared-structure read)
  309: (define read/ss read)
  310: 
  311: (define (write-with-shared-structure obj . args)
  312:   (write* obj (if (pair? args) (car args) (current-output-port))))
  313: (define write/ss write-with-shared-structure)
  314: 
  315: ;;;=======================================================
  316: ;;; i/o utility
  317: ;;;
  318: 
  319: (define (print . args) (for-each display args) (newline))
  320: 
  321: (define-values (format format/ss)
  322:   (letrec ((format-int
  323:             (lambda (port fmt args shared?)
  324:               (cond ((eqv? port #f)
  325:                      (let ((out (open-output-string :private? #t)))
  326:                        (%format out fmt args shared?)
  327:                        (get-output-string out)))
  328:                     ((eqv? port #t)
  329:                      (%format (current-output-port) fmt args shared?))
  330:                     (else (%format port fmt args shared?)))))
  331:            (format
  332:             (lambda (fmt . args)
  333:               (if (string? fmt)
  334:                 (format-int #f fmt args #f) ;; srfi-28 compatible behavior
  335:                 (format-int fmt (car args) (cdr args) #f))))
  336:            (format/ss
  337:             (lambda (fmt . args)
  338:               (if (string? fmt)
  339:                 (format-int #f fmt args #t) ;; srfi-28 compatible behavior
  340:                 (format-int fmt (car args) (cdr args) #t))))
  341:            )
  342:     (values format format/ss)))
  343: 
  344: ;;;=======================================================
  345: ;;; with-something
  346: ;;;
  347: 
  348: ;; R5RS open-{input|output}-file can be hooked by conversion port.
  349: ;; %open-{input|output}-file/conv are autoloaded.
  350: 
  351: (define-in-module scheme (open-input-file filename . args)
  352:   (if (get-keyword :encoding args #f)
  353:     (apply %open-input-file/conv filename args)
  354:     (apply %open-input-file filename args)))
  355: 
  356: (define-in-module scheme (open-output-file filename . args)
  357:   (if (get-keyword :encoding args #f)
  358:     (apply %open-output-file/conv filename args)
  359:     (apply %open-output-file filename args)))
  360: 
  361: ;; File ports.
  362: 
  363: (define-in-module scheme (call-with-input-file filename proc . flags)
  364:   (let ((port (apply open-input-file filename flags)))
  365:     (with-error-handler
  366:      (lambda (e)
  367:        (when port (close-input-port port))
  368:        (raise e))
  369:      (lambda ()
  370:        (receive r (proc port)
  371:          (when port (close-input-port port))
  372:          (apply values r))))))
  373: 
  374: (define-in-module scheme (call-with-output-file filename proc . flags)
  375:   (let ((port (apply open-output-file filename flags)))
  376:     (with-error-handler
  377:      (lambda (e)
  378:        (when port (close-output-port port))
  379:        (raise e))
  380:      (lambda ()
  381:        (receive r (proc port)
  382:          (when port (close-output-port port))
  383:          (apply values r))))))
  384: 
  385: (define-in-module scheme (with-input-from-file filename thunk . flags)
  386:   (let ((port (apply open-input-file filename flags)))
  387:     (and port
  388:          (with-error-handler
  389:           (lambda (e) (close-input-port port) (raise e))
  390:           (lambda ()
  391:             (receive r (with-input-from-port port thunk)
  392:               (close-input-port port)
  393:               (apply values r)))))))
  394:                   
  395: 
  396: (define-in-module scheme (with-output-to-file filename thunk . flags)
  397:   (let ((port (apply open-output-file filename flags)))
  398:     (and port
  399:          (with-error-handler
  400:           (lambda (e) (close-output-port port) (raise e))
  401:           (lambda ()
  402:             (receive r (with-output-to-port port thunk)
  403:               (close-output-port port)
  404:               (apply values r)))))))
  405: 
  406: ;; String ports
  407: 
  408: (define (with-output-to-string thunk)
  409:   (let ((out (open-output-string)))
  410:     (with-output-to-port out thunk)
  411:     (get-output-string out)))
  412: 
  413: (define (with-input-from-string str thunk)
  414:   (with-input-from-port (open-input-string str) thunk))
  415: 
  416: (define (call-with-output-string proc)
  417:   (let ((out (open-output-string)))
  418:     (proc out)
  419:     (get-output-string out)))
  420: 
  421: (define (call-with-input-string str proc)
  422:   (let ((in (open-input-string str)))
  423:     (proc in)))
  424: 
  425: (define (call-with-string-io str proc)
  426:   (let ((out (open-output-string))
  427:         (in  (open-input-string str)))
  428:     (proc in out)
  429:     (get-output-string out)))
  430: 
  431: (define (with-string-io str thunk)
  432:   (with-output-to-string
  433:     (lambda ()
  434:       (with-input-from-string str
  435:         thunk))))
  436: 
  437: (define (write-to-string obj . args)
  438:   (with-output-to-string
  439:     (lambda () ((if (pair? args) (car args) write) obj))))
  440: 
  441: (define (read-from-string string . args)
  442:   (with-input-from-string
  443:       (if (null? args) string (apply %maybe-substring string args))
  444:     read))
  445: 
  446: ;; with-port
  447: 
  448: (define-syntax %with-ports
  449:   (syntax-rules ()
  450:     ((_ "tmp" (tmp ...) () (port ...) (param ...) thunk)
  451:      (let ((tmp #f) ...)
  452:        (dynamic-wind
  453:            (lambda () (when port (set! tmp (param port))) ...)
  454:            thunk
  455:            (lambda () (when tmp (param tmp)) ...))))
  456:     ((_ "tmp" tmps (port . more) ports params thunk)
  457:      (%with-ports "tmp" (tmp . tmps) more ports params thunk))
  458:     ((_ ((param port) ...) thunk)
  459:      (%with-ports "tmp" () (port ...) (port ...) (param ...) thunk))
  460:     ))
  461: 
  462: (define (with-input-from-port port thunk)
  463:   (%with-ports ((current-input-port port)) thunk))
  464: 
  465: (define (with-output-to-port port thunk)
  466:   (%with-ports ((current-output-port port)) thunk))
  467: 
  468: (define (with-error-to-port port thunk)
  469:   (%with-ports ((current-error-port port)) thunk))
  470: 
  471: (define (with-ports iport oport eport thunk)
  472:   (%with-ports ((current-input-port iport)
  473:                 (current-output-port oport)
  474:                 (current-error-port eport))
  475:                thunk))