2015-03-30 21:34:40 +03:00
|
|
|
;; Copyright (C) 2015
|
|
|
|
;; "Mu Lei" known as "NalaGinrut" <NalaGinrut@gmail.com>
|
|
|
|
;; This file is free software: you can redistribute it and/or modify
|
|
|
|
;; it under the terms of the GNU General Public License as published by
|
|
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
|
|
;; (at your option) any later version.
|
|
|
|
|
|
|
|
;; This file is distributed in the hope that it will be useful,
|
|
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
;; GNU General Public License for more details.
|
|
|
|
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
|
|
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
|
|
|
|
(library (core)
|
2015-03-31 20:41:58 +03:00
|
|
|
(export core.ns ->list)
|
2015-04-03 21:27:19 +03:00
|
|
|
(import (guile) (rnrs) (types) (reader) (printer) (ice-9 match) (readline)))
|
2015-03-31 20:41:58 +03:00
|
|
|
|
|
|
|
(define (->list o) ((if (vector? o) vector->list identity) o))
|
2015-03-30 21:34:40 +03:00
|
|
|
|
|
|
|
(define (_count obj)
|
|
|
|
(cond
|
|
|
|
((_nil? obj) 0)
|
|
|
|
((vector? obj) (vector-length obj))
|
|
|
|
(else (length obj))))
|
|
|
|
|
|
|
|
(define (_empty? obj) (zero? (_count obj)))
|
|
|
|
|
2015-03-31 06:53:37 +03:00
|
|
|
;; Well, strange spec...
|
|
|
|
(define (_equal? o1 o2)
|
2015-03-31 20:41:58 +03:00
|
|
|
(equal? (->list o1) (->list o2)))
|
2015-03-31 06:53:37 +03:00
|
|
|
|
2015-03-30 21:34:40 +03:00
|
|
|
(define (pr-str . args)
|
|
|
|
(define (pr x) (pr_str x #t))
|
|
|
|
(string-join (map pr args) " "))
|
|
|
|
|
2015-03-31 06:53:37 +03:00
|
|
|
(define (str . args)
|
|
|
|
(define (pr x) (pr_str x #f))
|
|
|
|
(string-join (map pr args) ""))
|
|
|
|
|
|
|
|
(define (prn . args)
|
|
|
|
(format #t "~a~%" (apply pr-str args))
|
2015-04-03 13:45:15 +03:00
|
|
|
nil)
|
2015-03-31 06:53:37 +03:00
|
|
|
|
|
|
|
(define (println . args)
|
|
|
|
(define (pr x) (pr_str x #f))
|
2015-04-03 13:45:15 +03:00
|
|
|
(format #t "~{~a~^ ~}~%" (map pr args))
|
2015-03-31 06:53:37 +03:00
|
|
|
nil)
|
|
|
|
|
2015-03-31 18:39:59 +03:00
|
|
|
(define (slurp filename)
|
|
|
|
(when (not (file-exists? filename))
|
2015-04-05 23:27:47 +03:00
|
|
|
(throw 'mal-error (format #f "File/dir '~a' doesn't exist" filename)))
|
2015-03-31 18:39:59 +03:00
|
|
|
(call-with-input-file filename get-string-all))
|
|
|
|
|
2015-03-31 20:41:58 +03:00
|
|
|
(define (_cons x y)
|
|
|
|
(cons x (->list y)))
|
|
|
|
|
|
|
|
(define (concat . args)
|
|
|
|
(apply append (map ->list args)))
|
|
|
|
|
2015-04-02 21:39:02 +03:00
|
|
|
(define (_nth lst n)
|
|
|
|
(define ll (->list lst))
|
|
|
|
(when (>= n (length ll))
|
|
|
|
(throw 'mal-error "nth: index out of range"))
|
|
|
|
(list-ref ll n))
|
|
|
|
|
|
|
|
(define (_first lst)
|
|
|
|
(define ll (->list lst))
|
2015-04-05 23:27:47 +03:00
|
|
|
;;(format #t "FFF: ~a, ~a~%" ll (if (not (null? ll)) (car ll) ll))
|
2015-04-02 21:39:02 +03:00
|
|
|
(if (null? ll)
|
|
|
|
nil
|
|
|
|
(car ll)))
|
|
|
|
|
|
|
|
(define (_rest lst)
|
|
|
|
(define ll (->list lst))
|
|
|
|
(if (null? ll)
|
|
|
|
'()
|
|
|
|
(cdr ll)))
|
|
|
|
|
2015-04-03 13:45:15 +03:00
|
|
|
(define (_map f lst) (map (callable-closure f) (->list lst)))
|
|
|
|
|
|
|
|
(define (_apply f . args)
|
|
|
|
(define ll
|
|
|
|
(let lp((next (->list args)) (ret '()))
|
|
|
|
(cond
|
|
|
|
((null? next) (reverse ret))
|
|
|
|
(else
|
|
|
|
(let ((n (->list (car next))))
|
|
|
|
(lp (cdr next) (if (list? n)
|
|
|
|
(append (reverse n) ret)
|
|
|
|
(cons n ret))))))))
|
|
|
|
(apply (callable-closure f) ll))
|
|
|
|
|
|
|
|
(define (->symbol x)
|
|
|
|
((if (symbol? x) identity string->symbol) x))
|
|
|
|
|
|
|
|
(define (->keyword x)
|
|
|
|
((if (_keyword? x) identity string->keyword) x))
|
|
|
|
|
|
|
|
(define (_hash-map . lst) (list->hash-map lst))
|
|
|
|
|
|
|
|
(define (_assoc ht . lst) (list->hash-map lst (hash-table-clone ht)))
|
|
|
|
|
|
|
|
(define (_get ht k)
|
|
|
|
(if (_nil? ht)
|
|
|
|
nil
|
|
|
|
(hash-ref ht k nil)))
|
|
|
|
|
|
|
|
(define (_dissoc ht . lst)
|
|
|
|
(define ht2 (hash-table-clone ht))
|
|
|
|
(for-each (lambda (k) (hash-remove! ht2 k)) lst)
|
|
|
|
ht2)
|
|
|
|
|
|
|
|
(define (_keys ht) (hash-map->list (lambda (k v) k) ht))
|
|
|
|
|
|
|
|
(define (_vals ht) (hash-map->list (lambda (k v) v) ht))
|
|
|
|
|
|
|
|
(define (_contains? ht k) (if (hash-ref ht k) #t #f))
|
|
|
|
|
|
|
|
(define (_sequential? o) (or (list? o) (vector? o)))
|
|
|
|
|
2015-04-03 21:27:19 +03:00
|
|
|
(define (_meta c)
|
|
|
|
(if (callable? c)
|
|
|
|
(callable-meta-info c)
|
|
|
|
(or (object-property c 'meta) nil)))
|
|
|
|
|
|
|
|
(define (_with-meta c ht)
|
|
|
|
(cond
|
|
|
|
((callable? c)
|
|
|
|
(let ((cc (make-callable ht
|
|
|
|
(callable-unbox c)
|
2015-04-05 23:27:47 +03:00
|
|
|
(and (hash-table? ht) (hash-ref ht "ismacro"))
|
2015-04-03 21:27:19 +03:00
|
|
|
(callable-closure c))))
|
|
|
|
cc))
|
|
|
|
(else
|
|
|
|
(let ((cc (box c)))
|
2015-04-05 23:27:47 +03:00
|
|
|
(set-object-property! cc 'meta ht)
|
2015-04-03 21:27:19 +03:00
|
|
|
cc))))
|
|
|
|
|
|
|
|
;; Apply closure 'c' with atom-val as one of arguments, then
|
|
|
|
;; set the result as the new val of atom.
|
|
|
|
(define (_swap! atom c . rest)
|
|
|
|
(let* ((args (cons (atom-val atom) rest))
|
|
|
|
(val (callable-apply c args)))
|
|
|
|
(atom-val-set! atom val)
|
|
|
|
val))
|
|
|
|
|
|
|
|
(define (_conj lst . args)
|
|
|
|
(cond
|
|
|
|
((vector? lst)
|
|
|
|
(list->vector (append (->list lst) args)))
|
|
|
|
((list? lst)
|
|
|
|
(append (reverse args) (->list lst)))
|
|
|
|
(else (throw 'mal-error (format #f "conj: '~a' is not list/vector" lst)))))
|
|
|
|
|
2015-04-05 23:27:47 +03:00
|
|
|
(define (__readline prompt)
|
|
|
|
(let ((str (_readline prompt)))
|
|
|
|
(if (eof-object? str)
|
|
|
|
#f
|
|
|
|
str)))
|
|
|
|
|
2015-03-30 21:34:40 +03:00
|
|
|
(define *primitives*
|
2015-03-31 18:39:59 +03:00
|
|
|
`((list ,list)
|
|
|
|
(list? ,list?)
|
|
|
|
(empty? ,_empty?)
|
|
|
|
(count ,_count)
|
|
|
|
(= ,_equal?)
|
|
|
|
(< ,<)
|
|
|
|
(<= ,<=)
|
|
|
|
(> ,>)
|
|
|
|
(>= ,>=)
|
|
|
|
(+ ,+)
|
|
|
|
(- ,-)
|
|
|
|
(* ,*)
|
|
|
|
(/ ,/)
|
|
|
|
(not ,not)
|
|
|
|
(pr-str ,pr-str)
|
|
|
|
(str ,str)
|
|
|
|
(prn ,prn)
|
|
|
|
(println ,println)
|
|
|
|
(read-string ,read_str)
|
|
|
|
(slurp ,slurp)
|
2015-03-31 20:41:58 +03:00
|
|
|
(cons ,_cons)
|
|
|
|
(concat ,concat)
|
2015-04-02 21:39:02 +03:00
|
|
|
(nth ,_nth)
|
|
|
|
(first ,_first)
|
|
|
|
(rest ,_rest)
|
2015-04-03 13:45:15 +03:00
|
|
|
(map ,_map)
|
|
|
|
(apply ,_apply)
|
|
|
|
(nil? ,_nil?)
|
|
|
|
(true? ,(lambda (x) (eq? x #t)))
|
|
|
|
(false? ,(lambda (x) (eq? x #f)))
|
|
|
|
(symbol? ,symbol?)
|
|
|
|
(symbol ,->symbol)
|
|
|
|
(keyword ,->keyword)
|
|
|
|
(keyword? ,_keyword?)
|
|
|
|
(vector? ,vector?)
|
|
|
|
(vector ,vector)
|
|
|
|
(hash-map ,_hash-map)
|
|
|
|
(map? ,hash-table?)
|
|
|
|
(assoc ,_assoc)
|
|
|
|
(get ,_get)
|
|
|
|
(dissoc ,_dissoc)
|
|
|
|
(keys ,_keys)
|
|
|
|
(vals ,_vals)
|
|
|
|
(contains? ,_contains?)
|
|
|
|
(sequential? ,_sequential?)
|
2015-04-05 23:27:47 +03:00
|
|
|
(readline ,__readline)
|
2015-04-03 21:27:19 +03:00
|
|
|
(meta ,_meta)
|
|
|
|
(with-meta ,_with-meta)
|
|
|
|
(atom ,make-atom)
|
2015-04-05 23:27:47 +03:00
|
|
|
(atom? ,atom?)
|
2015-04-03 21:27:19 +03:00
|
|
|
(deref ,atom-val)
|
|
|
|
(reset! ,atom-val-set!)
|
|
|
|
(swap! ,_swap!)
|
|
|
|
(conj ,_conj)))
|
2015-03-30 21:34:40 +03:00
|
|
|
|
|
|
|
;; Well, we have to rename it to this strange name...
|
|
|
|
(define core.ns *primitives*)
|