kanaka/mal
1
1
Fork 0
mirror of https://github.com/kanaka/mal.git synced 2024-10-26 14:22:25 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #56 from NalaGinrut/master

Browse Source 
Added GNU Guile implementation
This commit is contained in:
Joel Martin 2015-04-06 15:18:50 -05:00
commit 9f21caf388
21 changed files with 2095 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
Makefile
View File

@ -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

9
README.md
View File

@ -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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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)))))))))