mirror of
https://github.com/kanaka/mal.git
synced 2024-10-26 14:22:25 +03:00
Merge pull request #56 from NalaGinrut/master
Added GNU Guile implementation
This commit is contained in:
commit
9f21caf388
5
Makefile
5
Makefile
@ -12,7 +12,7 @@ PYTHON = python
|
||||
|
||||
IMPLS = bash c clojure coffee cpp cs erlang factor forth go haskell java \
|
||||
julia js lua make mal ocaml matlab miniMAL nim perl php ps \
|
||||
python r racket ruby rust scala swift vb
|
||||
python r racket ruby rust scala swift vb guile
|
||||
|
||||
step0 = step0_repl
|
||||
step1 = step1_read_print
|
||||
@ -84,6 +84,7 @@ rust_STEP_TO_PROG = rust/target/release/$($(1))
|
||||
scala_STEP_TO_PROG = scala/$($(1)).scala
|
||||
swift_STEP_TO_PROG = swift/$($(1))
|
||||
vb_STEP_TO_PROG = vb/$($(1)).exe
|
||||
guile_STEP_TO_PROG = guile/$($(1)).scm
|
||||
|
||||
# Needed some argument munging
|
||||
COMMA = ,
|
||||
@ -124,6 +125,8 @@ rust_RUNSTEP = ../$(2) $(3)
|
||||
scala_RUNSTEP = sbt 'run-main $($(1))$(if $(3), $(3),)'
|
||||
swift_RUNSTEP = ../$(2) $(3)
|
||||
vb_RUNSTEP = mono ../$(2) --raw $(3)
|
||||
# needs TERM=dumb to work with readline
|
||||
guile_RUNSTEP = guile -L ../guile ../$(2) $(3)
|
||||
|
||||
# Extra options to pass to runtest.py
|
||||
mal_TEST_OPTS = --start-timeout 60 --test-timeout 120
|
||||
|
@ -22,6 +22,7 @@ Mal is implemented in 32 different languages:
|
||||
* Julia
|
||||
* Lua
|
||||
* GNU Make
|
||||
* GNU Guile
|
||||
* mal itself
|
||||
* MATLAB
|
||||
* [miniMAL](https://github.com/kanaka/miniMAL)
|
||||
@ -172,6 +173,14 @@ cd forth
|
||||
gforth stepX_YYY.fs
|
||||
```
|
||||
|
||||
### GNU Guile 2.1+
|
||||
Guile implementation was created by @NalaGinrut.
|
||||
|
||||
```
|
||||
cd guile
|
||||
guile -L ./ stepX_YYY.scm
|
||||
```
|
||||
|
||||
### Go
|
||||
|
||||
The Go implementation of mal requires that go is installed on on the
|
||||
|
12
guile/Makefile
Normal file
12
guile/Makefile
Normal file
@ -0,0 +1,12 @@
|
||||
SOURCES_BASE = types.scm reader.scm printer.scm
|
||||
SOURCES_LISP = env.scm core.scm stepA_mal.scm
|
||||
SOURCES = $(SOURCES_BASE) $(SOURCES_LISP)
|
||||
|
||||
all:
|
||||
|
||||
.PHONY: stats
|
||||
|
||||
stats: $(SOURCES)
|
||||
@wc $^
|
||||
stats-lisp: $(SOURCES_LISP)
|
||||
@wc $^
|
235
guile/core.scm
Normal file
235
guile/core.scm
Normal file
@ -0,0 +1,235 @@
|
||||
;; 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)
|
||||
(export core.ns ->list)
|
||||
(import (guile) (rnrs) (types) (reader) (printer) (ice-9 match) (readline)))
|
||||
|
||||
(define (->list o) ((if (vector? o) vector->list identity) o))
|
||||
|
||||
(define (_count obj)
|
||||
(cond
|
||||
((_nil? obj) 0)
|
||||
((vector? obj) (vector-length obj))
|
||||
(else (length obj))))
|
||||
|
||||
(define (_empty? obj) (zero? (_count obj)))
|
||||
|
||||
;; Well, strange spec...
|
||||
(define (_equal? o1 o2)
|
||||
(equal? (->list o1) (->list o2)))
|
||||
|
||||
(define (pr-str . args)
|
||||
(define (pr x) (pr_str x #t))
|
||||
(string-join (map pr args) " "))
|
||||
|
||||
(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))
|
||||
nil)
|
||||
|
||||
(define (println . args)
|
||||
(define (pr x) (pr_str x #f))
|
||||
(format #t "~{~a~^ ~}~%" (map pr args))
|
||||
nil)
|
||||
|
||||
(define (slurp filename)
|
||||
(when (not (file-exists? filename))
|
||||
(throw 'mal-error (format #f "File/dir '~a' doesn't exist" filename)))
|
||||
(call-with-input-file filename get-string-all))
|
||||
|
||||
(define (_cons x y)
|
||||
(cons x (->list y)))
|
||||
|
||||
(define (concat . args)
|
||||
(apply append (map ->list args)))
|
||||
|
||||
(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))
|
||||
(if (null? ll)
|
||||
nil
|
||||
(car ll)))
|
||||
|
||||
(define (_rest lst)
|
||||
(define ll (->list lst))
|
||||
(if (null? ll)
|
||||
'()
|
||||
(cdr ll)))
|
||||
|
||||
(define (_map f lst) (map (callable-closure f) (->list lst)))
|
||||
|
||||
(define (_apply f . args)
|
||||
(define ll
|
||||
(let lp((next 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))))))))
|
||||
(callable-apply 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)
|
||||
(let ((v (hash-ref ht k '*mal-null*)))
|
||||
(if (eq? v '*mal-null*)
|
||||
#f
|
||||
#t)))
|
||||
|
||||
(define (_sequential? o) (or (list? o) (vector? o)))
|
||||
|
||||
(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)
|
||||
(and (hash-table? ht) (hash-ref ht "ismacro"))
|
||||
(callable-closure c))))
|
||||
cc))
|
||||
(else
|
||||
(let ((cc (box c)))
|
||||
(set-object-property! cc 'meta ht)
|
||||
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)))))
|
||||
|
||||
(define (__readline prompt)
|
||||
(let ((str (_readline prompt)))
|
||||
(if (eof-object? str)
|
||||
#f
|
||||
str)))
|
||||
|
||||
(define (_not o) (or (_nil? o) (not o)))
|
||||
|
||||
(define (_true? x) (eq? x #t))
|
||||
(define (_false? x) (eq? x #f))
|
||||
|
||||
;; We need regular named procedure for better debug
|
||||
(define (_atom x) (make-atom x))
|
||||
(define (_atom? x) (atom? x))
|
||||
(define (_deref x) (atom-val x))
|
||||
(define (_reset! x v) (atom-val-set! x v))
|
||||
|
||||
(define *primitives*
|
||||
`((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)
|
||||
(cons ,_cons)
|
||||
(concat ,concat)
|
||||
(nth ,_nth)
|
||||
(first ,_first)
|
||||
(rest ,_rest)
|
||||
(map ,_map)
|
||||
(apply ,_apply)
|
||||
(nil? ,_nil?)
|
||||
(true? ,_true?)
|
||||
(false? ,_false?)
|
||||
(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?)
|
||||
(readline ,__readline)
|
||||
(meta ,_meta)
|
||||
(with-meta ,_with-meta)
|
||||
(atom ,_atom)
|
||||
(atom? ,_atom?)
|
||||
(deref ,_deref)
|
||||
(reset! ,_reset!)
|
||||
(swap! ,_swap!)
|
||||
(conj ,_conj)
|
||||
(time-ms ,current-time)))
|
||||
|
||||
;; Well, we have to rename it to this strange name...
|
||||
(define core.ns *primitives*)
|
64
guile/env.scm
Normal file
64
guile/env.scm
Normal file
@ -0,0 +1,64 @@
|
||||
;; 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 (env)
|
||||
(export make-Env env-has env-check)
|
||||
(import (guile) (types)))
|
||||
|
||||
(define (env-check sym env)
|
||||
(env-has sym env (lambda _ #f)))
|
||||
|
||||
(define (sym-err-throw sym)
|
||||
(throw 'mal-error (format #f "'~a' not found" sym)))
|
||||
|
||||
(define* (env-has sym env #:optional (err sym-err-throw))
|
||||
(let ((v ((env 'get) sym)))
|
||||
(if (equal? v '*mal-null*)
|
||||
(err sym)
|
||||
v)))
|
||||
|
||||
(define* (make-Env #:key (outer nil) (binds '()) (exprs '()))
|
||||
(define _env (make-hash-table))
|
||||
(define (_set k v) (hash-set! _env k v))
|
||||
(define (_get k)
|
||||
(let ((v (hash-ref _env k '*mal-null*)))
|
||||
(if (equal? v '*mal-null*)
|
||||
(if (_nil? outer)
|
||||
'*mal-null*
|
||||
((outer 'get) k))
|
||||
v)))
|
||||
(define (_find k) (_get k))
|
||||
(define (_show)
|
||||
(hash-for-each (lambda (k v) (format #t "~a : ~a~%" k v)) _env)
|
||||
(display "outer:\n")
|
||||
(and (not (_nil? outer)) ((outer 'show))))
|
||||
(let lp((b binds) (e exprs))
|
||||
(cond
|
||||
((null? b) #t)
|
||||
((eq? (car b) '&) (hash-set! _env (cadr b) e)) ; handle varglist
|
||||
(else ; normal binding
|
||||
(when (not (symbol? (car b)))
|
||||
(throw 'mal-error (format #f "Invalid binding key! '~a'" (car b))))
|
||||
(when (null? e)
|
||||
(throw 'mal-error "Invalid pattern for this macro"))
|
||||
(hash-set! _env (car b) (car e))
|
||||
(lp (cdr b) (cdr e)))))
|
||||
(lambda (cmd)
|
||||
(case cmd
|
||||
((set) _set)
|
||||
((find) _find)
|
||||
((get) _get)
|
||||
((show) _show)
|
||||
(else (throw 'mal-error (format #f "BUG: Invalid cmd '~a'" cmd))))))
|
136
guile/pcre.scm
Normal file
136
guile/pcre.scm
Normal file
@ -0,0 +1,136 @@
|
||||
;; 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 (pcre)
|
||||
(export new-pcre
|
||||
pcre-match
|
||||
pcre-get-substring
|
||||
pcre-search)
|
||||
(import (guile) (rnrs) (system foreign)))
|
||||
|
||||
(define (make-blob-pointer len)
|
||||
(bytevector->pointer (make-bytevector len)))
|
||||
|
||||
(define pcre-ffi (dynamic-link "libpcre"))
|
||||
|
||||
(define %pcre-compile2
|
||||
(pointer->procedure '*
|
||||
(dynamic-func "pcre_compile2" pcre-ffi)
|
||||
(list '* int '* '* '* '*)))
|
||||
|
||||
(define %pcre-compile
|
||||
(pointer->procedure '*
|
||||
(dynamic-func "pcre_compile" pcre-ffi)
|
||||
(list '* int '* '* '*)))
|
||||
|
||||
(define %pcre-exec
|
||||
(pointer->procedure int
|
||||
(dynamic-func "pcre_exec" pcre-ffi)
|
||||
(list '* '* '* int int int '* int)))
|
||||
|
||||
(define %pcre-study
|
||||
(pointer->procedure '*
|
||||
(dynamic-func "pcre_study" pcre-ffi)
|
||||
(list '* int '*)))
|
||||
|
||||
(define %pcre-get-substring
|
||||
(pointer->procedure '*
|
||||
(dynamic-func "pcre_get_substring" pcre-ffi)
|
||||
(list '* '* int int '*)))
|
||||
|
||||
(define %pcre-free
|
||||
(pointer->procedure void
|
||||
(dynamic-func "pcre_free" pcre-ffi)
|
||||
(list '*)))
|
||||
|
||||
(define %pcre-free-study (dynamic-func "pcre_free_study" pcre-ffi))
|
||||
|
||||
(define %pcre-free-substring (dynamic-func "pcre_free_substring" pcre-ffi))
|
||||
|
||||
(define-record-type pcre
|
||||
(fields
|
||||
errptr
|
||||
(mutable strptr)
|
||||
(mutable ovector)
|
||||
(mutable matched)
|
||||
(mutable code)
|
||||
(mutable extra)))
|
||||
|
||||
(define (%new-pcre)
|
||||
(make-pcre (make-blob-pointer (sizeof ptrdiff_t)) ; errptr
|
||||
#f #f 0 #f #f))
|
||||
|
||||
(define* (new-pcre re #:optional (options 0))
|
||||
(let ((reptr (string->pointer re))
|
||||
;;(errcodeptr (make-blob-pointer int))
|
||||
(erroffset (make-blob-pointer int))
|
||||
(tableptr %null-pointer)
|
||||
(pcre (%new-pcre)))
|
||||
;; FIXME: add exception handling
|
||||
(pcre-code-set! pcre (%pcre-compile reptr options (pcre-errptr pcre)
|
||||
erroffset tableptr))
|
||||
;;(set-pointer-finalizer! (pcre-code pcre) %pcre-free)
|
||||
pcre))
|
||||
|
||||
(define* (pcre-match pcre str #:key (study-options 0) (exec-options 0)
|
||||
(ovecsize 30) (offset 0))
|
||||
(let ((extra (%pcre-study (pcre-code pcre) study-options (pcre-errptr pcre)))
|
||||
(strptr (string->pointer str))
|
||||
(ovector (make-blob-pointer (* int ovecsize))))
|
||||
(pcre-matched-set! pcre
|
||||
(%pcre-exec (pcre-code pcre)
|
||||
extra
|
||||
strptr
|
||||
(string-length str)
|
||||
offset
|
||||
exec-options
|
||||
ovector
|
||||
ovecsize))
|
||||
(pcre-ovector-set! pcre ovector)
|
||||
(pcre-strptr-set! pcre strptr)
|
||||
(set-pointer-finalizer! extra %pcre-free-study)
|
||||
pcre))
|
||||
|
||||
(define (pcre-get-substring pcre index)
|
||||
(let ((strptr (pcre-strptr pcre))
|
||||
(ovector (pcre-ovector pcre))
|
||||
(matched (pcre-matched pcre))
|
||||
(buf (make-blob-pointer (sizeof ptrdiff_t))))
|
||||
(%pcre-get-substring strptr ovector matched index buf)
|
||||
(let ((ret (pointer->string (dereference-pointer buf))))
|
||||
(set-pointer-finalizer! (dereference-pointer buf) %pcre-free-substring)
|
||||
ret)))
|
||||
|
||||
(define* (pcre-search pcre str #:key (study-options 0) (exec-options 0)
|
||||
(exclude " "))
|
||||
(define (trim s)
|
||||
(string-trim-both s (lambda (x) (string-contains exclude (string x)))))
|
||||
(define len (string-length str))
|
||||
(let lp((i 0) (ret '()))
|
||||
(cond
|
||||
((>= i len) (reverse ret))
|
||||
(else
|
||||
(pcre-match pcre str #:study-options study-options #:exec-options exec-options #:offset i)
|
||||
(if (<= (pcre-matched pcre) 0)
|
||||
(lp len ret)
|
||||
(let ((hit (trim (pcre-get-substring pcre 1)))
|
||||
(sublen (string-length (pcre-get-substring pcre 0))))
|
||||
(if (zero? sublen)
|
||||
(lp len ret)
|
||||
(lp (+ i sublen) (cons hit ret)))))))))
|
||||
|
||||
(define (pcre-free pcre)
|
||||
(and (not (null-pointer? (pcre-code pcre)))
|
||||
(%pcre-free (pcre-code pcre))))
|
60
guile/printer.scm
Normal file
60
guile/printer.scm
Normal file
@ -0,0 +1,60 @@
|
||||
;; 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 (printer)
|
||||
(export pr_str)
|
||||
(import (guile) (types) (ice-9 match) (ice-9 regex)))
|
||||
|
||||
(define (print-hashmap hm p)
|
||||
(call-with-output-string
|
||||
(lambda (port)
|
||||
(display "{" port)
|
||||
(display
|
||||
(string-join
|
||||
(hash-map->list
|
||||
(lambda (k v)
|
||||
(format #f "~a ~a" (pr_str k #t) (pr_str v #t)))
|
||||
hm)
|
||||
" ")
|
||||
port)
|
||||
(display "}" port))))
|
||||
|
||||
(define (pr_str obj readable?)
|
||||
(define (->str s)
|
||||
(string-sub
|
||||
(string-sub
|
||||
(string-sub s "\\\\" "\\\\")
|
||||
"\"" "\\\"")
|
||||
"\n" "\\\n"))
|
||||
(define (%pr_str o) (pr_str o readable?))
|
||||
(match obj
|
||||
((? box?) (%pr_str (unbox obj)))
|
||||
((? is-func?) "#<function>")
|
||||
((? is-macro?) "#<macro>")
|
||||
((? list?) (format #f "(~{~a~^ ~})" (map %pr_str obj)))
|
||||
((? vector?) (format #f "[~{~a~^ ~}]" (map %pr_str (vector->list obj))))
|
||||
((? hash-table?) (print-hashmap obj %pr_str))
|
||||
((? string?)
|
||||
(cond
|
||||
((string-match "^\u029e(.*)" obj)
|
||||
=> (lambda (m) (format #f ":~a" (match:substring m 1))))
|
||||
(else (if readable? (format #f "\"~a\"" (->str obj)) obj))))
|
||||
;;((? number?) (format #f "~a" obj))
|
||||
;;((? symbol?) (format #f "~a" obj))
|
||||
((? atom?) (format #f "(atom ~a)" (%pr_str (atom-val obj))))
|
||||
((? _nil?) "nil")
|
||||
(#t "true")
|
||||
(#f "false")
|
||||
(else (format #f "~a" obj))))
|
136
guile/reader.scm
Normal file
136
guile/reader.scm
Normal file
@ -0,0 +1,136 @@
|
||||
;; 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 (reader)
|
||||
(export read_str)
|
||||
(import (guile) (pcre) (ice-9 match) (srfi srfi-1)
|
||||
(ice-9 regex) (types) (ice-9 format)))
|
||||
|
||||
(define (make-Reader tokens)
|
||||
(lambda (cmd)
|
||||
(case cmd
|
||||
((next)
|
||||
(if (null? tokens)
|
||||
'()
|
||||
(let ((r (car tokens))) (set! tokens (cdr tokens)) r)))
|
||||
((peek) (if (null? tokens) '() (car tokens)))
|
||||
(else (error "Reader: Invalid cmd!" cmd)))))
|
||||
|
||||
(define *token-re*
|
||||
(new-pcre "[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"|;[^\n]*|[^\\s\\[\\]{}('\"`,;)]*)"))
|
||||
|
||||
(define (tokenizer str)
|
||||
(filter (lambda (s) (and (not (string-null? s)) (not (string=? (substring s 0 1) ";"))))
|
||||
(pcre-search *token-re* str)))
|
||||
|
||||
(define (delim-read reader delim)
|
||||
(let lp((next (reader 'peek)) (ret '()))
|
||||
(cond
|
||||
((null? next) (throw 'mal-error (format #f "expected '~a'" delim)))
|
||||
((string=? next delim) (reader 'next) (reverse ret))
|
||||
(else
|
||||
(let* ((cur (read_form reader))
|
||||
(n (reader 'peek)))
|
||||
(lp n (cons cur ret)))))))
|
||||
|
||||
(define (read_list reader)
|
||||
(cond
|
||||
((string=? ")" (reader 'peek))
|
||||
(reader 'next)
|
||||
'())
|
||||
(else (delim-read reader ")"))))
|
||||
|
||||
(define (read_vector reader)
|
||||
(cond
|
||||
((string=? "]" (reader 'peek))
|
||||
(reader 'next)
|
||||
#())
|
||||
(else (list->vector (delim-read reader "]")))))
|
||||
|
||||
(define (read_hashmap reader)
|
||||
(define ht (make-hash-table))
|
||||
(define lst (delim-read reader "}"))
|
||||
(cond
|
||||
((null? lst) ht)
|
||||
(else
|
||||
(let lp((next lst))
|
||||
(cond
|
||||
((null? next) ht)
|
||||
(else
|
||||
(when (null? (cdr next))
|
||||
(throw 'mal-error
|
||||
(format #f "read_hashmap: '~a' lack of value" (car next))))
|
||||
(let ((k (car next))
|
||||
(v (cadr next)))
|
||||
(hash-set! ht k v)
|
||||
(lp (cddr next)))))))))
|
||||
|
||||
(define (read_atom reader)
|
||||
(define (->str s)
|
||||
(string-sub
|
||||
(string-sub s "\\\\\"" "\"")
|
||||
"\\\\\n" "\n"))
|
||||
(let ((token (reader 'next)))
|
||||
(cond
|
||||
((string-match "^-?[0-9][0-9.]*$" token)
|
||||
=> (lambda (m) (string->number (match:substring m 0))))
|
||||
((string-match "^\"(.*)(.)$" token)
|
||||
=> (lambda (m)
|
||||
(if (string=? "\"" (match:substring m 2))
|
||||
(->str (match:substring m 1))
|
||||
(throw 'mal-error "expected '\"'"))))
|
||||
((string-match "^:(.*)" token)
|
||||
=> (lambda (m) (string->keyword (match:substring m 1))))
|
||||
((string=? "nil" token) nil)
|
||||
((string=? "true" token) #t)
|
||||
((string=? "false" token) #f)
|
||||
(else (string->symbol token)))))
|
||||
|
||||
(define (read_form reader)
|
||||
(define (clean x)
|
||||
(if (string? x)
|
||||
(string-trim-both
|
||||
x
|
||||
(lambda (c) (char-set-contains? char-set:whitespace c)))
|
||||
x))
|
||||
(define (next) (reader 'next))
|
||||
(define (more) (read_form reader))
|
||||
(match (clean (reader 'peek))
|
||||
(() (throw 'mal-error "blank line")) ; FIXME: what should be returned?
|
||||
("'" (next) (list 'quote (more)))
|
||||
("`" (next) (list 'quasiquote (more)))
|
||||
("~" (next) (list 'unquote (more)))
|
||||
("~@" (next) (list 'splice-unquote (more)))
|
||||
("^" (next) (let ((meta (more))) `(with-meta ,(more) ,meta)))
|
||||
("@" (next) `(deref ,(more)))
|
||||
(")" (next) (throw 'mal-error "unexpected ')'"))
|
||||
("(" (next) (read_list reader))
|
||||
("]" (throw 'mal-error "unexpected ']'"))
|
||||
("[" (next) (read_vector reader))
|
||||
("}" (throw 'mal-error "unexpected '}'"))
|
||||
("{" (next) (read_hashmap reader))
|
||||
("" (next) (read_form reader))
|
||||
(else (read_atom reader))))
|
||||
|
||||
(define (read_str str)
|
||||
(if (eof-object? str)
|
||||
str
|
||||
(let* ((tokens (tokenizer str))
|
||||
(t (if (null? tokens)
|
||||
(if (char=? (string-ref str 0) #\;)
|
||||
'()
|
||||
(list str))
|
||||
tokens)))
|
||||
(read_form (make-Reader t)))))
|
32
guile/readline.scm
Normal file
32
guile/readline.scm
Normal file
@ -0,0 +1,32 @@
|
||||
;; 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/>.
|
||||
|
||||
;;(use-modules (ice-9 readline))
|
||||
|
||||
(library (readline)
|
||||
(export _readline)
|
||||
(import (guile) (ice-9 readline)))
|
||||
|
||||
(define mal-history
|
||||
(format #f "~a/.mal-history" (getenv "HOME")))
|
||||
|
||||
(setenv "GUILE_HISTORY" mal-history)
|
||||
(readline-set! bounce-parens 0)
|
||||
(activate-readline)
|
||||
|
||||
(define (_readline prompt)
|
||||
(let ((str (readline prompt)))
|
||||
(and (not (eof-object? str)) (add-history str))
|
||||
str))
|
32
guile/step0_repl.scm
Normal file
32
guile/step0_repl.scm
Normal file
@ -0,0 +1,32 @@
|
||||
;; 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/>.
|
||||
|
||||
(import (readline))
|
||||
|
||||
(define (READ) (_readline "user> "))
|
||||
|
||||
(define (EVAL ast env) ast)
|
||||
|
||||
(define (PRINT str)
|
||||
(and (not (eof-object? str))
|
||||
(format #t "~a~%" str)))
|
||||
|
||||
(define (LOOP continue?)
|
||||
(and continue? (REPL)))
|
||||
|
||||
(define (REPL)
|
||||
(LOOP (PRINT (EVAL (READ) '()))))
|
||||
|
||||
(REPL)
|
39
guile/step1_read_print.scm
Normal file
39
guile/step1_read_print.scm
Normal file
@ -0,0 +1,39 @@
|
||||
;; 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/>.
|
||||
|
||||
(import (readline) (reader) (printer))
|
||||
|
||||
(define (READ)
|
||||
(read_str (_readline "user> ")))
|
||||
|
||||
(define (EVAL ast env) ast)
|
||||
|
||||
(define (PRINT exp)
|
||||
(and (not (eof-object? exp))
|
||||
(format #t "~a~%" (pr_str exp #t))))
|
||||
|
||||
(define (LOOP continue?)
|
||||
(and continue? (REPL)))
|
||||
|
||||
(define (REPL)
|
||||
(LOOP
|
||||
(catch 'mal-error
|
||||
(lambda () (PRINT (EVAL (READ) '())))
|
||||
(lambda (k . e)
|
||||
(if (string=? (car e) "blank line")
|
||||
(display "")
|
||||
(format #t "Error: ~a~%" (car e)))))))
|
||||
|
||||
(REPL)
|
68
guile/step2_eval.scm
Normal file
68
guile/step2_eval.scm
Normal file
@ -0,0 +1,68 @@
|
||||
;; 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/>.
|
||||
|
||||
(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43))
|
||||
|
||||
(define *toplevel*
|
||||
`((+ . ,+)
|
||||
(- . ,-)
|
||||
(* . ,*)
|
||||
(/ . ,/)))
|
||||
|
||||
(define (READ)
|
||||
(read_str (_readline "user> ")))
|
||||
|
||||
(define (eval_ast ast env)
|
||||
(define (_eval x) (EVAL x env))
|
||||
(match ast
|
||||
((? symbol? sym)
|
||||
(or (assoc-ref env sym)
|
||||
(throw 'mal-error (format #f "'~a' not found" sym))))
|
||||
((? list? lst) (map _eval lst))
|
||||
((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec))
|
||||
((? hash-table? ht)
|
||||
(hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht)
|
||||
ht)
|
||||
(else ast)))
|
||||
|
||||
(define (eval_func ast env)
|
||||
(define expr (eval_ast ast env))
|
||||
(match expr
|
||||
(((? procedure? proc) args ...)
|
||||
(apply proc args))
|
||||
(else (throw 'mal-error (format #f "'~a' not found" (car expr))))))
|
||||
|
||||
(define (EVAL ast env)
|
||||
(match ast
|
||||
((? list?) (eval_func ast env))
|
||||
(else (eval_ast ast env))))
|
||||
|
||||
(define (PRINT exp)
|
||||
(and (not (eof-object? exp))
|
||||
(format #t "~a~%" (pr_str exp #t))))
|
||||
|
||||
(define (LOOP continue?)
|
||||
(and continue? (REPL)))
|
||||
|
||||
(define (REPL)
|
||||
(LOOP
|
||||
(catch 'mal-error
|
||||
(lambda () (PRINT (EVAL (READ) *toplevel*)))
|
||||
(lambda (k . e)
|
||||
(if (string=? (car e) "blank line")
|
||||
(display "")
|
||||
(format #t "Error: ~a~%" (car e)))))))
|
||||
|
||||
(REPL)
|
86
guile/step3_env.scm
Normal file
86
guile/step3_env.scm
Normal file
@ -0,0 +1,86 @@
|
||||
;; 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/>.
|
||||
|
||||
(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43)
|
||||
(srfi srfi-1) (ice-9 receive) (env))
|
||||
|
||||
(define *primitives*
|
||||
`((+ ,+)
|
||||
(- ,-)
|
||||
(* ,*)
|
||||
(/ ,/)))
|
||||
|
||||
(define *toplevel*
|
||||
(receive (b e) (unzip2 *primitives*)
|
||||
(make-Env #:binds b #:exprs e)))
|
||||
|
||||
(define (READ)
|
||||
(read_str (_readline "user> ")))
|
||||
|
||||
(define (eval_ast ast env)
|
||||
(define (_eval x) (EVAL x env))
|
||||
(match ast
|
||||
((? symbol? sym) (env-has sym env))
|
||||
((? list? lst) (map _eval lst))
|
||||
((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec))
|
||||
((? hash-table? ht)
|
||||
(hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht)
|
||||
ht)
|
||||
(else ast)))
|
||||
|
||||
(define (eval_func ast env)
|
||||
(define expr (eval_ast ast env))
|
||||
(match expr
|
||||
(((? procedure? proc) args ...)
|
||||
(apply proc args))
|
||||
(else (throw 'mal-error (format #f "'~a' not found" (car expr))))))
|
||||
|
||||
(define (EVAL ast env)
|
||||
(define (->list kvs) ((if (vector? kvs) vector->list identity) kvs))
|
||||
(define (%unzip2 kvs)
|
||||
(let lp((next kvs) (k '()) (v '()))
|
||||
(cond
|
||||
;; NOTE: reverse is very important here!
|
||||
((null? next) (values (reverse k) (reverse v)))
|
||||
((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs))
|
||||
(else (lp (cddr next) (cons (car next) k) (cons (cadr next) v))))))
|
||||
(match ast
|
||||
((? (lambda (x) (not (list? x)))) (eval_ast ast env))
|
||||
(('def! k v) ((env 'set) k (EVAL v env)))
|
||||
(('let* kvs body)
|
||||
(let* ((new-env (make-Env #:outer env))
|
||||
(setter (lambda (k v) ((new-env 'set) k (EVAL v new-env)))))
|
||||
(receive (keys vals) (%unzip2 (->list kvs))
|
||||
(for-each setter keys vals))
|
||||
(EVAL body new-env)))
|
||||
(else (eval_func ast env))))
|
||||
|
||||
(define (PRINT exp)
|
||||
(and (not (eof-object? exp))
|
||||
(format #t "~a~%" (pr_str exp #t))))
|
||||
|
||||
(define (LOOP continue?)
|
||||
(and continue? (REPL)))
|
||||
|
||||
(define (REPL)
|
||||
(LOOP
|
||||
(catch 'mal-error
|
||||
(lambda () (PRINT (EVAL (READ) *toplevel*)))
|
||||
(lambda (k . e)
|
||||
(if (string=? (car e) "blank line")
|
||||
(display "")
|
||||
(format #t "Error: ~a~%" (car e)))))))
|
||||
|
||||
(REPL)
|
100
guile/step4_if_fn_do.scm
Normal file
100
guile/step4_if_fn_do.scm
Normal file
@ -0,0 +1,100 @@
|
||||
;; 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/>.
|
||||
|
||||
(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43)
|
||||
(srfi srfi-1) (ice-9 receive) (env) (core) (types))
|
||||
|
||||
(define *toplevel*
|
||||
(receive (b e) (unzip2 core.ns)
|
||||
(make-Env #:binds b #:exprs e)))
|
||||
|
||||
(define (READ)
|
||||
(read_str (_readline "user> ")))
|
||||
|
||||
(define (eval_ast ast env)
|
||||
(define (_eval x) (EVAL x env))
|
||||
(match ast
|
||||
((? _nil? obj) obj)
|
||||
((? symbol? sym) (env-has sym env))
|
||||
((? list? lst) (map _eval lst))
|
||||
((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec))
|
||||
((? hash-table? ht)
|
||||
(hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht)
|
||||
ht)
|
||||
(else ast)))
|
||||
|
||||
(define (eval_func ast env)
|
||||
(define expr (eval_ast ast env))
|
||||
(match expr
|
||||
(((? procedure? proc) args ...)
|
||||
(apply proc args))
|
||||
(else (throw 'mal-error (format #f "'~a' not found" (car expr))))))
|
||||
|
||||
(define (eval_seq ast env)
|
||||
(cond
|
||||
((null? ast) nil)
|
||||
((null? (cdr ast)) (EVAL (car ast) env))
|
||||
(else
|
||||
(EVAL (car ast) env)
|
||||
(eval_seq (cdr ast) env))))
|
||||
|
||||
(define (EVAL ast env)
|
||||
(define (->list kvs) ((if (vector? kvs) vector->list identity) kvs))
|
||||
(define (%unzip2 kvs)
|
||||
(let lp((next kvs) (k '()) (v '()))
|
||||
(cond
|
||||
;; NOTE: reverse is very important here!
|
||||
((null? next) (values (reverse k) (reverse v)))
|
||||
((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs))
|
||||
(else (lp (cddr next) (cons (car next) k) (cons (cadr next) v))))))
|
||||
(match ast
|
||||
(('def! k v) ((env 'set) k (EVAL v env)))
|
||||
(('let* kvs body)
|
||||
(let* ((new-env (make-Env #:outer env))
|
||||
(setter (lambda (k v) ((new-env 'set) k (EVAL v new-env)))))
|
||||
(receive (keys vals) (%unzip2 (->list kvs))
|
||||
(for-each setter keys vals))
|
||||
(EVAL body new-env)))
|
||||
(('do rest ...) (eval_seq rest env))
|
||||
(('if cnd thn els ...)
|
||||
(cond
|
||||
((and (not (null? els)) (not (null? (cdr els))))
|
||||
;; Invalid `if' form
|
||||
(throw 'mal-error "failed to match any pattern in form " ast))
|
||||
((cond-true? (EVAL cnd env)) (EVAL thn env))
|
||||
(else (if (null? els) nil (EVAL (car els) env)))))
|
||||
(('fn* params body ...) ; function definition
|
||||
(lambda args
|
||||
(eval_seq body (make-Env #:outer env #:binds (->list params) #:exprs args))))
|
||||
((? list?) (eval_func ast env)) ; function calling
|
||||
(else (eval_ast ast env))))
|
||||
|
||||
(define (PRINT exp)
|
||||
(and (not (eof-object? exp))
|
||||
(format #t "~a~%" (pr_str exp #t))))
|
||||
|
||||
(define (LOOP continue?)
|
||||
(and continue? (REPL)))
|
||||
|
||||
(define (REPL)
|
||||
(LOOP
|
||||
(catch 'mal-error
|
||||
(lambda () (PRINT (EVAL (READ) *toplevel*)))
|
||||
(lambda (k . e)
|
||||
(if (string=? (car e) "blank line")
|
||||
(display "")
|
||||
(format #t "Error: ~a~%" (car e)))))))
|
||||
|
||||
(REPL)
|
129
guile/step5_tco.scm
Normal file
129
guile/step5_tco.scm
Normal file
@ -0,0 +1,129 @@
|
||||
;; 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/>.
|
||||
|
||||
(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43)
|
||||
(srfi srfi-1) (ice-9 receive) (env) (core) (types))
|
||||
|
||||
(define *toplevel*
|
||||
(receive (b e) (unzip2 core.ns)
|
||||
(make-Env #:binds b #:exprs e)))
|
||||
|
||||
(define (READ)
|
||||
(read_str (_readline "user> ")))
|
||||
|
||||
(define (eval_ast ast env)
|
||||
(define (_eval x) (EVAL x env))
|
||||
(match ast
|
||||
((? _nil? obj) obj)
|
||||
((? symbol? sym) (env-has sym env))
|
||||
((? list? lst) (map _eval lst))
|
||||
((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec))
|
||||
((? hash-table? ht)
|
||||
(hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht)
|
||||
ht)
|
||||
(else ast)))
|
||||
|
||||
(define (eval_func ast env)
|
||||
(define expr (eval_ast ast env))
|
||||
(match expr
|
||||
(((? procedure? proc) args ...)
|
||||
(apply proc args))
|
||||
(else (throw 'mal-error (format #f "'~a' not found" (car expr))))))
|
||||
|
||||
(define (eval_seq ast env)
|
||||
(cond
|
||||
((null? ast) nil)
|
||||
((null? (cdr ast)) (EVAL (car ast) env))
|
||||
(else
|
||||
(EVAL (car ast) env)
|
||||
(eval_seq (cdr ast) env))))
|
||||
|
||||
(define (EVAL ast env)
|
||||
(define (->list kvs) ((if (vector? kvs) vector->list identity) kvs))
|
||||
(define (%unzip2 kvs)
|
||||
(let lp((next kvs) (k '()) (v '()))
|
||||
(cond
|
||||
;; NOTE: reverse is very important here!
|
||||
((null? next) (values (reverse k) (reverse v)))
|
||||
((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs))
|
||||
(else (lp (cddr next) (cons (car next) k) (cons (cadr next) v))))))
|
||||
;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means
|
||||
;; it'll bring some trouble in control flow. We have to use continuations to return
|
||||
;; and use non-standard `break' feature. In a word, not elegant at all.
|
||||
;; The named let loop is natural for Scheme, but it looks a bit cheating. But NO!
|
||||
;; Such kind of loop is actually `while loop' in Scheme, I don't take advantage of
|
||||
;; TCO in Scheme to implement TCO, but it's the same principle with normal loop.
|
||||
;; If you're Lispy enough, there's no recursive at all while you saw named let loop.
|
||||
(let tco-loop((ast ast) (env env))
|
||||
(match ast
|
||||
(('def! k v) ((env 'set) k (EVAL v env)))
|
||||
(('let* kvs body)
|
||||
(let* ((new-env (make-Env #:outer env))
|
||||
(setter (lambda (k v) ((new-env 'set) k (EVAL v new-env)))))
|
||||
(receive (keys vals) (%unzip2 (->list kvs))
|
||||
(for-each setter keys vals))
|
||||
(tco-loop body new-env)))
|
||||
(('do rest ...)
|
||||
(cond
|
||||
((null? rest) (throw 'mal-error "do: Invalid form!" rest))
|
||||
((= 1 (length rest)) (tco-loop (car rest) env))
|
||||
(else
|
||||
(let ((mexpr (take rest (1- (length rest))))
|
||||
(tail-call (car (take-right rest 1))))
|
||||
(eval_seq mexpr env)
|
||||
(tco-loop tail-call env)))))
|
||||
(('if cnd thn els ...)
|
||||
(cond
|
||||
((and (not (null? els)) (not (null? (cdr els))))
|
||||
;; Invalid `if' form
|
||||
(throw 'mal-error "if: failed to match any pattern in form " ast))
|
||||
((cond-true? (EVAL cnd env)) (tco-loop thn env))
|
||||
(else (if (null? els) nil (tco-loop (car els) env)))))
|
||||
(('fn* params body ...) ; function definition
|
||||
(lambda args
|
||||
(let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args)))
|
||||
(cond
|
||||
((null? body) (throw 'mal-error "fn*: bad lambda in form " ast))
|
||||
((= 1 (length body)) (tco-loop (car body) nenv))
|
||||
(else
|
||||
(let ((mexpr (take body (1- (length body))))
|
||||
(tail-call (car (take-right body 1))))
|
||||
(eval_seq mexpr nenv)
|
||||
(tco-loop tail-call nenv)))))))
|
||||
((? list?) (eval_func ast env)) ; function calling
|
||||
(else (eval_ast ast env)))))
|
||||
|
||||
(define (PRINT exp)
|
||||
(and (not (eof-object? exp))
|
||||
(format #t "~a~%" (pr_str exp #t))))
|
||||
|
||||
(define (LOOP continue?)
|
||||
(and continue? (REPL)))
|
||||
|
||||
(define (REPL)
|
||||
(LOOP
|
||||
(catch 'mal-error
|
||||
(lambda () (PRINT (EVAL (READ) *toplevel*)))
|
||||
(lambda (k . e)
|
||||
(if (string=? (car e) "blank line")
|
||||
(display "")
|
||||
(format #t "Error: ~a~%" (car e)))))))
|
||||
|
||||
;; NOTE: we have to reduce stack size to pass step5 test
|
||||
((@ (system vm vm) call-with-stack-overflow-handler)
|
||||
1024
|
||||
(lambda () (REPL))
|
||||
(lambda k (throw 'mal-error "stack overflow")))
|
||||
|
138
guile/step6_file.scm
Normal file
138
guile/step6_file.scm
Normal file
@ -0,0 +1,138 @@
|
||||
;; 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/>.
|
||||
|
||||
(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43)
|
||||
(srfi srfi-1) (ice-9 receive) (env) (core) (types))
|
||||
|
||||
(define *toplevel*
|
||||
(receive (b e) (unzip2 core.ns)
|
||||
(make-Env #:binds b #:exprs e)))
|
||||
|
||||
(define (READ)
|
||||
(read_str (_readline "user> ")))
|
||||
|
||||
(define (eval_ast ast env)
|
||||
(define (_eval x) (EVAL x env))
|
||||
(match ast
|
||||
((? _nil? obj) obj)
|
||||
((? symbol? sym) (env-has sym env))
|
||||
((? list? lst) (map _eval lst))
|
||||
((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec))
|
||||
((? hash-table? ht)
|
||||
(hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht)
|
||||
ht)
|
||||
(else ast)))
|
||||
|
||||
(define (eval_func ast env)
|
||||
(define expr (eval_ast ast env))
|
||||
(match expr
|
||||
(((? procedure? proc) args ...)
|
||||
(apply proc args))
|
||||
(else (throw 'mal-error (format #f "'~a' not found" (car expr))))))
|
||||
|
||||
(define (eval_seq ast env)
|
||||
(cond
|
||||
((null? ast) nil)
|
||||
((null? (cdr ast)) (EVAL (car ast) env))
|
||||
(else
|
||||
(EVAL (car ast) env)
|
||||
(eval_seq (cdr ast) env))))
|
||||
|
||||
(define (EVAL ast env)
|
||||
(define (->list kvs) ((if (vector? kvs) vector->list identity) kvs))
|
||||
(define (%unzip2 kvs)
|
||||
(let lp((next kvs) (k '()) (v '()))
|
||||
(cond
|
||||
;; NOTE: reverse is very important here!
|
||||
((null? next) (values (reverse k) (reverse v)))
|
||||
((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs))
|
||||
(else (lp (cddr next) (cons (car next) k) (cons (cadr next) v))))))
|
||||
;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means
|
||||
;; it'll bring some trouble in control flow. We have to use continuations to return
|
||||
;; and use non-standard `break' feature. In a word, not elegant at all.
|
||||
;; The named let loop is natural for Scheme, but it looks a bit cheating. But NO!
|
||||
;; Such kind of loop is actually `while loop' in Scheme, I don't take advantage of
|
||||
;; TCO in Scheme to implement TCO, but it's the same principle with normal loop.
|
||||
;; If you're Lispy enough, there's no recursive at all while you saw named let loop.
|
||||
(let tco-loop((ast ast) (env env))
|
||||
(match ast
|
||||
(('def! k v) ((env 'set) k (EVAL v env)))
|
||||
(('let* kvs body)
|
||||
(let* ((new-env (make-Env #:outer env))
|
||||
(setter (lambda (k v) ((new-env 'set) k (EVAL v new-env)))))
|
||||
(receive (keys vals) (%unzip2 (->list kvs))
|
||||
(for-each setter keys vals))
|
||||
(tco-loop body new-env)))
|
||||
(('do rest ...)
|
||||
(cond
|
||||
((null? rest) (throw 'mal-error "do: Invalid form!" rest))
|
||||
((= 1 (length rest)) (tco-loop (car rest) env))
|
||||
(else
|
||||
(let ((mexpr (take rest (1- (length rest))))
|
||||
(tail-call (car (take-right rest 1))))
|
||||
(eval_seq mexpr env)
|
||||
(tco-loop tail-call env)))))
|
||||
(('if cnd thn els ...)
|
||||
(cond
|
||||
((and (not (null? els)) (not (null? (cdr els))))
|
||||
;; Invalid `if' form
|
||||
(throw 'mal-error "if: failed to match any pattern in form " ast))
|
||||
((cond-true? (EVAL cnd env)) (tco-loop thn env))
|
||||
(else (if (null? els) nil (tco-loop (car els) env)))))
|
||||
(('fn* params body ...) ; function definition
|
||||
(lambda args
|
||||
(let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args)))
|
||||
(cond
|
||||
((null? body) (throw 'mal-error "fn*: bad lambda in form " ast))
|
||||
((= 1 (length body)) (tco-loop (car body) nenv))
|
||||
(else
|
||||
(let ((mexpr (take body (1- (length body))))
|
||||
(tail-call (car (take-right body 1))))
|
||||
(eval_seq mexpr nenv)
|
||||
(tco-loop tail-call nenv)))))))
|
||||
((? list?) (eval_func ast env)) ; function calling
|
||||
(else (eval_ast ast env)))))
|
||||
|
||||
(define (EVAL-string str)
|
||||
(EVAL (read_str str) *toplevel*))
|
||||
|
||||
(define (PRINT exp)
|
||||
(and (not (eof-object? exp))
|
||||
(format #t "~a~%" (pr_str exp #t))))
|
||||
|
||||
(define (LOOP continue?)
|
||||
(and continue? (REPL)))
|
||||
|
||||
(define (REPL)
|
||||
(LOOP
|
||||
(catch 'mal-error
|
||||
(lambda () (PRINT (EVAL (READ) *toplevel*)))
|
||||
(lambda (k . e)
|
||||
(if (string=? (car e) "blank line")
|
||||
(display "")
|
||||
(format #t "Error: ~a~%" (car e)))))))
|
||||
|
||||
;; initialization
|
||||
((*toplevel* 'set) 'eval (lambda (ast) (EVAL ast *toplevel*)))
|
||||
((*toplevel* 'set) '*ARGV* '())
|
||||
(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
|
||||
|
||||
(let ((args (cdr (command-line))))
|
||||
(cond
|
||||
((> (length args) 0)
|
||||
(for-each (lambda (f) (EVAL-string (string-append "(load-file \"" f "\")"))) args))
|
||||
(else
|
||||
((*toplevel* 'set) '*ARGV* args)
|
||||
(REPL))))
|
156
guile/step7_quote.scm
Normal file
156
guile/step7_quote.scm
Normal file
@ -0,0 +1,156 @@
|
||||
;; 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/>.
|
||||
|
||||
(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43)
|
||||
(srfi srfi-1) (ice-9 receive) (env) (core) (types))
|
||||
|
||||
(define *toplevel*
|
||||
(receive (b e) (unzip2 core.ns)
|
||||
(make-Env #:binds b #:exprs (map (lambda (x) (make-func x)) e))))
|
||||
|
||||
(define (READ)
|
||||
(read_str (_readline "user> ")))
|
||||
|
||||
(define (eval_ast ast env)
|
||||
(define (_eval x) (EVAL x env))
|
||||
(match ast
|
||||
((? _nil? obj) obj)
|
||||
((? symbol? sym) (env-has sym env))
|
||||
((? list? lst) (map _eval lst))
|
||||
((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec))
|
||||
((? hash-table? ht)
|
||||
(hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht)
|
||||
ht)
|
||||
(else ast)))
|
||||
|
||||
(define (eval_func ast env)
|
||||
(define (_eval o) (EVAL o env))
|
||||
(define (func? x) (and=> ((env 'get) x) is-func?))
|
||||
(cond
|
||||
((func? (car ast))
|
||||
=> (lambda (f)
|
||||
(apply (callable-closure f) (map _eval (cdr ast)))))
|
||||
(else (throw 'mal-error (format #f "'~a' not found" (car ast))))))
|
||||
|
||||
(define (eval_seq ast env)
|
||||
(cond
|
||||
((null? ast) nil)
|
||||
((null? (cdr ast)) (EVAL (car ast) env))
|
||||
(else
|
||||
(EVAL (car ast) env)
|
||||
(eval_seq (cdr ast) env))))
|
||||
|
||||
(define (EVAL ast env)
|
||||
(define (%unzip2 kvs)
|
||||
(let lp((next kvs) (k '()) (v '()))
|
||||
(cond
|
||||
;; NOTE: reverse is very important here!
|
||||
((null? next) (values (reverse k) (reverse v)))
|
||||
((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs))
|
||||
(else (lp (cddr next) (cons (car next) k) (cons (cadr next) v))))))
|
||||
;; (define (_quasiquote ast)
|
||||
;; (define (non-pair? x) (not (pair? x)))
|
||||
;; (match ast
|
||||
;; ((? non-pair?) `(quote ,ast))
|
||||
;; (('unquote unq) unq)
|
||||
;; (((? pair? p) ('splice-unquote unqsp) rest ...)
|
||||
;; `(concat ,p ,unqsp ,(_quasiquote rest)))
|
||||
;; (else `(cons ,(_quasiquote (car ast)) ,(_quasiquote (cdr ast))))))
|
||||
(define (_quasiquote obj)
|
||||
(match obj
|
||||
((('unquote unq) rest ...) `(cons ,unq ,(_quasiquote rest)))
|
||||
(('unquote unq) unq)
|
||||
((('splice-unquote unqsp) rest ...) `(concat ,unqsp ,(_quasiquote rest)))
|
||||
((head rest ...) (list 'cons (list 'quote head) (_quasiquote rest)))
|
||||
(else `(quote ,obj))))
|
||||
;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means
|
||||
;; it'll bring some trouble in control flow. We have to use continuations to return
|
||||
;; and use non-standard `break' feature. In a word, not elegant at all.
|
||||
;; The named let loop is natural for Scheme, but it looks a bit cheating. But NO!
|
||||
;; Such kind of loop is actually `while loop' in Scheme, I don't take advantage of
|
||||
;; TCO in Scheme to implement TCO, but it's the same principle with normal loop.
|
||||
;; If you're Lispy enough, there's no recursive at all while you saw named let loop.
|
||||
(let tco-loop((ast ast) (env env))
|
||||
(match ast
|
||||
(('quote obj) obj)
|
||||
(('quasiquote obj) (EVAL (_quasiquote (->list obj)) env))
|
||||
(('def! k v) ((env 'set) k (EVAL v env)))
|
||||
(('let* kvs body)
|
||||
(let* ((new-env (make-Env #:outer env))
|
||||
(setter (lambda (k v) ((new-env 'set) k (EVAL v new-env)))))
|
||||
(receive (keys vals) (%unzip2 (->list kvs))
|
||||
(for-each setter keys vals))
|
||||
(tco-loop body new-env)))
|
||||
(('do rest ...)
|
||||
(cond
|
||||
((null? rest) (throw 'mal-error "do: Invalid form!" rest))
|
||||
((= 1 (length rest)) (tco-loop (car rest) env))
|
||||
(else
|
||||
(let ((mexpr (take rest (1- (length rest))))
|
||||
(tail-call (car (take-right rest 1))))
|
||||
(eval_seq mexpr env)
|
||||
(tco-loop tail-call env)))))
|
||||
(('if cnd thn els ...)
|
||||
(cond
|
||||
((and (not (null? els)) (not (null? (cdr els))))
|
||||
;; Invalid `if' form
|
||||
(throw 'mal-error "if: failed to match any pattern in form " ast))
|
||||
((cond-true? (EVAL cnd env)) (tco-loop thn env))
|
||||
(else (if (null? els) nil (tco-loop (car els) env)))))
|
||||
(('fn* params body ...) ; function definition
|
||||
(lambda args
|
||||
(let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args)))
|
||||
(cond
|
||||
((null? body) (throw 'mal-error "fn*: bad lambda in form " ast))
|
||||
((= 1 (length body)) (tco-loop (car body) nenv))
|
||||
(else
|
||||
(let ((mexpr (take body (1- (length body))))
|
||||
(tail-call (car (take-right body 1))))
|
||||
(eval_seq mexpr nenv)
|
||||
(tco-loop tail-call nenv)))))))
|
||||
((? list?) (eval_func ast env)) ; function calling
|
||||
(else (eval_ast ast env)))))
|
||||
|
||||
(define (EVAL-string str)
|
||||
(EVAL (read_str str) *toplevel*))
|
||||
|
||||
(define (PRINT exp)
|
||||
(and (not (eof-object? exp))
|
||||
(format #t "~a~%" (pr_str exp #t))))
|
||||
|
||||
(define (LOOP continue?)
|
||||
(and continue? (REPL)))
|
||||
|
||||
(define (REPL)
|
||||
(LOOP
|
||||
(catch 'mal-error
|
||||
(lambda () (PRINT (EVAL (READ) *toplevel*)))
|
||||
(lambda (k . e)
|
||||
(if (string=? (car e) "blank line")
|
||||
(display "")
|
||||
(format #t "Error: ~a~%" (car e)))))))
|
||||
|
||||
;; initialization
|
||||
((*toplevel* 'set) 'eval (lambda (ast) (EVAL ast *toplevel*)))
|
||||
((*toplevel* 'set) '*ARGV* '())
|
||||
(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
|
||||
|
||||
(let ((args (cdr (command-line))))
|
||||
(cond
|
||||
((> (length args) 0)
|
||||
(for-each (lambda (f) (EVAL-string (string-append "(load-file \"" f "\")"))) args))
|
||||
(else
|
||||
((*toplevel* 'set) '*ARGV* args)
|
||||
(REPL))))
|
170
guile/step8_macros.scm
Normal file
170
guile/step8_macros.scm
Normal file
@ -0,0 +1,170 @@
|
||||
;; 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/>.
|
||||
|
||||
(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43)
|
||||
(srfi srfi-1) (ice-9 receive) (env) (core) (types))
|
||||
|
||||
(define *toplevel*
|
||||
(receive (b e) (unzip2 core.ns)
|
||||
(make-Env #:binds b #:exprs (map (lambda (x) (make-func x)) e))))
|
||||
|
||||
(define (READ)
|
||||
(read_str (_readline "user> ")))
|
||||
|
||||
(define (eval_ast ast env)
|
||||
(define (_eval x) (EVAL x env))
|
||||
(match ast
|
||||
((? _nil? obj) obj)
|
||||
((? symbol? sym) (env-has sym env))
|
||||
((? list? lst) (map _eval lst))
|
||||
((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec))
|
||||
((? hash-table? ht)
|
||||
(hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht)
|
||||
ht)
|
||||
(else ast)))
|
||||
|
||||
(define (eval_func ast env)
|
||||
(define (_eval o) (EVAL o env))
|
||||
(define (func? x) (and=> ((env 'get) x) is-func?))
|
||||
(cond
|
||||
((func? (car ast))
|
||||
=> (lambda (c)
|
||||
(callable-apply c (map _eval (cdr ast)))))
|
||||
(else (throw 'mal-error (format #f "'~a' not found" (car ast))))))
|
||||
|
||||
(define (eval_seq ast env)
|
||||
(cond
|
||||
((null? ast) nil)
|
||||
((null? (cdr ast)) (EVAL (car ast) env))
|
||||
(else
|
||||
(EVAL (car ast) env)
|
||||
(eval_seq (cdr ast) env))))
|
||||
|
||||
(define (is_macro_call ast env)
|
||||
(and (list? ast)
|
||||
(and=> (env-check (car ast) env) is-macro?)))
|
||||
|
||||
(define (_macroexpand ast env)
|
||||
(cond
|
||||
((is_macro_call ast env)
|
||||
=> (lambda (c)
|
||||
;; NOTE: Macros are normal-order, so we shouldn't eval args here.
|
||||
;; Or it's applicable-order.
|
||||
(_macroexpand (callable-apply c (cdr ast)) env)))
|
||||
(else ast)))
|
||||
|
||||
(define (EVAL ast env)
|
||||
(define (%unzip2 kvs)
|
||||
(let lp((next kvs) (k '()) (v '()))
|
||||
(cond
|
||||
;; NOTE: reverse is very important here!
|
||||
((null? next) (values (reverse k) (reverse v)))
|
||||
((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs))
|
||||
(else (lp (cddr next) (cons (car next) k) (cons (cadr next) v))))))
|
||||
(define (_quasiquote obj)
|
||||
(match obj
|
||||
((('unquote unq) rest ...) `(cons ,unq ,(_quasiquote rest)))
|
||||
(('unquote unq) unq)
|
||||
((('splice-unquote unqsp) rest ...) `(concat ,unqsp ,(_quasiquote rest)))
|
||||
((head rest ...) (list 'cons (_quasiquote head) (_quasiquote rest)))
|
||||
(else `(quote ,obj))))
|
||||
;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means
|
||||
;; it'll bring some trouble in control flow. We have to use continuations to return
|
||||
;; and use non-standard `break' feature. In a word, not elegant at all.
|
||||
;; The named let loop is natural for Scheme, but it looks a bit cheating. But NO!
|
||||
;; Such kind of loop is actually `while loop' in Scheme, I don't take advantage of
|
||||
;; TCO in Scheme to implement TCO, but it's the same principle with normal loop.
|
||||
;; If you're Lispy enough, there's no recursive at all while you saw named let loop.
|
||||
(let tco-loop((ast ast) (env env)) ; expand as possible
|
||||
(let ((ast (_macroexpand ast env)))
|
||||
(match ast
|
||||
((? non-list?) (eval_ast ast env))
|
||||
(('defmacro! k v)
|
||||
(let ((c (EVAL v env)))
|
||||
(callable-is_macro-set! c #t)
|
||||
((env 'set) k c)))
|
||||
(('macroexpand obj) (_macroexpand obj env))
|
||||
(('quote obj) obj)
|
||||
(('quasiquote obj) (EVAL (_quasiquote (->list obj)) env))
|
||||
(('def! k v) ((env 'set) k (EVAL v env)))
|
||||
(('let* kvs body)
|
||||
(let* ((new-env (make-Env #:outer env))
|
||||
(setter (lambda (k v) ((new-env 'set) k (EVAL v new-env)))))
|
||||
(receive (keys vals) (%unzip2 (->list kvs))
|
||||
(for-each setter keys vals))
|
||||
(tco-loop body new-env)))
|
||||
(('do rest ...)
|
||||
(cond
|
||||
((null? rest) (throw 'mal-error "do: Invalid form!" rest))
|
||||
((= 1 (length rest)) (tco-loop (car rest) env))
|
||||
(else
|
||||
(let ((mexpr (take rest (1- (length rest))))
|
||||
(tail-call (car (take-right rest 1))))
|
||||
(eval_seq mexpr env)
|
||||
(tco-loop tail-call env)))))
|
||||
(('if cnd thn els ...)
|
||||
(cond
|
||||
((and (not (null? els)) (not (null? (cdr els))))
|
||||
;; Invalid `if' form
|
||||
(throw 'mal-error "if: failed to match any pattern in form " ast))
|
||||
((cond-true? (EVAL cnd env)) (tco-loop thn env))
|
||||
(else (if (null? els) nil (tco-loop (car els) env)))))
|
||||
(('fn* params body ...) ; function definition
|
||||
(make-func
|
||||
(lambda args
|
||||
(let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args)))
|
||||
(cond
|
||||
((null? body) (throw 'mal-error "fn*: bad lambda in form " ast))
|
||||
((= 1 (length body)) (tco-loop (car body) nenv))
|
||||
(else
|
||||
(let ((mexpr (take body (1- (length body))))
|
||||
(tail-call (car (take-right body 1))))
|
||||
(eval_seq mexpr nenv)
|
||||
(tco-loop tail-call nenv))))))))
|
||||
(else (eval_func ast env))))))
|
||||
|
||||
(define (EVAL-string str)
|
||||
(EVAL (read_str str) *toplevel*))
|
||||
|
||||
(define (PRINT exp)
|
||||
(and (not (eof-object? exp))
|
||||
(format #t "~a~%" (pr_str exp #t))))
|
||||
|
||||
(define (LOOP continue?)
|
||||
(and continue? (REPL)))
|
||||
|
||||
(define (REPL)
|
||||
(LOOP
|
||||
(catch 'mal-error
|
||||
(lambda () (PRINT (EVAL (READ) *toplevel*)))
|
||||
(lambda (k . e)
|
||||
(if (string=? (car e) "blank line")
|
||||
(display "")
|
||||
(format #t "Error: ~a~%" (car e)))))))
|
||||
|
||||
;; initialization
|
||||
((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*))))
|
||||
((*toplevel* 'set) '*ARGV* '())
|
||||
(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
|
||||
(EVAL-string "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))")
|
||||
(EVAL-string "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))")
|
||||
|
||||
(let ((args (cdr (command-line))))
|
||||
(cond
|
||||
((> (length args) 0)
|
||||
(for-each (lambda (f) (EVAL-string (string-append "(load-file \"" f "\")"))) args))
|
||||
(else
|
||||
((*toplevel* 'set) '*ARGV* args)
|
||||
(REPL))))
|
182
guile/step9_try.scm
Normal file
182
guile/step9_try.scm
Normal file
@ -0,0 +1,182 @@
|
||||
;; 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/>.
|
||||
|
||||
(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43)
|
||||
(srfi srfi-1) (ice-9 receive) (env) (core) (types))
|
||||
|
||||
(define *toplevel*
|
||||
(receive (b e) (unzip2 core.ns)
|
||||
(make-Env #:binds b #:exprs (map (lambda (x) (make-func x)) e))))
|
||||
|
||||
(define (READ)
|
||||
(read_str (_readline "user> ")))
|
||||
|
||||
(define (eval_ast ast env)
|
||||
(define (_eval x) (EVAL x env))
|
||||
(match ast
|
||||
((? _nil? obj) obj)
|
||||
((? symbol? sym) (env-has sym env))
|
||||
((? list? lst) (map _eval lst))
|
||||
((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec))
|
||||
((? hash-table? ht)
|
||||
(hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht)
|
||||
ht)
|
||||
(else ast)))
|
||||
|
||||
(define (eval_func ast env)
|
||||
(define (_eval o) (EVAL o env))
|
||||
(define (func? x) (and=> (env-check x env) is-func?))
|
||||
;;(format #t "AAA: ~a~%" (func? (car ast)))
|
||||
(cond
|
||||
((func? (car ast))
|
||||
=> (lambda (c)
|
||||
(callable-apply c (map _eval (cdr ast)))))
|
||||
(else (throw 'mal-error (format #f "'~a' not found" (car ast))))))
|
||||
|
||||
(define (eval_seq ast env)
|
||||
(cond
|
||||
((null? ast) nil)
|
||||
((null? (cdr ast)) (EVAL (car ast) env))
|
||||
(else
|
||||
(EVAL (car ast) env)
|
||||
(eval_seq (cdr ast) env))))
|
||||
|
||||
(define (is_macro_call ast env)
|
||||
(and (list? ast)
|
||||
(and=> (env-check (car ast) env) is-macro?)))
|
||||
|
||||
(define (_macroexpand ast env)
|
||||
(cond
|
||||
((is_macro_call ast env)
|
||||
=> (lambda (c)
|
||||
;;(format #t "AAA: ~a, ~a~%" ast (_macroexpand (callable-apply c (cdr ast)) env))
|
||||
;;(format #t "BBB: ~a~%" (_macroexpand (callable-apply c (cdr ast)) env))
|
||||
;; NOTE: Macros are normal-order, so we shouldn't eval args here.
|
||||
;; Or it's applicable-order.
|
||||
(_macroexpand (callable-apply c (cdr ast)) env)))
|
||||
(else ast)))
|
||||
|
||||
(define (EVAL ast env)
|
||||
(define (%unzip2 kvs)
|
||||
(let lp((next kvs) (k '()) (v '()))
|
||||
(cond
|
||||
;; NOTE: reverse is very important here!
|
||||
((null? next) (values (reverse k) (reverse v)))
|
||||
((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs))
|
||||
(else (lp (cddr next) (cons (car next) k) (cons (cadr next) v))))))
|
||||
(define (_quasiquote obj)
|
||||
(match obj
|
||||
((('unquote unq) rest ...) `(cons ,unq ,(_quasiquote rest)))
|
||||
(('unquote unq) unq)
|
||||
((('splice-unquote unqsp) rest ...) `(concat ,unqsp ,(_quasiquote rest)))
|
||||
((head rest ...) (list 'cons (_quasiquote head) (_quasiquote rest)))
|
||||
(else `(quote ,obj))))
|
||||
;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means
|
||||
;; it'll bring some trouble in control flow. We have to use continuations to return
|
||||
;; and use non-standard `break' feature. In a word, not elegant at all.
|
||||
;; The named let loop is natural for Scheme, but it looks a bit cheating. But NO!
|
||||
;; Such kind of loop is actually `while loop' in Scheme, I don't take advantage of
|
||||
;; TCO in Scheme to implement TCO, but it's the same principle with normal loop.
|
||||
;; If you're Lispy enough, there's no recursive at all while you saw named let loop.
|
||||
(let tco-loop((ast ast) (env env)) ; expand as possible
|
||||
;;(format #t "CCC: ~a === ~a~%" ast (_macroexpand ast env))
|
||||
(let ((ast (_macroexpand ast env)))
|
||||
(match ast
|
||||
((? non-list?) (eval_ast ast env))
|
||||
(('defmacro! k v)
|
||||
(let ((c (EVAL v env)))
|
||||
(callable-is_macro-set! c #t)
|
||||
((env 'set) k c)))
|
||||
(('macroexpand obj) (_macroexpand obj env))
|
||||
(('quote obj) obj)
|
||||
(('quasiquote obj) (EVAL (_quasiquote (->list obj)) env))
|
||||
(('def! k v) ((env 'set) k (EVAL v env)))
|
||||
(('let* kvs body)
|
||||
(let* ((new-env (make-Env #:outer env))
|
||||
(setter (lambda (k v) ((new-env 'set) k (EVAL v new-env)))))
|
||||
(receive (keys vals) (%unzip2 (->list kvs))
|
||||
(for-each setter keys vals))
|
||||
(tco-loop body new-env)))
|
||||
(('do rest ...)
|
||||
(cond
|
||||
((null? rest) (throw 'mal-error "do: Invalid form!" rest))
|
||||
((= 1 (length rest)) (tco-loop (car rest) env))
|
||||
(else
|
||||
(let ((mexpr (take rest (1- (length rest))))
|
||||
(tail-call (car (take-right rest 1))))
|
||||
(eval_seq mexpr env)
|
||||
(tco-loop tail-call env)))))
|
||||
(('if cnd thn els ...)
|
||||
(cond
|
||||
((and (not (null? els)) (not (null? (cdr els))))
|
||||
;; Invalid `if' form
|
||||
(throw 'mal-error "if: failed to match any pattern in form " ast))
|
||||
((cond-true? (EVAL cnd env)) (tco-loop thn env))
|
||||
(else (if (null? els) nil (tco-loop (car els) env)))))
|
||||
(('fn* params body ...) ; function definition
|
||||
(make-func
|
||||
(lambda args
|
||||
(let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args)))
|
||||
(cond
|
||||
((null? body) (throw 'mal-error "fn*: bad lambda in form " ast))
|
||||
((= 1 (length body)) (tco-loop (car body) nenv))
|
||||
(else
|
||||
(let ((mexpr (take body (1- (length body))))
|
||||
(tail-call (car (take-right body 1))))
|
||||
(eval_seq mexpr nenv)
|
||||
(tco-loop tail-call nenv))))))))
|
||||
(('try* A ('catch* B C))
|
||||
(catch
|
||||
#t
|
||||
(lambda () (EVAL A env))
|
||||
(lambda e
|
||||
(let ((nenv (make-Env #:outer env #:binds (list B) #:exprs (cdr e))))
|
||||
(EVAL C nenv)))))
|
||||
(else (eval_func ast env))))))
|
||||
|
||||
(define (EVAL-string str)
|
||||
(EVAL (read_str str) *toplevel*))
|
||||
|
||||
(define (PRINT exp)
|
||||
(and (not (eof-object? exp))
|
||||
(format #t "~a~%" (pr_str exp #t))))
|
||||
|
||||
(define (LOOP continue?)
|
||||
(and continue? (REPL)))
|
||||
|
||||
(define (REPL)
|
||||
(LOOP
|
||||
(catch 'mal-error
|
||||
(lambda () (PRINT (EVAL (READ) *toplevel*)))
|
||||
(lambda (k . e)
|
||||
(if (string=? (car e) "blank line")
|
||||
(display "")
|
||||
(format #t "Error: ~a~%" (car e)))))))
|
||||
|
||||
;; initialization
|
||||
((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*))))
|
||||
((*toplevel* 'set) 'throw (make-func (lambda (val) (throw 'mal-error val))))
|
||||
((*toplevel* 'set) '*ARGV* '())
|
||||
(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
|
||||
(EVAL-string "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))")
|
||||
(EVAL-string "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))")
|
||||
|
||||
(let ((args (cdr (command-line))))
|
||||
(cond
|
||||
((> (length args) 0)
|
||||
(for-each (lambda (f) (EVAL-string (string-append "(load-file \"" f "\")"))) args))
|
||||
(else
|
||||
((*toplevel* 'set) '*ARGV* args)
|
||||
(REPL))))
|
206
guile/stepA_mal.scm
Normal file
206
guile/stepA_mal.scm
Normal file
@ -0,0 +1,206 @@
|
||||
;; 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/>.
|
||||
|
||||
(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43)
|
||||
(srfi srfi-1) (ice-9 receive) (env) (core) (types))
|
||||
|
||||
;; Primitives which doesn't unbox args in default.
|
||||
;; This is a trick to implement meta-info taking advange of the original
|
||||
;; types of Guile as possible.
|
||||
(define *unbox-exception* '(meta assoc swap!))
|
||||
|
||||
(define *toplevel*
|
||||
(receive (b e) (unzip2 core.ns)
|
||||
(let ((env (make-Env #:binds b #:exprs (map (lambda (x) (make-func x)) e))))
|
||||
(for-each (lambda (f)
|
||||
(callable-unbox-set! ((env 'get) f) #f))
|
||||
*unbox-exception*)
|
||||
env)))
|
||||
|
||||
(define (READ)
|
||||
(read_str (_readline "user> ")))
|
||||
|
||||
(define (eval_ast ast env)
|
||||
(define (_eval x) (EVAL x env))
|
||||
(match ast
|
||||
((? symbol? sym) (env-has sym env))
|
||||
((? list? lst) (map _eval lst))
|
||||
((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec))
|
||||
((? hash-table? ht)
|
||||
;; NOTE: we must allocate a new hashmap here to avoid any side-effects, or
|
||||
;; there'll be strange bugs!!!
|
||||
(list->hash-map (hash-fold (lambda (k v p) (cons k (cons (_eval v) p))) '() ht)))
|
||||
(else ast)))
|
||||
|
||||
(define (eval_func ast env)
|
||||
(define (_eval o) (EVAL o env))
|
||||
(define (func? x)
|
||||
(let ((f (if (list? x)
|
||||
(EVAL x env)
|
||||
x)))
|
||||
(if (callable? f)
|
||||
f
|
||||
(and=> (env-check f env) is-func?))))
|
||||
(cond
|
||||
((func? (car ast))
|
||||
=> (lambda (c)
|
||||
(callable-apply c (map _eval (cdr ast)))))
|
||||
(else (throw 'mal-error (format #f "'~a' not found" (car ast))))))
|
||||
|
||||
(define (eval_seq ast env)
|
||||
(cond
|
||||
((null? ast) nil)
|
||||
((null? (cdr ast)) (EVAL (car ast) env))
|
||||
(else
|
||||
(EVAL (car ast) env)
|
||||
(eval_seq (cdr ast) env))))
|
||||
|
||||
(define (is_macro_call ast env)
|
||||
(and (list? ast)
|
||||
(and=> (env-check (car ast) env) is-macro?)))
|
||||
|
||||
(define (_macroexpand ast env)
|
||||
(cond
|
||||
((is_macro_call ast env)
|
||||
=> (lambda (c)
|
||||
;; NOTE: Macros are normal-order, so we shouldn't eval args here.
|
||||
;; Or it's applicable-order.
|
||||
(_macroexpand (callable-apply c (cdr ast)) env)))
|
||||
(else ast)))
|
||||
|
||||
(define (EVAL ast env)
|
||||
(define (%unzip2 kvs)
|
||||
(let lp((next kvs) (k '()) (v '()))
|
||||
(cond
|
||||
;; NOTE: reverse is very important here!
|
||||
((null? next) (values (reverse k) (reverse v)))
|
||||
((null? (cdr next))
|
||||
(throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs)))
|
||||
(else (lp (cddr next) (cons (car next) k) (cons (cadr next) v))))))
|
||||
(define (_quasiquote obj)
|
||||
(match obj
|
||||
((('unquote unq) rest ...) `(cons ,unq ,(_quasiquote rest)))
|
||||
(('unquote unq) unq)
|
||||
((('splice-unquote unqsp) rest ...) `(concat ,unqsp ,(_quasiquote rest)))
|
||||
((head rest ...) (list 'cons (_quasiquote head) (_quasiquote rest)))
|
||||
(else `(quote ,obj))))
|
||||
;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means
|
||||
;; it'll bring some trouble in control flow. We have to use continuations to return
|
||||
;; and use non-standard `break' feature. In a word, not elegant at all.
|
||||
;; The named let loop is natural for Scheme, but it looks a bit cheating. But NO!
|
||||
;; Such kind of loop is actually `while loop' in Scheme, I don't take advantage of
|
||||
;; TCO in Scheme to implement TCO, but it's the same principle with normal loop.
|
||||
;; If you're Lispy enough, there's no recursive at all while you saw named let loop.
|
||||
(let tco-loop((ast ast) (env env)) ; expand as possible
|
||||
(let ((ast (_macroexpand ast env)))
|
||||
(match ast
|
||||
((? non-list?) (eval_ast ast env))
|
||||
(('defmacro! k v)
|
||||
(let ((c (EVAL v env)))
|
||||
(callable-is_macro-set! c #t)
|
||||
((env 'set) k c)))
|
||||
(('macroexpand obj) (_macroexpand obj env))
|
||||
(('quote obj) obj)
|
||||
(('quasiquote obj) (EVAL (_quasiquote (->list obj)) env))
|
||||
(('def! k v) ((env 'set) k (EVAL v env)))
|
||||
(('let* kvs body)
|
||||
(let* ((new-env (make-Env #:outer env))
|
||||
(setter (lambda (k v) ((new-env 'set) k (EVAL v new-env)))))
|
||||
(receive (keys vals) (%unzip2 (->list kvs))
|
||||
(for-each setter keys vals))
|
||||
(tco-loop body new-env)))
|
||||
(('do rest ...)
|
||||
(cond
|
||||
((null? rest)
|
||||
(throw 'mal-error (format #f "do: Invalid form! '~a'" rest)))
|
||||
((= 1 (length rest)) (tco-loop (car rest) env))
|
||||
(else
|
||||
(let ((mexpr (take rest (1- (length rest))))
|
||||
(tail-call (car (take-right rest 1))))
|
||||
(eval_seq mexpr env)
|
||||
(tco-loop tail-call env)))))
|
||||
(('if cnd thn els ...)
|
||||
(cond
|
||||
((and (not (null? els)) (not (null? (cdr els))))
|
||||
;; Invalid `if' form
|
||||
(throw 'mal-error
|
||||
(format #f "if: failed to match any pattern in form '~a'" ast)))
|
||||
((cond-true? (EVAL cnd env)) (tco-loop thn env))
|
||||
(else (if (null? els) nil (tco-loop (car els) env)))))
|
||||
(('fn* params body ...) ; function definition
|
||||
(make-anonymous-func
|
||||
(lambda args
|
||||
(let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args)))
|
||||
(cond
|
||||
((null? body)
|
||||
(throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast)))
|
||||
((= 1 (length body)) (tco-loop (car body) nenv))
|
||||
(else
|
||||
(let ((mexpr (take body (1- (length body))))
|
||||
(tail-call (car (take-right body 1))))
|
||||
(eval_seq mexpr nenv)
|
||||
(tco-loop tail-call nenv))))))))
|
||||
(('try* A ('catch* B C))
|
||||
(catch
|
||||
#t
|
||||
(lambda () (EVAL A env))
|
||||
(lambda (k . e)
|
||||
(case k
|
||||
((mal-error)
|
||||
(let ((nenv (make-Env #:outer env #:binds (list B) #:exprs e)))
|
||||
(EVAL C nenv)))
|
||||
;; TODO: add backtrace
|
||||
(else (print-exception (current-output-port) #f k e))))))
|
||||
(else (eval_func ast env))))))
|
||||
|
||||
(define (EVAL-string str)
|
||||
(EVAL (read_str str) *toplevel*))
|
||||
|
||||
(define (PRINT exp)
|
||||
(and (not (eof-object? exp))
|
||||
(format #t "~a~%" (pr_str exp #t))))
|
||||
|
||||
(define (LOOP continue?)
|
||||
(and continue? (REPL)))
|
||||
|
||||
(define (REPL)
|
||||
(LOOP
|
||||
(catch #t
|
||||
(lambda () (PRINT (EVAL (READ) *toplevel*)))
|
||||
(lambda (k . e)
|
||||
(case k
|
||||
((mal-error)
|
||||
(if (string=? (car e) "blank line")
|
||||
(display "")
|
||||
(format #t "Error: ~a~%" (car e))))
|
||||
(else (print-exception (current-output-port) #f k e)))))))
|
||||
|
||||
;; initialization
|
||||
((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*))))
|
||||
((*toplevel* 'set) 'throw (make-func (lambda (val) (throw 'mal-error val))))
|
||||
((*toplevel* 'set) '*ARGV* '())
|
||||
(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
|
||||
(EVAL-string "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))")
|
||||
(EVAL-string "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))")
|
||||
(EVAL-string "(def! *host-language* \"guile\")")
|
||||
|
||||
(let ((args (cdr (command-line))))
|
||||
(cond
|
||||
((> (length args) 0)
|
||||
(for-each (lambda (f) (EVAL-string (string-append "(load-file \"" f "\")"))) args))
|
||||
(else
|
||||
((*toplevel* 'set) '*ARGV* args)
|
||||
(EVAL-string "(println (str \"Mal (\" *host-language* \")\"))")
|
||||
(REPL))))
|
101
guile/types.scm
Normal file
101
guile/types.scm
Normal file
@ -0,0 +1,101 @@
|
||||
;; 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 (types)
|
||||
(export string-sub *eof* non-list?
|
||||
string->keyword _keyword?
|
||||
nil _nil? list->hash-map
|
||||
cond-true? make-anonymous-func
|
||||
make-atom atom? atom-val atom-val-set!
|
||||
make-callable callable? callable-is_macro
|
||||
callable-is_macro-set! callable-closure
|
||||
is-func? is-macro? make-func callable-apply
|
||||
callable-unbox-set! callable-unbox
|
||||
callable-meta-info hash-table-clone
|
||||
box? box unbox)
|
||||
(import (guile) (only (rnrs) define-record-type) (ice-9 regex) (ice-9 session)))
|
||||
|
||||
(define (non-list? x) (not (list? x)))
|
||||
|
||||
|
||||
(define (string-sub str p1 p2)
|
||||
(regexp-substitute/global #f p1 str 'pre p2 'post))
|
||||
|
||||
(define *eof* (call-with-input-string "" read))
|
||||
|
||||
(define (string->keyword str)
|
||||
(when (not (string? str))
|
||||
(throw 'mal-error (format #f "string->keyword: '~a' is not a string" str)))
|
||||
(string-append "\u029e" str))
|
||||
|
||||
(define (_keyword? k)
|
||||
(and (string? k) (if (string-match "^\u029e" k) #t #f)))
|
||||
|
||||
(define-record-type mal-nil)
|
||||
|
||||
(define nil (make-mal-nil))
|
||||
|
||||
(define (_nil? obj) (mal-nil? obj))
|
||||
|
||||
(define (cond-true? obj)
|
||||
(and (not (_nil? obj)) obj))
|
||||
|
||||
(define-record-type atom (fields (mutable val)))
|
||||
|
||||
(define-record-type callable
|
||||
(fields
|
||||
meta-info
|
||||
(mutable unbox)
|
||||
(mutable is_macro)
|
||||
closure))
|
||||
|
||||
(define (make-func closure) (make-callable nil #t #f closure))
|
||||
(define (make-anonymous-func closure) (make-callable nil #f #f closure))
|
||||
|
||||
(define (callable-apply c arglst)
|
||||
(apply (callable-closure c) (if (callable-unbox c) (map unbox arglst) arglst)))
|
||||
|
||||
(define (callable-check c b)
|
||||
(and (callable? c)
|
||||
(eq? (callable-is_macro c) b)
|
||||
c))
|
||||
|
||||
(define (is-func? c) (callable-check c #f))
|
||||
(define (is-macro? c) (callable-check c #t))
|
||||
|
||||
(define (hash-table-clone ht)
|
||||
(list->hash-map (hash-fold (lambda (k v p) (cons k (cons v p))) '() ht)))
|
||||
|
||||
(define-record-type box (fields val))
|
||||
|
||||
(define (box o) (make-box o))
|
||||
(define (unbox o)
|
||||
(if (box? o) (box-val o) o))
|
||||
|
||||
(define* (list->hash-map lst #:optional (ht (make-hash-table)))
|
||||
(cond
|
||||
((null? lst) ht)
|
||||
(else
|
||||
(let lp((next lst))
|
||||
(cond
|
||||
((null? next) ht)
|
||||
(else
|
||||
(when (null? (cdr next))
|
||||
(throw 'mal-error
|
||||
(format #f "hash-map: '~a' lack of value" (car next))))
|
||||
(let ((k (car next))
|
||||
(v (cadr next)))
|
||||
(hash-set! ht k v)
|
||||
(lp (cddr next)))))))))
|
Loading…
Reference in New Issue
Block a user