guile/types.scm

   1 ;;  Copyright (C) 2015
   2 ;;      "Mu Lei" known as "NalaGinrut" <NalaGinrut@gmail.com>
   3 ;;  This file is free software: you can redistribute it and/or modify
   4 ;;  it under the terms of the GNU General Public License as published by
   5 ;;  the Free Software Foundation, either version 3 of the License, or
   6 ;;  (at your option) any later version.
   7
   8 ;;  This file is distributed in the hope that it will be useful,
   9 ;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 ;;  GNU General Public License for more details.
  12
  13 ;;  You should have received a copy of the GNU General Public License
  14 ;;  along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 (library (types)
  17   (export string-sub *eof* non-list?
  18           string->keyword _keyword? _string?
  19           nil _nil? list->hash-map
  20           cond-true? make-anonymous-func
  21           make-atom atom? atom-val atom-val-set!
  22           make-callable callable? callable-is_macro
  23           callable-is_macro-set! callable-closure
  24           is-func? is-macro? make-func callable-apply
  25           callable-unbox-set! callable-unbox
  26           callable-meta-info hash-table-clone
  27           box? box unbox)
  28   (import (guile) (only (rnrs) define-record-type) (ice-9 regex) (ice-9 session)))
  29
  30 (define (non-list? x) (not (list? x)))
  31
  32
  33 (define (string-sub str p1 p2)
  34   (regexp-substitute/global #f p1 str 'pre p2 'post))
  35
  36 (define *eof* (call-with-input-string "" read))
  37
  38 (define (string->keyword str)
  39   (when (not (string? str))
  40     (throw 'mal-error (format #f "string->keyword: '~a' is not a string" str)))
  41   (string-append "\u029e" str))
  42
  43 (define (_keyword? k)
  44   (and (string? k)
  45        (> (string-length k) 0)
  46        (char=? #\1236 (string-ref k 0))))
  47
  48 (define (_string? s)
  49   (and (string? s) (not (_keyword? s))))
  50
  51 (define-record-type mal-nil)
  52
  53 (define nil (make-mal-nil))
  54
  55 (define (_nil? obj) (mal-nil? obj))
  56
  57 (define (cond-true? obj)
  58   (and (not (_nil? obj)) obj))
  59
  60 (define-record-type atom (fields (mutable val)))
  61
  62 (define-record-type callable
  63   (fields
  64    meta-info
  65    (mutable unbox)
  66    (mutable is_macro)
  67    closure))
  68
  69 (define (make-func closure) (make-callable nil #t #f closure))
  70 (define (make-anonymous-func closure) (make-callable nil #f #f closure))
  71
  72 (define (callable-apply c arglst)
  73   (apply (callable-closure c) (if (callable-unbox c) (map unbox arglst) arglst)))
  74
  75 (define (callable-check c b)
  76   (and (callable? c)
  77        (eq? (callable-is_macro c) b)
  78        c))
  79
  80 (define (is-func? c) (callable-check c #f))
  81 (define (is-macro? c) (callable-check c #t))
  82
  83 (define (hash-table-clone ht)
  84   (list->hash-map (hash-fold (lambda (k v p) (cons k (cons v p))) '() ht)))
  85
  86 (define-record-type box (fields val))
  87
  88 (define (box o) (make-box o))
  89 (define (unbox o)
  90   (if (box? o) (box-val o) o))
  91
  92 (define* (list->hash-map lst #:optional (ht (make-hash-table)))
  93   (cond
  94    ((null? lst) ht)
  95    (else
  96     (let lp((next lst))
  97       (cond
  98        ((null? next) ht)
  99        (else
 100         (when (null? (cdr next))
 101           (throw 'mal-error
 102                  (format #f "hash-map: '~a' lack of value" (car next))))
 103         (let ((k (car next))
 104               (v (cadr next)))
 105           (hash-set! ht k v)
 106           (lp (cddr next)))))))))