src/utils.scm

   1 ;;; Gacela, a GNU Guile extension for fast games development
   2 ;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
   3 ;;;
   4 ;;; This program is free software: you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation, either version 3 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License
  15 ;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16
  17
  18 (define-module (gacela utils)
  19   #:export (use-cache-with
  20             arguments-calling
  21             arguments-apply
  22             bound?
  23             names-arguments
  24             make-producer))
  25
  26
  27 ;;; Cache for procedures
  28
  29 (define (use-cache-with proc)
  30   "Cache for procedures"
  31   (let ((cache (make-weak-value-hash-table)))
  32     (lambda (. param)
  33       (let* ((key param)
  34              (res (hash-ref cache key)))
  35         (cond (res res)
  36               (else
  37                (set! res (apply proc param))
  38                (hash-set! cache key res)
  39                res))))))
  40
  41
  42 ;;; Playing with procedures arguments
  43
  44 (define undefined)
  45 (define (bound? var) (not (eq? var undefined)))
  46
  47 (define (required-arguments args values)
  48   "Return an alist with required arguments and their values"
  49   (define (f vars values)
  50     (cond ((null? vars) '())
  51           ((null? values) (assoc-set! (f (cdr vars) '())
  52                                       (car vars)
  53                                       undefined))
  54           (else (assoc-set! (f (cdr vars) (cdr values))
  55                             (car vars)
  56                             (car values)))))
  57   (f (assoc-ref args 'required) values))
  58
  59 (define (optional-arguments args values)
  60   "Return an alist with optional arguments and their values"
  61   (define (f vars values)
  62     (cond ((null? vars) '())
  63           ((null? values) (assoc-set! (f (cdr vars) '())
  64                                       (car vars)
  65                                       undefined))
  66           (else (assoc-set! (f (cdr vars) (cdr values))
  67                             (car vars)
  68                             (car values)))))
  69   (f (assoc-ref args 'optional)
  70      (list-tail values
  71                 (min (length (assoc-ref args 'required))
  72                      (length values)))))
  73
  74 (define (keyword-arguments args values)
  75   "Return an alist with keyword arguments and their values"
  76   (define (f vars values)
  77     (cond ((null? vars) '())
  78           (else
  79            (let ((val (member (car vars) values)))
  80              (assoc-set! (f (cdr vars) values)
  81                             (keyword->symbol (car vars))
  82                             (if val (cadr val) undefined))))))
  83   (f (map (lambda (x) (car x)) (assoc-ref args 'keyword)) values))
  84
  85 (define (rest-arguments args values)
  86   "Return an alist with rest arguments"
  87   (let ((rest (assoc-ref args 'rest)))
  88     (cond (rest (assoc-set! '()
  89                             rest
  90                             (list-tail values
  91                                        (min (+ (length (assoc-ref args 'required))
  92                                                (length (assoc-ref args 'optional)))
  93                                             (length values)))))
  94           (else '()))))
  95
  96 (define (arguments-calling proc values)
  97   "Return an alist with procedure arguments and their values"
  98   (let ((args ((@ (ice-9 session) procedure-arguments) proc)))
  99     (append (required-arguments args values)
 100             (optional-arguments args values)
 101             (keyword-arguments args values)
 102             (rest-arguments args values))))
 103
 104 (define (required-arguments-apply args values)
 105   "Return a list with required arguments for use with apply"
 106   (define (f vars values)
 107     (cond ((null? vars) '())
 108           (else
 109            (cons (assoc-ref values (car vars))
 110                  (f (cdr vars) values)))))
 111   (f (assoc-ref args 'required) values))
 112
 113 (define (optional-arguments-apply args values)
 114   "Return a list with optional arguments for use with apply"
 115   (define (f vars values)
 116     (cond ((null? vars) '())
 117           (else (let ((a (f (cdr vars) values))
 118                       (val (assoc (car vars) values)))
 119                   (cond ((and val (bound? (cdr val)))
 120                          (cons (cdr val) a))
 121                         (else a))))))
 122   (f (assoc-ref args 'optional) values))
 123
 124 (define (keyword-arguments-apply args values)
 125   "Return a list with keyword arguments for use with apply"
 126   (define (f vars values)
 127     (cond ((null? vars) '())
 128           (else (let ((a (f (cdr vars) values))
 129                       (val (assoc (keyword->symbol (car vars)) values)))
 130                   (cond ((and val (bound? (cdr val)))
 131                          (cons (car vars) (cons (cdr val) a)))
 132                         (else a))))))
 133   (f (map (lambda (x) (car x)) (assoc-ref args 'keyword)) values))
 134
 135 (define (rest-arguments-apply args values)
 136   "Return a list with rest arguments for use with apply"
 137   (let ((rest (assoc-ref args 'rest)))
 138     (cond (rest (assoc-ref values rest))
 139           (else '()))))
 140
 141 (define (arguments-apply proc values)
 142   "Return a list for use with apply"
 143   (let ((args ((@ (ice-9 session) procedure-arguments) proc)))
 144     (append (required-arguments-apply args values)
 145             (optional-arguments-apply args values)
 146             (keyword-arguments-apply args values)
 147             (rest-arguments-apply args values))))
 148
 149 (define (names-arguments args)
 150   (map (lambda (x) (if (list? x) (car x) x))
 151        (filter (lambda (x) (not (keyword? x)))
 152                (pair-to-list args))))
 153
 154
 155 ;;; Continuations and coroutines
 156
 157 (define (make-producer body)
 158   (define resume #f)
 159   (lambda (real-send)
 160     (define send-to real-send)
 161     (define (send value-to-send)
 162       (set! send-to
 163             (call/cc
 164              (lambda (k)
 165                (set! resume k)
 166                (send-to value-to-send)))))
 167     (if resume
 168         (resume real-send)
 169         (body send))))
 170
 171
 172 ;;; Miscellaneous
 173
 174 (define (pair-to-list pair)
 175   (cond ((null? pair) '())
 176         ((not (pair? pair)) (list pair))
 177         (else (cons (car pair) (pair-to-list (cdr pair))))))