kanaka/mal
1
1
Fork 0
mirror of https://github.com/kanaka/mal.git synced 2024-09-21 10:37:58 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #273 from wasamasa/r7rs-implementation

Browse Source 
R7RS implementation
This commit is contained in:
Joel Martin 2017-09-13 14:55:48 -05:00 committed by GitHub
commit de37556cd2
26 changed files with 2442 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.travis.yml
View File

@ -71,6 +71,13 @@ matrix:
- {env: IMPL=ruby, services: [docker]} - {env: IMPL=ruby, services: [docker]}
- {env: IMPL=rust, services: [docker]} - {env: IMPL=rust, services: [docker]}
- {env: IMPL=scala, services: [docker]} - {env: IMPL=scala, services: [docker]}
- {env: IMPL=scheme scheme_MODE=chibi, services: [docker]}
- {env: IMPL=scheme scheme_MODE=kawa, services: [docker]}
- {env: IMPL=scheme scheme_MODE=gauche, services: [docker]}
- {env: IMPL=scheme scheme_MODE=chicken, services: [docker]}
- {env: IMPL=scheme scheme_MODE=sagittarius, services: [docker]}
- {env: IMPL=scheme scheme_MODE=cyclone, services: [docker]}
# - {env: IMPL=scheme scheme_MODE=foment, services: [docker]}
- {env: IMPL=skew, services: [docker]} - {env: IMPL=skew, services: [docker]}
- {env: IMPL=swift NO_DOCKER=1, os: osx, osx_image: xcode7} - {env: IMPL=swift NO_DOCKER=1, os: osx, osx_image: xcode7}
- {env: IMPL=swift3, services: [docker]} - {env: IMPL=swift3, services: [docker]}

15
Makefile
View File

@ -52,6 +52,8 @@ haxe_MODE = neko
matlab_MODE = octave matlab_MODE = octave
# python, python2 or python3 # python, python2 or python3
python_MODE = python python_MODE = python
# scheme (chibi, kawa, gauche, chicken, sagittarius, cyclone, foment)
scheme_MODE = chibi
# Extra options to pass to runtest.py # Extra options to pass to runtest.py
TEST_OPTS = TEST_OPTS =
@ -83,8 +85,8 @@ IMPLS = ada awk bash basic c d chuck clojure coffee common-lisp cpp crystal cs d
erlang elisp elixir es6 factor forth fsharp go groovy gst guile haskell \ erlang elisp elixir es6 factor forth fsharp go groovy gst guile haskell \
haxe io java julia js kotlin logo lua make mal ocaml matlab miniMAL \ haxe io java julia js kotlin logo lua make mal ocaml matlab miniMAL \
nim objc objpascal perl perl6 php pil plpgsql plsql powershell ps \ nim objc objpascal perl perl6 php pil plpgsql plsql powershell ps \
python r racket rexx rpython ruby rust scala skew swift swift3 tcl ts vb vhdl \ python r racket rexx rpython ruby rust scala scheme skew swift swift3 tcl \
vimscript livescript elm ts vb vhdl vimscript livescript elm
EXTENSION = .mal EXTENSION = .mal
@ -144,6 +146,14 @@ haxe_STEP_TO_PROG_js = haxe/$($(1)).js
clojure_STEP_TO_PROG_clj = clojure/target/$($(1)).jar clojure_STEP_TO_PROG_clj = clojure/target/$($(1)).jar
clojure_STEP_TO_PROG_cljs = clojure/src/mal/$($(1)).cljc clojure_STEP_TO_PROG_cljs = clojure/src/mal/$($(1)).cljc
scheme_STEP_TO_PROG_chibi = scheme/$($(1)).scm
scheme_STEP_TO_PROG_kawa = scheme/out/$($(1)).class
scheme_STEP_TO_PROG_gauche = scheme/$($(1)).scm
scheme_STEP_TO_PROG_chicken = scheme/$($(1))
scheme_STEP_TO_PROG_sagittarius = scheme/$($(1)).scm
scheme_STEP_TO_PROG_cyclone = scheme/$($(1))
scheme_STEP_TO_PROG_foment = scheme/$($(1)).scm
opt_DEFERRABLE = $(if $(strip $(DEFERRABLE)),$(if $(filter t true T True TRUE 1 y yes Yes YES,$(DEFERRABLE)),--deferrable,--no-deferrable),--no-deferrable) opt_DEFERRABLE = $(if $(strip $(DEFERRABLE)),$(if $(filter t true T True TRUE 1 y yes Yes YES,$(DEFERRABLE)),--deferrable,--no-deferrable),--no-deferrable)
opt_OPTIONAL = $(if $(strip $(OPTIONAL)),$(if $(filter t true T True TRUE 1 y yes Yes YES,$(OPTIONAL)),--optional,--no-optional),--no-optional) opt_OPTIONAL = $(if $(strip $(OPTIONAL)),$(if $(filter t true T True TRUE 1 y yes Yes YES,$(OPTIONAL)),--optional,--no-optional),--no-optional)
@ -211,6 +221,7 @@ rpython_STEP_TO_PROG = rpython/$($(1))
ruby_STEP_TO_PROG = ruby/$($(1)).rb ruby_STEP_TO_PROG = ruby/$($(1)).rb
rust_STEP_TO_PROG = rust/target/release/$($(1)) rust_STEP_TO_PROG = rust/target/release/$($(1))
scala_STEP_TO_PROG = scala/target/scala-2.11/classes/$($(1)).class scala_STEP_TO_PROG = scala/target/scala-2.11/classes/$($(1)).class
scheme_STEP_TO_PROG = $(scheme_STEP_TO_PROG_$(scheme_MODE))
skew_STEP_TO_PROG = skew/$($(1)).js skew_STEP_TO_PROG = skew/$($(1)).js
swift_STEP_TO_PROG = swift/$($(1)) swift_STEP_TO_PROG = swift/$($(1))
swift3_STEP_TO_PROG = swift3/$($(1)) swift3_STEP_TO_PROG = swift3/$($(1))

36
README.md
View File

@ -6,7 +6,7 @@
Mal is a Clojure inspired Lisp interpreter. Mal is a Clojure inspired Lisp interpreter.
Mal is implemented in 68 languages: Mal is implemented in 69 languages:
* Ada * Ada
* GNU awk * GNU awk
@ -68,6 +68,7 @@ Mal is implemented in 68 languages:
* Ruby * Ruby
* Rust * Rust
* Scala * Scala
* Scheme (R7RS)
* Skew * Skew
* Swift * Swift
* Swift 3 * Swift 3
@ -864,6 +865,39 @@ sbt compile
scala -classpath target/scala*/classes stepX_YYY scala -classpath target/scala*/classes stepX_YYY
``` ```
### Scheme (R7RS) ###
*The Scheme implementation was created by [Vasilij Schneidermann](https://github.com/wasamasa)*
The Scheme implementation of mal has been tested with Chibi-Scheme
0.7.3, Kawa 2.4, Gauche 0.9.5, CHICKEN 4.11.0, Sagittarius 0.8.3,
Cyclone 0.6.3 (Git version) and Foment 0.4 (Git version). You should
be able to get it running on other conforming R7RS implementations
after figuring out how libraries are loaded and adjusting the
`Makefile` and `run` script accordingly.
```
cd scheme
make symlinks
# chibi
scheme_MODE=chibi ./run
# kawa
make kawa
scheme_MODE=kawa ./run
# gauche
scheme_MODE=gauche ./run
# chicken
make chicken
scheme_MODE=chicken ./run
# sagittarius
scheme_MODE=sagittarius ./run
# cyclone
make cyclone
scheme_MODE=cyclone ./run
# foment
scheme_MODE=foment ./run
```
### Skew ### ### Skew ###
*The Skew implementation was created by [Dov Murik](https://github.com/dubek)* *The Skew implementation was created by [Dov Murik](https://github.com/dubek)*

11
scheme/.gitignore vendored Normal file
View File

@ -0,0 +1,11 @@
lib/*.scm
lib/*.so
lib/*.c
lib/*.o
lib/*.meta
lib.*.scm
*.so
*.c
*.o
out/
eggs/*

59
scheme/Dockerfile Normal file
View File

@ -0,0 +1,59 @@
FROM ubuntu:xenial
MAINTAINER Joel Martin <github@martintribe.org>
##########################################################
# General requirements for testing or common across many
# implementations
##########################################################
RUN apt-get -y update
# Required for running tests
RUN apt-get -y install make python
# Some typical implementation and test requirements
RUN apt-get -y install curl libreadline-dev libedit-dev
RUN mkdir -p /mal
WORKDIR /mal
##########################################################
# Specific implementation requirements
##########################################################
# Prepackaged Scheme implementations
RUN apt-get -y install gauche chicken-bin
# Chibi
RUN apt-get -y install bison gcc g++ flex
RUN cd /tmp && curl -Lo chibi-0.7.3.tar.gz https://github.com/ashinn/chibi-scheme/archive/0.7.3.tar.gz \
&& tar xvzf chibi-0.7.3.tar.gz && cd chibi-scheme-0.7.3 \
&& make && make install && rm -rf /tmp/chibi-*
# Kawa
RUN apt-get -y install openjdk-8-jdk-headless groff
RUN cd /tmp && curl -O http://ftp.gnu.org/pub/gnu/kawa/kawa-2.4.tar.gz \
&& tar xvzf kawa-2.4.tar.gz && cd kawa-2.4 \
&& ./configure && make && make install && rm -rf /tmp/kawa-2.4*
# Sagittarius
RUN apt-get -y install cmake libgc-dev zlib1g-dev libffi-dev
RUN cd /tmp && curl -LO https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/sagittarius-0.8.3.tar.gz \
&& tar xvzf sagittarius-0.8.3.tar.gz && cd sagittarius-0.8.3 \
&& cmake . && make && make install && rm -rf /tmp/sagittarius-0.8.3*
# Cyclone
RUN apt-get -y install git libtommath-dev
RUN cd /tmp && curl -O http://concurrencykit.org/releases/ck-0.6.0.tar.gz \
&& tar xvzf ck-0.6.0.tar.gz && cd ck-0.6.0 && ./configure PREFIX=/usr \
&& make all && make install && ldconfig && rm -rf /tmp/ck-0.6.0*
RUN cd /tmp && git clone https://github.com/justinethier/cyclone-bootstrap \
&& cd cyclone-bootstrap && make CFLAGS="-O2 -fPIC -rdynamic -Wall -Iinclude -L." \
&& make install && rm -rf /tmp/cyclone-bootstrap
# Foment
RUN cd /tmp && git clone https://github.com/leftmike/foment \
&& cd foment/unix && make && cp release/foment /usr/bin/foment \
&& rm -rf /tmp/foment
ENV HOME /mal

114
scheme/Makefile Normal file
View File

@ -0,0 +1,114 @@
SOURCES_BASE = lib/util.sld lib/reader.sld lib/printer.sld lib/types.sld
SOURCES_LISP = lib/env.sld lib/core.sld stepA_mal.scm
SOURCES = $(SOURCES_BASE) $(SOURCES_LISP)
BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step5_tco
BINS += step6_file step7_quote step8_macros step9_try stepA_mal
scheme_MODE ?= chibi
CLASSSTEPS = out/step0_repl.class out/step1_read_print.class \
out/step3_env.class out/step4_if_fn_do.class out/step5_tco.class \
out/step6_file.class out/step7_quote.class out/step8_macros.class \
out/step9_try.class out/stepA_mal.class
STEPS = $(if $(filter kawa,$(scheme_MODE)),$(CLASSSTEPS),\
$(if $(filter chicken,$(scheme_MODE)),$(BINS),\
$(if $(filter cyclone,$(scheme_MODE)),$(BINS))))
KAWA_STEP1_DEPS = out/lib/util.class out/lib/reader.class \
out/lib/printer.class out/lib/types.class
KAWA_STEP3_DEPS = $(KAWA_STEP1_DEPS) out/lib/env.class
KAWA_STEP4_DEPS = $(KAWA_STEP3_DEPS) out/lib/core.class
GAUCHE_STEP1_DEPS = lib/util.scm lib/reader.scm lib/printer.scm lib/types.scm
GAUCHE_STEP3_DEPS = $(GAUCHE_STEP1_DEPS) lib/env.scm
GAUCHE_STEP4_DEPS = $(GAUCHE_STEP3_DEPS) lib/core.scm
CHICKEN_STEP1_DEPS = eggs/lib.util.so eggs/lib.types.so \
eggs/lib.reader.so eggs/lib.printer.so
CHICKEN_STEP3_DEPS = $(CHICKEN_STEP1_DEPS) eggs/lib.env.so
CHICKEN_STEP4_DEPS = $(CHICKEN_STEP3_DEPS) eggs/lib.core.so
CYCLONE_STEP1_DEPS = lib/util.so lib/reader.so lib/printer.so lib/types.so
CYCLONE_STEP3_DEPS = $(CYCLONE_STEP1_DEPS) lib/env.so
CYCLONE_STEP4_DEPS = $(CYCLONE_STEP3_DEPS) lib/core.so
STEP1_DEPS = $(if $(filter kawa,$(scheme_MODE)),$(KAWA_STEP1_DEPS),\
$(if $(filter gauche,$(scheme_MODE)),$(GAUCHE_STEP1_DEPS),\
$(if $(filter chicken,$(scheme_MODE)),$(CHICKEN_STEP1_DEPS),\
$(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP1_DEPS)))))
STEP3_DEPS = $(if $(filter kawa,$(scheme_MODE)),$(KAWA_STEP3_DEPS),\
$(if $(filter gauche,$(scheme_MODE)),$(GAUCHE_STEP3_DEPS),\
$(if $(filter chicken,$(scheme_MODE)),$(CHICKEN_STEP3_DEPS),\
$(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP3_DEPS)))))
STEP4_DEPS = $(if $(filter kawa,$(scheme_MODE)),$(KAWA_STEP4_DEPS),\
$(if $(filter gauche,$(scheme_MODE)),$(GAUCHE_STEP4_DEPS),\
$(if $(filter chicken,$(scheme_MODE)),$(CHICKEN_STEP4_DEPS),\
$(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE_STEP4_DEPS)))))
KAWALIB = kawa --r7rs --no-warn-unused -d out -C
KAWA = kawa --r7rs --no-warn-unused -d out --main -C
CHICKEN = CHICKEN_REPOSITORY=$(CURDIR)/eggs csc -O3 -R r7rs
CHICKENLIB = $(CHICKEN) -sJ
CYCLONELIB = cyclone -O2
CYCLONE = $(CYCLONELIB)
SCMLIB = $(if $(filter kawa,$(scheme_MODE)),$(KAWALIB),\
$(if $(filter chicken,$(scheme_MODE)),$(CHICKENLIB),\
$(if $(filter cyclone,$(scheme_MODE)),$(CYCLONELIB))))
SCM = $(if $(filter kawa,$(scheme_MODE)),$(KAWA),\
$(if $(filter chicken,$(scheme_MODE)),$(CHICKEN),\
$(if $(filter cyclone,$(scheme_MODE)),$(CYCLONE))))
MKDIR = mkdir -p
SYMLINK = ln -sfr
RM = rm -f
RMR = rm -rf
all: $(STEPS)
.PHONY: clean stats stats-lisp
.PRECIOUS: lib/%.scm eggs/lib.%.scm
eggs/r7rs.so:
chicken-install -init eggs
CHICKEN_REPOSITORY=$(CURDIR)/eggs chicken-install r7rs
lib/%.scm: lib/%.sld
$(SYMLINK) $< $@
eggs/lib.%.scm: lib/%.sld
$(SYMLINK) $< $@
out/lib/%.class: lib/%.scm
$(SCMLIB) $<
out/%.class: %.scm
$(SCM) $<
eggs/lib.%.so: eggs/lib.%.scm
$(SCMLIB) $<
lib/%.so: lib/%.sld
$(SCMLIB) $<
%: %.scm
$(SCM) $<
out/step1_read_print.class out/step2_eval.class: $(STEP1_DEPS)
out/step3_env.class: $(STEP3_DEPS)
out/step4_if_fn_do.class out/step5_tco.class out/step6_file.class out/step7_quote.class out/step8_macros.class out/step9_try.class out/stepA_mal.class: $(STEP4_DEPS)
step0_repl: $(if $(filter chicken,$(scheme_MODE)),eggs/r7rs.so,)
step1_read_print.scm step2_eval.scm: $(STEP1_DEPS)
step3_env.scm: $(STEP3_DEPS)
step4_if_fn_do.scm step5_tco.scm step6_file.scm step7_quote.scm step8_macros.scm step9_try.scm stepA_mal.scm: $(STEP4_DEPS)
clean:
$(RM) lib/*.scm lib/*.so lib/*.c lib/*.o lib/*.meta
$(RM) lib.*.scm *.so *.c *.o $(BINS)
$(RM) eggs/*
$(RMR) out
stats: $(SOURCES)
@wc $^
@printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]"
stats-lisp: $(SOURCES_LISP)
@wc $^
@printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]"

0
scheme/eggs/.keep Normal file
View File

291
scheme/lib/core.sld Normal file
View File

@ -0,0 +1,291 @@
(define-library (lib core)
(export ns)
(import (scheme base))
(import (scheme write))
(import (scheme file))
(import (scheme time))
(import (scheme read))
(import (scheme eval))
;; HACK: cyclone doesn't implement environments yet, but its eval
;; behaves as if you were using the repl environment
(cond-expand
(cyclone)
(else
(import (scheme repl))))
(import (lib types))
(import (lib util))
(import (lib printer))
(import (lib reader))
(begin
(define (coerce x)
(if x mal-true mal-false))
(define (->printed-string args print-readably sep)
(let ((items (map (lambda (arg) (pr-str arg print-readably)) args)))
(string-intersperse items sep)))
(define (mal-equal? a b)
(let ((a-type (and (mal-object? a) (mal-type a)))
(a-value (and (mal-object? a) (mal-value a)))
(b-type (and (mal-object? b) (mal-type b)))
(b-value (and (mal-object? b) (mal-value b))))
(cond
((or (not a-type) (not b-type))
mal-false)
((and (memq a-type '(list vector))
(memq b-type '(list vector)))
(mal-list-equal? (->list a-value) (->list b-value)))
((and (eq? a-type 'map) (eq? b-type 'map))
(mal-map-equal? a-value b-value))
(else
(and (eq? a-type b-type)
(equal? a-value b-value))))))
(define (mal-list-equal? as bs)
(let loop ((as as)
(bs bs))
(cond
((and (null? as) (null? bs)) #t)
((or (null? as) (null? bs)) #f)
(else
(if (mal-equal? (car as) (car bs))
(loop (cdr as) (cdr bs))
#f)))))
(define (mal-map-ref key m . default)
(if (pair? default)
(alist-ref key m mal-equal? (car default))
(alist-ref key m mal-equal?)))
(define (mal-map-equal? as bs)
(if (not (= (length as) (length bs)))
#f
(let loop ((as as))
(if (pair? as)
(let* ((item (car as))
(key (car item))
(value (cdr item)))
(if (mal-equal? (mal-map-ref key bs) value)
(loop (cdr as))
#f))
#t))))
(define (mal-map-dissoc m keys)
(let loop ((items m)
(acc '()))
(if (pair? items)
(let* ((item (car items))
(key (car item)))
(if (contains? keys (lambda (x) (mal-equal? key x)))
(loop (cdr items) acc)
(loop (cdr items) (cons item acc))))
(reverse acc))))
(define (mal-map-assoc m kvs)
(let ((kvs (list->alist kvs)))
(append kvs (mal-map-dissoc m (map car kvs)))))
(define (map-in-order proc items)
(let loop ((items items)
(acc '()))
(if (null? items)
(reverse acc)
(loop (cdr items) (cons (proc (car items)) acc)))))
(define (slurp path)
(call-with-output-string
(lambda (out)
(call-with-input-file path
(lambda (in)
(let loop ()
(let ((chunk (read-string 1024 in)))
(when (not (eof-object? chunk))
(display chunk out)
(loop)))))))))
(define (time-ms)
(* (/ (current-jiffy) (jiffies-per-second)) 1000.0))
(define (->mal-object x)
(cond
((boolean? x) (if x mal-true mal-false))
((char? x) (mal-string (char->string x)))
((procedure? x) x)
((symbol? x) (mal-symbol x))
((number? x) (mal-number x))
((string? x) (mal-string x))
((or (null? x) (pair? x))
(mal-list (map ->mal-object x)))
((vector? x)
(mal-vector (vector-map ->mal-object x)))
(else
(error "unknown type"))))
(define (scm-eval input)
(call-with-input-string input
(lambda (port)
(cond-expand
(cyclone
(->mal-object (eval (read port))))
(else
(->mal-object (eval (read port) (environment '(scheme base)
'(scheme write)))))))))
(define ns
`((+ . ,(lambda (a b) (mal-number (+ (mal-value a) (mal-value b)))))
(- . ,(lambda (a b) (mal-number (- (mal-value a) (mal-value b)))))
(* . ,(lambda (a b) (mal-number (* (mal-value a) (mal-value b)))))
(/ . ,(lambda (a b) (mal-number (/ (mal-value a) (mal-value b)))))
(list . ,(lambda args (mal-list args)))
(list? . ,(lambda (x) (coerce (mal-instance-of? x 'list))))
(empty? . ,(lambda (lis) (coerce (null? (->list (mal-value lis))))))
(count . ,(lambda (lis) (mal-number
(if (eq? lis mal-nil)
0
(length (->list (mal-value lis)))))))
(< . ,(lambda (a b) (coerce (< (mal-value a) (mal-value b)))))
(<= . ,(lambda (a b) (coerce (<= (mal-value a) (mal-value b)))))
(> . ,(lambda (a b) (coerce (> (mal-value a) (mal-value b)))))
(>= . ,(lambda (a b) (coerce (>= (mal-value a) (mal-value b)))))
(= . ,(lambda (a b) (coerce (mal-equal? a b))))
(pr-str . ,(lambda args (mal-string (->printed-string args #t " "))))
(str . ,(lambda args (mal-string (->printed-string args #f ""))))
(prn . ,(lambda args
(display (->printed-string args #t " "))
(newline)
mal-nil))
(println . ,(lambda args
(display (->printed-string args #f " "))
(newline)
mal-nil))
(read-string . ,(lambda (string) (read-str (mal-value string))))
(slurp . ,(lambda (path) (mal-string (slurp (mal-value path)))))
(throw . ,(lambda (x) (raise (cons 'user-error x))))
(readline . ,(lambda (prompt) (let ((output (readline (mal-value prompt))))
(if output (mal-string output) mal-nil))))
(time-ms . ,(lambda () (mal-number (time-ms))))
(scm-eval . ,(lambda (input) (scm-eval (mal-value input))))
(atom . ,(lambda (x) (mal-atom x)))
(atom? . ,(lambda (x) (coerce (mal-instance-of? x 'atom))))
(deref . ,(lambda (atom) (mal-value atom)))
(reset! . ,(lambda (atom x) (mal-value-set! atom x) x))
(swap! . ,(lambda (atom fn . args)
(let* ((fn (if (func? fn) (func-fn fn) fn))
(value (apply fn (cons (mal-value atom) args))))
(mal-value-set! atom value)
value)))
(cons . ,(lambda (x xs) (mal-list (cons x (->list (mal-value xs))))))
(concat . ,(lambda args (mal-list (apply append (map (lambda (arg) (->list (mal-value arg))) args)))))
(nth . ,(lambda (x n) (let ((items (->list (mal-value x)))
(index (mal-value n)))
(if (< index (length items))
(list-ref items index)
(error (str "Out of range: " index))))))
(first . ,(lambda (x) (if (eq? x mal-nil)
mal-nil
(let ((items (->list (mal-value x))))
(if (null? items)
mal-nil
(car items))))))
(rest . ,(lambda (x) (if (eq? x mal-nil)
(mal-list '())
(let ((items (->list (mal-value x))))
(if (null? items)
(mal-list '())
(mal-list (cdr items)))))))
(conj . ,(lambda (coll . args)
(let ((items (mal-value coll)))
(cond
((vector? items)
(mal-vector (vector-append items (list->vector args))))
((list? items)
(mal-list (append (reverse args) items)))
(else
(error "invalid collection type"))))))
(seq . ,(lambda (x) (if (eq? x mal-nil)
mal-nil
(let ((value (mal-value x)))
(case (mal-type x)
((list)
(if (null? value)
mal-nil
x))
((vector)
(if (zero? (vector-length value))
mal-nil
(mal-list (vector->list value))))
((string)
(if (zero? (string-length value))
mal-nil
(mal-list (map mal-string (explode value)))))
(else
(error "invalid collection type")))))))
(apply . ,(lambda (f . args) (apply (if (func? f) (func-fn f) f)
(if (pair? (cdr args))
(append (butlast args)
(->list (mal-value (last args))))
(->list (mal-value (car args)))))))
(map . ,(lambda (f items) (mal-list (map-in-order
(if (func? f) (func-fn f) f)
(->list (mal-value items))))))
(nil? . ,(lambda (x) (coerce (eq? x mal-nil))))
(true? . ,(lambda (x) (coerce (eq? x mal-true))))
(false? . ,(lambda (x) (coerce (eq? x mal-false))))
(string? . ,(lambda (x) (coerce (mal-instance-of? x 'string))))
(symbol? . ,(lambda (x) (coerce (mal-instance-of? x 'symbol))))
(symbol . ,(lambda (x) (mal-symbol (string->symbol (mal-value x)))))
(keyword? . ,(lambda (x) (coerce (mal-instance-of? x 'keyword))))
(keyword . ,(lambda (x) (mal-keyword (string->symbol (mal-value x)))))
(vector? . ,(lambda (x) (coerce (mal-instance-of? x 'vector))))
(vector . ,(lambda args (mal-vector (list->vector args))))
(map? . ,(lambda (x) (coerce (mal-instance-of? x 'map))))
(hash-map . ,(lambda args (mal-map (list->alist args))))
(sequential? . ,(lambda (x) (coerce (and (mal-object? x)
(memq (mal-type x)
'(list vector))))))
(assoc . ,(lambda (m . kvs) (mal-map (mal-map-assoc (mal-value m) kvs))))
(dissoc . ,(lambda (m . keys) (mal-map (mal-map-dissoc (mal-value m) keys))))
(get . ,(lambda (m key) (mal-map-ref key (mal-value m) mal-nil)))
(contains? . ,(lambda (m key) (coerce (mal-map-ref key (mal-value m)))))
(keys . ,(lambda (m) (mal-list (map car (mal-value m)))))
(vals . ,(lambda (m) (mal-list (map cdr (mal-value m)))))
(with-meta . ,(lambda (x meta)
(cond
((mal-object? x)
(make-mal-object (mal-type x) (mal-value x) meta))
((func? x)
(let ((func (make-func (func-ast x) (func-params x)
(func-env x) (func-fn x))))
(func-macro?-set! func (func-macro? x))
(func-meta-set! func meta)
func))
(else
(error "unsupported type")))))
(meta . ,(lambda (x) (cond
((mal-object? x)
(or (mal-meta x) mal-nil))
((func? x)
(or (func-meta x) mal-nil))
(else
mal-nil))))
))
)
)

49
scheme/lib/env.sld Normal file
View File

@ -0,0 +1,49 @@
(define-library (lib env)
(export make-env env-set env-find env-get)
(import (scheme base))
(import (lib util))
(import (lib types))
(begin
(define-record-type env
(%make-env outer data)
env?
(outer env-outer)
(data env-data env-data-set!))
(define (make-env outer . rest)
(let ((env (%make-env outer '())))
(when (pair? rest)
(let loop ((binds (car rest))
(exprs (cadr rest)))
(when (pair? binds)
(let ((bind (car binds)))
(if (eq? bind '&)
(env-set env (cadr binds) (mal-list exprs))
(begin
(env-set env bind (car exprs))
(loop (cdr binds) (cdr exprs))))))))
env))
(define (env-set env key value)
(env-data-set! env (cons (cons key value) (env-data env))))
(define (env-find env key)
(cond
((alist-ref key (env-data env)) => identity)
((env-outer env) => (lambda (outer) (env-find outer key)))
(else #f)))
(define (env-get env key)
(let ((value (env-find env key)))
(if value
value
(error (str "'" key "' not found")))))
)
)

62
scheme/lib/printer.sld Normal file
View File

@ -0,0 +1,62 @@
(define-library (lib printer)
(export pr-str)
(import (scheme base))
(import (scheme write))
(import (lib util))
(import (lib types))
(begin
(define (pr-str ast print-readably)
(cond
((procedure? ast)
"#<fn>")
((func? ast)
"#<func>")
(else
(if (procedure? ast)
"#<fn>"
(let* ((type (and (mal-object? ast) (mal-type ast)))
(value (and (mal-object? ast) (mal-value ast))))
(case type
((true) "true")
((false) "false")
((nil) "nil")
((number) (number->string value))
((string) (call-with-output-string
(lambda (port)
(if print-readably
(begin
(display #\" port)
(string-for-each
(lambda (char)
(case char
((#\\) (display "\\\\" port))
((#\") (display "\\\"" port))
((#\newline) (display "\\n" port))
(else (display char port))))
value)
(display #\" port))
(display value port)))))
((keyword) (string-append ":" (symbol->string value)))
((symbol) (symbol->string value))
((list) (pr-list value "(" ")" print-readably))
((vector) (pr-list (vector->list value) "[" "]" print-readably))
((map) (pr-list (alist->list value) "{" "}" print-readably))
((atom) (string-append "(atom " (pr-str value print-readably) ")"))
(else (error "unknown type"))))))))
(define (pr-list items starter ender print-readably)
(call-with-output-string
(lambda (port)
(display starter port)
(let ((reprs (map (lambda (item) (pr-str item print-readably)) items)))
(display (string-intersperse reprs " ") port))
(display ender port))))
)
)

178
scheme/lib/reader.sld Normal file
View File

@ -0,0 +1,178 @@
(define-library (lib reader)
(export read-str)
(import (scheme base))
(import (scheme char))
(import (scheme read))
(import (scheme write))
(import (lib util))
(import (lib types))
(begin
(define-record-type reader
(%make-reader tokens position)
reader?
(tokens %reader-tokens)
(position %reader-position %reader-position-set!))
(define (make-reader tokens)
(%make-reader (list->vector tokens) 0))
(define (peek reader)
(let ((tokens (%reader-tokens reader))
(position (%reader-position reader)))
(if (>= position (vector-length tokens))
#f
(vector-ref tokens position))))
(define (next reader)
(let ((token (peek reader)))
(when token
(%reader-position-set! reader (+ (%reader-position reader) 1)))
token))
(define (read-str input)
(let* ((tokens (tokenizer input))
(reader (make-reader tokens)))
(read-form reader)))
(define (whitespace-char? char)
(or (char-whitespace? char) (char=? char #\,)))
(define (special-char? char)
(memv char '(#\[ #\] #\{ #\} #\( #\) #\' #\` #\~ #\^ #\@)))
(define (non-word-char? char)
(or (whitespace-char? char)
(memv char '(#\[ #\] #\{ #\} #\( #\) #\' #\" #\` #\;))))
(define (tokenizer input)
(call-with-input-string input
(lambda (port)
(let loop ((tokens '()))
(if (eof-object? (peek-char port))
(reverse tokens)
(let ((char (read-char port)))
(cond
((whitespace-char? char)
(loop tokens))
((and (char=? char #\~)
(char=? (peek-char port) #\@))
(read-char port) ; remove @ token
(loop (cons "~@" tokens)))
((char=? char #\")
(loop (cons (tokenize-string port) tokens)))
((char=? char #\;)
(skip-comment port)
(loop tokens))
((special-char? char)
(loop (cons (char->string char) tokens)))
(else
(loop (cons (tokenize-word port char) tokens))))))))))
(define (tokenize-string port)
(let loop ((chars '(#\")))
(let ((char (read-char port)))
(cond
((eof-object? char)
(list->string (reverse chars)))
((char=? char #\\)
(let ((char (read-char port)))
(when (not (eof-object? char))
(loop (cons char (cons #\\ chars))))))
((not (char=? char #\"))
(loop (cons char chars)))
((char=? char #\")
(list->string (reverse (cons #\" chars))))))))
(define (skip-comment port)
(let loop ()
(let ((char (peek-char port)))
(when (not (or (eof-object? char)
(char=? char #\newline)))
(read-char port)
(loop)))))
(define (tokenize-word port char)
(let loop ((chars (list char)))
(let ((char (peek-char port)))
(if (or (eof-object? char)
(non-word-char? char))
(list->string (reverse chars))
(loop (cons (read-char port) chars))))))
(define (read-form reader)
(let ((token (peek reader)))
(cond
((equal? token "'")
(read-macro reader 'quote))
((equal? token "`")
(read-macro reader 'quasiquote))
((equal? token "~")
(read-macro reader 'unquote))
((equal? token "~@")
(read-macro reader 'splice-unquote))
((equal? token "@")
(read-macro reader 'deref))
((equal? token "^")
(read-meta reader))
((equal? token "(")
(read-list reader ")" mal-list))
((equal? token "[")
(read-list reader "]" (lambda (items) (mal-vector (list->vector items)))))
((equal? token "{")
(read-list reader "}" (lambda (items) (mal-map (list->alist items)))))
(else
(read-atom reader)))))
(define (read-macro reader symbol)
(next reader) ; pop macro token
(mal-list (list (mal-symbol symbol) (read-form reader))))
(define (read-meta reader)
(next reader) ; pop macro token
(let ((form (read-form reader)))
(mal-list (list (mal-symbol 'with-meta) (read-form reader) form))))
(define (read-list reader ender proc)
(next reader) ; pop list start
(let loop ((items '()))
(let ((token (peek reader)))
(cond
((equal? token ender)
(next reader)
(proc (reverse items)))
((not token)
(error (str "expected '" ender "', got EOF")))
(else
(loop (cons (read-form reader) items)))))))
(define (read-atom reader)
(let ((token (next reader)))
(cond
((not token)
(error "end of token stream" 'empty-input))
((equal? token "true")
mal-true)
((equal? token "false")
mal-false)
((equal? token "nil")
mal-nil)
((string->number token)
=> mal-number)
((char=? (string-ref token 0) #\")
(let ((last (- (string-length token) 1)))
(if (char=? (string-ref token last) #\")
(mal-string (call-with-input-string token read))
(error (str "expected '" #\" "', got EOF")))))
((char=? (string-ref token 0) #\:)
(mal-keyword (string->symbol (string-copy token 1))))
(else
(mal-symbol (string->symbol token))))))
)
)

70
scheme/lib/types.sld Normal file
View File

@ -0,0 +1,70 @@
(define-library (lib types)
(export make-mal-object mal-object? mal-type mal-value mal-value-set! mal-meta
mal-true mal-false mal-nil
mal-number mal-string mal-symbol mal-keyword
mal-list mal-vector mal-map mal-atom
make-func func? func-ast func-params func-env
func-fn func-macro? func-macro?-set! func-meta func-meta-set!
mal-instance-of?)
(import (scheme base))
(begin
(define-record-type mal-object
(make-mal-object type value meta)
mal-object?
(type mal-type)
(value mal-value mal-value-set!)
(meta mal-meta mal-meta-set!))
(define mal-true (make-mal-object 'true #t #f))
(define mal-false (make-mal-object 'false #f #f))
(define mal-nil (make-mal-object 'nil #f #f))
(define (mal-number n)
(make-mal-object 'number n #f))
(define (mal-string string)
(make-mal-object 'string string #f))
(define (mal-symbol name)
(make-mal-object 'symbol name #f))
(define (mal-keyword name)
(make-mal-object 'keyword name #f))
(define (mal-list items)
(make-mal-object 'list items #f))
(define (mal-vector items)
(make-mal-object 'vector items #f))
(define (mal-map items)
(make-mal-object 'map items #f))
(define (mal-atom item)
(make-mal-object 'atom item #f))
(define-record-type func
(%make-func ast params env fn macro? meta)
func?
(ast func-ast)
(params func-params)
(env func-env)
(fn func-fn)
(macro? func-macro? func-macro?-set!)
(meta func-meta func-meta-set!))
(define (make-func ast params env fn)
(%make-func ast params env fn #f #f))
(define (mal-instance-of? x type)
(and (mal-object? x) (eq? (mal-type x) type)))
)
)

162
scheme/lib/util.sld Normal file
View File

@ -0,0 +1,162 @@
(define-library (lib util)
(export call-with-input-string call-with-output-string
str prn debug
string-intersperse explode
char->string
list->alist alist->list alist-ref alist-map
->list car-safe cdr-safe contains? last butlast
identity readline
;; HACK: cyclone doesn't have those
error-object? error-object-message error-object-irritants)
(import (scheme base))
(import (scheme write))
(begin
;; HACK: cyclone currently implements error the SICP way
(cond-expand
(cyclone
(define (error-object? x) (and (pair? x) (string? (car x))))
(define error-object-message car)
(define error-object-irritants cdr))
(else))
(define (call-with-input-string string proc)
(let ((port (open-input-string string)))
(dynamic-wind
(lambda () #t)
(lambda () (proc port))
(lambda () (close-input-port port)))))
(define (call-with-output-string proc)
(let ((port (open-output-string)))
(dynamic-wind
(lambda () #t)
(lambda () (proc port) (get-output-string port))
(lambda () (close-output-port port)))))
(define (str . items)
(call-with-output-string
(lambda (port)
(for-each (lambda (item) (display item port)) items))))
(define (prn . items)
(for-each (lambda (item) (write item) (display " ")) items)
(newline))
(define (debug . items)
(parameterize ((current-output-port (current-error-port)))
(apply prn items)))
(define (intersperse items sep)
(let loop ((items items)
(acc '()))
(if (null? items)
(reverse acc)
(let ((tail (cdr items)))
(if (null? tail)
(loop (cdr items) (cons (car items) acc))
(loop (cdr items) (cons sep (cons (car items) acc))))))))
(define (string-intersperse items sep)
(apply string-append (intersperse items sep)))
(define (char->string char)
(list->string (list char)))
(define (explode string)
(map char->string (string->list string)))
(define (list->alist items)
(let loop ((items items)
(acc '()))
(if (null? items)
(reverse acc)
(let ((key (car items)))
(when (null? (cdr items))
(error "unbalanced list"))
(let ((value (cadr items)))
(loop (cddr items)
(cons (cons key value) acc)))))))
(define (alist->list items)
(let loop ((items items)
(acc '()))
(if (null? items)
(reverse acc)
(let ((kv (car items)))
(loop (cdr items)
(cons (cdr kv) (cons (car kv) acc)))))))
(define (alist-ref key alist . args)
(let ((test (if (pair? args) (car args) eqv?))
(default (if (> (length args) 1) (cadr args) #f)))
(let loop ((items alist))
(if (pair? items)
(let ((item (car items)))
(if (test (car item) key)
(cdr item)
(loop (cdr items))))
default))))
(define (alist-map proc items)
(map (lambda (item) (proc (car item) (cdr item))) items))
(define (->list items)
(if (vector? items)
(vector->list items)
items))
(define (car-safe x)
(if (pair? x)
(car x)
'()))
(define (cdr-safe x)
(if (pair? x)
(cdr x)
'()))
(define (contains? items test)
(let loop ((items items))
(if (pair? items)
(if (test (car items))
#t
(loop (cdr items)))
#f)))
(define (last items)
(when (null? items)
(error "empty argument"))
(let loop ((items items))
(let ((tail (cdr items)))
(if (pair? tail)
(loop tail)
(car items)))))
(define (butlast items)
(when (null? items)
(error "empty argument"))
(let loop ((items items)
(acc '()))
(let ((tail (cdr items)))
(if (pair? tail)
(loop tail (cons (car items) acc))
(reverse acc)))))
(define (identity x) x)
(define (readline prompt)
(display prompt)
(flush-output-port)
(let ((input (read-line)))
(if (eof-object? input)
#f
input)))
)
)

26
scheme/run Executable file
View File

@ -0,0 +1,26 @@
#!/bin/bash
basedir=$(dirname $0)
step=${STEP:-stepA_mal}
if [[ -e /usr/share/kawa/lib/kawa.jar ]]; then
kawa=/usr/share/kawa/lib/kawa.jar
elif [[ -e /usr/local/share/kawa/lib/kawa.jar ]]; then
kawa=/usr/local/share/kawa/lib/kawa.jar
fi
if [[ $(which sash 2>/dev/null) ]]; then
sagittarius=sash
elif [[ $(which sagittarius 2>/dev/null) ]]; then
sagittarius=sagittarius
fi
case ${scheme_MODE:-chibi} in
chibi) exec chibi-scheme -I$basedir $basedir/$step.scm "${@}" ;;
kawa) exec java -cp $kawa:$basedir/out $step "${@}" ;;
gauche) exec gosh -I$basedir $basedir/$step.scm "${@}" ;;
chicken) CHICKEN_REPOSITORY=$basedir/eggs exec $basedir/$step "${@}" ;;
sagittarius) exec $sagittarius -n -L$basedir $basedir/$step.scm "${@}" ;;
cyclone) exec $basedir/$step "${@}" ;;
foment) exec foment $basedir/$step.scm "${@}" ;;
*) echo "Invalid scheme_MODE: ${scheme_MODE}"; exit 2 ;;
esac

33
scheme/step0_repl.scm Normal file
View File

@ -0,0 +1,33 @@
(import (scheme base))
(import (scheme write))
(define (READ input)
input)
(define (EVAL input)
input)
(define (PRINT input)
input)
(define (rep input)
(PRINT (EVAL (READ input))))
(define (readline prompt)
(display prompt)
(flush-output-port)
(let ((input (read-line)))
(if (eof-object? input)
#f
input)))
(define (main)
(let loop ()
(let ((input (readline "user> ")))
(when input
(display (rep input))
(newline)
(loop))))
(newline))
(main)

36
scheme/step1_read_print.scm Normal file
View File

@ -0,0 +1,36 @@
(import (scheme base))
(import (scheme write))
(import (lib util))
(import (lib reader))
(import (lib printer))
(import (lib types))
(define (READ input)
(read-str input))
(define (EVAL ast)
ast)
(define (PRINT ast)
(pr-str ast #t))
(define (rep input)
(PRINT (EVAL (READ input))))
(define (main)
(let loop ()
(let ((input (readline "user> ")))
(when input
(guard
(ex ((error-object? ex)
(when (not (memv 'empty-input (error-object-irritants ex)))
(display "[error] ")
(display (error-object-message ex))
(newline))))
(display (rep input))
(newline))
(loop))))
(newline))
(main)

62
scheme/step2_eval.scm Normal file
View File

@ -0,0 +1,62 @@
(import (scheme base))
(import (scheme write))
(import (lib util))
(import (lib reader))
(import (lib printer))
(import (lib types))
(define (READ input)
(read-str input))
(define (eval-ast ast env)
(let ((type (and (mal-object? ast) (mal-type ast)))
(value (and (mal-object? ast) (mal-value ast))))
(case type
((symbol) (or (alist-ref value env)
(error (str "'" value "' not found"))))
((list) (mal-list (map (lambda (item) (EVAL item env)) value)))
((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value)))
((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value)))
(else ast))))
(define (EVAL ast env)
(let ((type (and (mal-object? ast) (mal-type ast))))
(if (not (eq? type 'list))
(eval-ast ast env)
(let ((items (mal-value ast)))
(if (null? items)
ast
(let* ((items (mal-value (eval-ast ast env)))
(op (car items))
(ops (cdr items)))
(apply op ops)))))))
(define (PRINT ast)
(pr-str ast #t))
(define repl-env
`((+ . ,(lambda (a b) (mal-number (+ (mal-value a) (mal-value b)))))
(- . ,(lambda (a b) (mal-number (- (mal-value a) (mal-value b)))))
(* . ,(lambda (a b) (mal-number (* (mal-value a) (mal-value b)))))
(/ . ,(lambda (a b) (mal-number (/ (mal-value a) (mal-value b)))))))
(define (rep input)
(PRINT (EVAL (READ input) repl-env)))
(define (main)
(let loop ()
(let ((input (readline "user> ")))
(when input
(guard
(ex ((error-object? ex)
(when (not (memv 'empty-input (error-object-irritants ex)))
(display "[error] ")
(display (error-object-message ex))
(newline))))
(display (rep input))
(newline))
(loop))))
(newline))
(main)

83
scheme/step3_env.scm Normal file
View File

@ -0,0 +1,83 @@
(import (scheme base))
(import (scheme write))
(import (lib util))
(import (lib reader))
(import (lib printer))
(import (lib types))
(import (lib env))
(define (READ input)
(read-str input))
(define (eval-ast ast env)
(let ((type (and (mal-object? ast) (mal-type ast)))
(value (and (mal-object? ast) (mal-value ast))))
(case type
((symbol) (env-get env value))
((list) (mal-list (map (lambda (item) (EVAL item env)) value)))
((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value)))
((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value)))
(else ast))))
(define (EVAL ast env)
(let ((type (and (mal-object? ast) (mal-type ast))))
(if (not (eq? type 'list))
(eval-ast ast env)
(let ((items (mal-value ast)))
(if (null? items)
ast
(case (mal-value (car items))
((def!)
(let ((symbol (mal-value (cadr items)))
(value (EVAL (list-ref items 2) env)))
(env-set env symbol value)
value))
((let*)
(let* ((env* (make-env env))
(binds (mal-value (cadr items)))
(binds (if (vector? binds) (vector->list binds) binds))
(form (list-ref items 2)))
(let loop ((binds binds))
(when (pair? binds)
(let ((key (mal-value (car binds))))
(when (null? (cdr binds))
(error "unbalanced list"))
(let ((value (EVAL (cadr binds) env*)))
(env-set env* key value)
(loop (cddr binds))))))
(EVAL form env*)))
(else
(let* ((items (mal-value (eval-ast ast env)))
(op (car items))
(ops (cdr items)))
(apply op ops)))))))))
(define (PRINT ast)
(pr-str ast #t))
(define repl-env (make-env #f))
(env-set repl-env '+ (lambda (a b) (mal-number (+ (mal-value a) (mal-value b)))))
(env-set repl-env '- (lambda (a b) (mal-number (- (mal-value a) (mal-value b)))))
(env-set repl-env '* (lambda (a b) (mal-number (* (mal-value a) (mal-value b)))))
(env-set repl-env '/ (lambda (a b) (mal-number (/ (mal-value a) (mal-value b)))))
(define (rep input)
(PRINT (EVAL (READ input) repl-env)))
(define (main)
(let loop ()
(let ((input (readline "user> ")))
(when input
(guard
(ex ((error-object? ex)
(when (not (memv 'empty-input (error-object-irritants ex)))
(display "[error] ")
(display (error-object-message ex))
(newline))))
(display (rep input))
(newline))
(loop))))
(newline))
(main)

111
scheme/step4_if_fn_do.scm Normal file
View File

@ -0,0 +1,111 @@
(import (scheme base))
(import (scheme write))
(import (lib util))
(import (lib reader))
(import (lib printer))
(import (lib types))
(import (lib env))
(import (lib core))
(define (READ input)
(read-str input))
(define (eval-ast ast env)
(let ((type (and (mal-object? ast) (mal-type ast)))
(value (and (mal-object? ast) (mal-value ast))))
(case type
((symbol) (env-get env value))
((list) (mal-list (map (lambda (item) (EVAL item env)) value)))
((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value)))
((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value)))
(else ast))))
(define (EVAL ast env)
(let ((type (and (mal-object? ast) (mal-type ast))))
(if (not (eq? type 'list))
(eval-ast ast env)
(let ((items (mal-value ast)))
(if (null? items)
ast
(case (mal-value (car items))
((def!)
(let ((symbol (mal-value (cadr items)))
(value (EVAL (list-ref items 2) env)))
(env-set env symbol value)
value))
((let*)
(let ((env* (make-env env))
(binds (->list (mal-value (cadr items))))
(form (list-ref items 2)))
(let loop ((binds binds))
(when (pair? binds)
(let ((key (mal-value (car binds))))
(when (null? (cdr binds))
(error "unbalanced list"))
(let ((value (EVAL (cadr binds) env*)))
(env-set env* key value)
(loop (cddr binds))))))
(EVAL form env*)))
((do)
(let ((forms (cdr items)))
(if (null? forms)
mal-nil
;; the evaluation order of map is unspecified
(let loop ((forms forms))
(let ((form (car forms))
(tail (cdr forms)))
(if (null? tail)
(EVAL form env)
(begin
(EVAL form env)
(loop tail))))))))
((if)
(let* ((condition (EVAL (cadr items) env))
(type (and (mal-object? condition)
(mal-type condition))))
(if (memq type '(false nil))
(if (< (length items) 4)
mal-nil
(EVAL (list-ref items 3) env))
(EVAL (list-ref items 2) env))))
((fn*)
(let* ((binds (->list (mal-value (cadr items))))
(binds (map mal-value binds))
(body (list-ref items 2)))
(lambda args
(let ((env* (make-env env binds args)))
(EVAL body env*)))))
(else
(let* ((items (mal-value (eval-ast ast env)))
(op (car items))
(ops (cdr items)))
(apply op ops)))))))))
(define (PRINT ast)
(pr-str ast #t))
(define repl-env (make-env #f))
(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns)
(define (rep input)
(PRINT (EVAL (READ input) repl-env)))
(rep "(def! not (fn* (a) (if a false true)))")
(define (main)
(let loop ()
(let ((input (readline "user> ")))
(when input
(guard
(ex ((error-object? ex)
(when (not (memv 'empty-input (error-object-irritants ex)))
(display "[error] ")
(display (error-object-message ex))
(newline))))
(display (rep input))
(newline))
(loop))))
(newline))
(main)

117
scheme/step5_tco.scm Normal file
View File

@ -0,0 +1,117 @@
(import (scheme base))
(import (scheme write))
(import (lib util))
(import (lib reader))
(import (lib printer))
(import (lib types))
(import (lib env))
(import (lib core))
(define (READ input)
(read-str input))
(define (eval-ast ast env)
(let ((type (and (mal-object? ast) (mal-type ast)))
(value (and (mal-object? ast) (mal-value ast))))
(case type
((symbol) (env-get env value))
((list) (mal-list (map (lambda (item) (EVAL item env)) value)))
((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value)))
((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value)))
(else ast))))
(define (EVAL ast env)
(let ((type (and (mal-object? ast) (mal-type ast))))
(if (not (eq? type 'list))
(eval-ast ast env)
(let ((items (mal-value ast)))
(if (null? items)
ast
(case (mal-value (car items))
((def!)
(let ((symbol (mal-value (cadr items)))
(value (EVAL (list-ref items 2) env)))
(env-set env symbol value)
value))
((let*)
(let ((env* (make-env env))
(binds (->list (mal-value (cadr items))))
(form (list-ref items 2)))
(let loop ((binds binds))
(when (pair? binds)
(let ((key (mal-value (car binds))))
(when (null? (cdr binds))
(error "unbalanced list"))
(let ((value (EVAL (cadr binds) env*)))
(env-set env* key value)
(loop (cddr binds))))))
(EVAL form env*))) ; TCO
((do)
(let ((forms (cdr items)))
(if (null? forms)
mal-nil
;; the evaluation order of map is unspecified
(let loop ((forms forms))
(let ((form (car forms))
(tail (cdr forms)))
(if (null? tail)
(EVAL form env) ; TCO
(begin
(EVAL form env)
(loop tail))))))))
((if)
(let* ((condition (EVAL (cadr items) env))
(type (and (mal-object? condition)
(mal-type condition))))
(if (memq type '(false nil))
(if (< (length items) 4)
mal-nil
(EVAL (list-ref items 3) env)) ; TCO
(EVAL (list-ref items 2) env)))) ; TCO
((fn*)
(let* ((binds (->list (mal-value (cadr items))))
(binds (map mal-value binds))
(body (list-ref items 2))
(fn (lambda args
(let ((env* (make-env env binds args)))
(EVAL body env*)))))
(make-func body binds env fn)))
(else
(let* ((items (mal-value (eval-ast ast env)))
(op (car items))
(ops (cdr items)))
(if (func? op)
(let* ((outer (func-env op))
(binds (func-params op))
(env* (make-env outer binds ops)))
(EVAL (func-ast op) env*)) ; TCO
(apply op ops))))))))))
(define (PRINT ast)
(pr-str ast #t))
(define repl-env (make-env #f))
(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns)
(define (rep input)
(PRINT (EVAL (READ input) repl-env)))
(rep "(def! not (fn* (a) (if a false true)))")
(define (main)
(let loop ()
(let ((input (readline "user> ")))
(when input
(guard
(ex ((error-object? ex)
(when (not (memv 'empty-input (error-object-irritants ex)))
(display "[error] ")
(display (error-object-message ex))
(newline))))
(display (rep input))
(newline))
(loop))))
(newline))
(main)

127
scheme/step6_file.scm Normal file
View File

@ -0,0 +1,127 @@
(import (scheme base))
(import (scheme write))
(import (scheme process-context))
(import (lib util))
(import (lib reader))
(import (lib printer))
(import (lib types))
(import (lib env))
(import (lib core))
(define (READ input)
(read-str input))
(define (eval-ast ast env)
(let ((type (and (mal-object? ast) (mal-type ast)))
(value (and (mal-object? ast) (mal-value ast))))
(case type
((symbol) (env-get env value))
((list) (mal-list (map (lambda (item) (EVAL item env)) value)))
((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value)))
((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value)))
(else ast))))
(define (EVAL ast env)
(let ((type (and (mal-object? ast) (mal-type ast))))
(if (not (eq? type 'list))
(eval-ast ast env)
(let ((items (mal-value ast)))
(if (null? items)
ast
(let ((a0 (car items)))
(case (and (mal-object? a0) (mal-value a0))
((def!)
(let ((symbol (mal-value (cadr items)))
(value (EVAL (list-ref items 2) env)))
(env-set env symbol value)
value))
((let*)
(let ((env* (make-env env))
(binds (->list (mal-value (cadr items))))
(form (list-ref items 2)))
(let loop ((binds binds))
(when (pair? binds)
(let ((key (mal-value (car binds))))
(when (null? (cdr binds))
(error "unbalanced list"))
(let ((value (EVAL (cadr binds) env*)))
(env-set env* key value)
(loop (cddr binds))))))
(EVAL form env*))) ; TCO
((do)
(let ((forms (cdr items)))
(if (null? forms)
mal-nil
;; the evaluation order of map is unspecified
(let loop ((forms forms))
(let ((form (car forms))
(tail (cdr forms)))
(if (null? tail)
(EVAL form env) ; TCO
(begin
(EVAL form env)
(loop tail))))))))
((if)
(let* ((condition (EVAL (cadr items) env))
(type (and (mal-object? condition)
(mal-type condition))))
(if (memq type '(false nil))
(if (< (length items) 4)
mal-nil
(EVAL (list-ref items 3) env)) ; TCO
(EVAL (list-ref items 2) env)))) ; TCO
((fn*)
(let* ((binds (->list (mal-value (cadr items))))
(binds (map mal-value binds))
(body (list-ref items 2))
(fn (lambda args
(let ((env* (make-env env binds args)))
(EVAL body env*)))))
(make-func body binds env fn)))
(else
(let* ((items (mal-value (eval-ast ast env)))
(op (car items))
(ops (cdr items)))
(if (func? op)
(let* ((outer (func-env op))
(binds (func-params op))
(env* (make-env outer binds ops)))
(EVAL (func-ast op) env*)) ; TCO
(apply op ops)))))))))))
(define (PRINT ast)
(pr-str ast #t))
(define repl-env (make-env #f))
(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns)
(define (rep input)
(PRINT (EVAL (READ input) repl-env)))
(define args (cdr (command-line)))
(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env)))
(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args))))
(rep "(def! not (fn* (a) (if a false true)))")
(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
(define (main)
(let loop ()
(let ((input (readline "user> ")))
(when input
(guard
(ex ((error-object? ex)
(when (not (memv 'empty-input (error-object-irritants ex)))
(display "[error] ")
(display (error-object-message ex))
(newline))))
(display (rep input))
(newline))
(loop))))
(newline))
(if (null? args)
(main)
(rep (string-append "(load-file \"" (car args) "\")")))

155
scheme/step7_quote.scm Normal file
View File

@ -0,0 +1,155 @@
(import (scheme base))
(import (scheme write))
(import (scheme process-context))
(import (lib util))
(import (lib reader))
(import (lib printer))
(import (lib types))
(import (lib env))
(import (lib core))
(define (READ input)
(read-str input))
(define (eval-ast ast env)
(let ((type (and (mal-object? ast) (mal-type ast)))
(value (and (mal-object? ast) (mal-value ast))))
(case type
((symbol) (env-get env value))
((list) (mal-list (map (lambda (item) (EVAL item env)) value)))
((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value)))
((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value)))
(else ast))))
(define (is-pair? ast)
(let ((type (and (mal-object? ast) (mal-type ast))))
(if (memq type '(list vector))
(pair? (->list (mal-value ast)))
#f)))
(define (QUASIQUOTE ast)
(if (not (is-pair? ast))
(mal-list (list (mal-symbol 'quote) ast))
(let* ((items (->list (mal-value ast)))
(a0 (car items)))
(if (and (mal-object? a0)
(eq? (mal-type a0) 'symbol)
(eq? (mal-value a0) 'unquote))
(cadr items)
(if (and (is-pair? a0)
(mal-object? (car (mal-value a0)))
(eq? (mal-type (car (mal-value a0))) 'symbol)
(eq? (mal-value (car (mal-value a0))) 'splice-unquote))
(mal-list (list (mal-symbol 'concat)
(cadr (mal-value a0))
(QUASIQUOTE (mal-list (cdr items)))))
(mal-list (list (mal-symbol 'cons)
(QUASIQUOTE a0)
(QUASIQUOTE (mal-list (cdr items))))))))))
(define (EVAL ast env)
(let ((type (and (mal-object? ast) (mal-type ast))))
(if (not (eq? type 'list))
(eval-ast ast env)
(let ((items (mal-value ast)))
(if (null? items)
ast
(let ((a0 (car items)))
(case (and (mal-object? a0) (mal-value a0))
((def!)
(let ((symbol (mal-value (cadr items)))
(value (EVAL (list-ref items 2) env)))
(env-set env symbol value)
value))
((let*)
(let ((env* (make-env env))
(binds (->list (mal-value (cadr items))))
(form (list-ref items 2)))
(let loop ((binds binds))
(when (pair? binds)
(let ((key (mal-value (car binds))))
(when (null? (cdr binds))
(error "unbalanced list"))
(let ((value (EVAL (cadr binds) env*)))
(env-set env* key value)
(loop (cddr binds))))))
(EVAL form env*))) ; TCO
((do)
(let ((forms (cdr items)))
(if (null? forms)
mal-nil
;; the evaluation order of map is unspecified
(let loop ((forms forms))
(let ((form (car forms))
(tail (cdr forms)))
(if (null? tail)
(EVAL form env) ; TCO
(begin
(EVAL form env)
(loop tail))))))))
((if)
(let* ((condition (EVAL (cadr items) env))
(type (and (mal-object? condition)
(mal-type condition))))
(if (memq type '(false nil))
(if (< (length items) 4)
mal-nil
(EVAL (list-ref items 3) env)) ; TCO
(EVAL (list-ref items 2) env)))) ; TCO
((quote) (cadr items))
((quasiquote) (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO
((fn*)
(let* ((binds (->list (mal-value (cadr items))))
(binds (map mal-value binds))
(body (list-ref items 2))
(fn (lambda args
(let ((env* (make-env env binds args)))
(EVAL body env*)))))
(make-func body binds env fn)))
(else
(let* ((items (mal-value (eval-ast ast env)))
(op (car items))
(ops (cdr items)))
(if (func? op)
(let* ((outer (func-env op))
(binds (func-params op))
(env* (make-env outer binds ops)))
(EVAL (func-ast op) env*)) ; TCO
(apply op ops)))))))))))
(define (PRINT ast)
(pr-str ast #t))
(define repl-env (make-env #f))
(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns)
(define (rep input)
(PRINT (EVAL (READ input) repl-env)))
(define args (cdr (command-line)))
(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env)))
(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args))))
(rep "(def! not (fn* (a) (if a false true)))")
(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
(define (main)
(let loop ()
(let ((input (readline "user> ")))
(when input
(guard
(ex ((error-object? ex)
(when (not (memv 'empty-input (error-object-irritants ex)))
(display "[error] ")
(display (error-object-message ex))
(newline))))
(display (rep input))
(newline))
(loop))))
(newline))
(if (null? args)
(main)
(rep (string-append "(load-file \"" (car args) "\")")))

196
scheme/step8_macros.scm Normal file
View File

@ -0,0 +1,196 @@
(import (scheme base))
(import (scheme write))
(import (scheme process-context))
(import (lib util))
(import (lib reader))
(import (lib printer))
(import (lib types))
(import (lib env))
(import (lib core))
(define (READ input)
(read-str input))
(define (eval-ast ast env)
(let ((type (and (mal-object? ast) (mal-type ast)))
(value (and (mal-object? ast) (mal-value ast))))
(case type
((symbol) (env-get env value))
((list) (mal-list (map (lambda (item) (EVAL item env)) value)))
((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value)))
((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value)))
(else ast))))
(define (is-pair? ast)
(let ((type (and (mal-object? ast) (mal-type ast))))
(if (memq type '(list vector))
(pair? (->list (mal-value ast)))
#f)))
(define (QUASIQUOTE ast)
(if (not (is-pair? ast))
(mal-list (list (mal-symbol 'quote) ast))
(let* ((items (->list (mal-value ast)))
(a0 (car items)))
(if (and (mal-object? a0)
(eq? (mal-type a0) 'symbol)
(eq? (mal-value a0) 'unquote))
(cadr items)
(if (and (is-pair? a0)
(mal-object? (car (mal-value a0)))
(eq? (mal-type (car (mal-value a0))) 'symbol)
(eq? (mal-value (car (mal-value a0))) 'splice-unquote))
(mal-list (list (mal-symbol 'concat)
(cadr (mal-value a0))
(QUASIQUOTE (mal-list (cdr items)))))
(mal-list (list (mal-symbol 'cons)
(QUASIQUOTE a0)
(QUASIQUOTE (mal-list (cdr items))))))))))
(define (is-macro-call? ast env)
(if (mal-instance-of? ast 'list)
(let ((op (car-safe (mal-value ast))))
(if (mal-instance-of? op 'symbol)
(let ((x (env-find env (mal-value op))))
(if x
(if (and (func? x) (func-macro? x))
#t
#f)
#f))
#f))
#f))
(define (macroexpand ast env)
(let loop ((ast ast))
(if (is-macro-call? ast env)
(let* ((items (mal-value ast))
(op (car items))
(ops (cdr items))
(fn (func-fn (env-get env (mal-value op)))))
(loop (apply fn ops)))
ast)))
(define (EVAL ast env)
(let ((type (and (mal-object? ast) (mal-type ast))))
(if (not (eq? type 'list))
(eval-ast ast env)
(if (null? (mal-value ast))
ast
(let* ((ast (macroexpand ast env))
(items (mal-value ast)))
(if (not (mal-instance-of? ast 'list))
(eval-ast ast env)
(let ((a0 (car items)))
(case (and (mal-object? a0) (mal-value a0))
((def!)
(let ((symbol (mal-value (cadr items)))
(value (EVAL (list-ref items 2) env)))
(env-set env symbol value)
value))
((defmacro!)
(let ((symbol (mal-value (cadr items)))
(value (EVAL (list-ref items 2) env)))
(when (func? value)
(func-macro?-set! value #t))
(env-set env symbol value)
value))
((macroexpand)
(macroexpand (cadr items) env))
((let*)
(let ((env* (make-env env))
(binds (->list (mal-value (cadr items))))
(form (list-ref items 2)))
(let loop ((binds binds))
(when (pair? binds)
(let ((key (mal-value (car binds))))
(when (null? (cdr binds))
(error "unbalanced list"))
(let ((value (EVAL (cadr binds) env*)))
(env-set env* key value)
(loop (cddr binds))))))
(EVAL form env*))) ; TCO
((do)
(let ((forms (cdr items)))
(if (null? forms)
mal-nil
;; the evaluation order of map is unspecified
(let loop ((forms forms))
(let ((form (car forms))
(tail (cdr forms)))
(if (null? tail)
(EVAL form env) ; TCO
(begin
(EVAL form env)
(loop tail))))))))
((if)
(let* ((condition (EVAL (cadr items) env))
(type (and (mal-object? condition)
(mal-type condition))))
(if (memq type '(false nil))
(if (< (length items) 4)
mal-nil
(EVAL (list-ref items 3) env)) ; TCO
(EVAL (list-ref items 2) env)))) ; TCO
((quote)
(cadr items))
((quasiquote)
(EVAL (QUASIQUOTE (cadr items)) env)) ; TCO
((fn*)
(let* ((binds (->list (mal-value (cadr items))))
(binds (map mal-value binds))
(body (list-ref items 2))
(fn (lambda args
(let ((env* (make-env env binds args)))
(EVAL body env*)))))
(make-func body binds env fn)))
(else
(let* ((items (mal-value (eval-ast ast env)))
(op (car items))
(ops (cdr items)))
(if (func? op)
(let* ((outer (func-env op))
(binds (func-params op))
(env* (make-env outer binds ops)))
(EVAL (func-ast op) env*)) ; TCO
(apply op ops))))))))))))
(define (PRINT ast)
(pr-str ast #t))
(define repl-env (make-env #f))
(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns)
(define (rep input)
(PRINT (EVAL (READ input) repl-env)))
(define args (cdr (command-line)))
(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env)))
(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args))))
(rep "(def! not (fn* (a) (if a false true)))")
(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
(rep "(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)))))))")
(rep "(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))))))))")
(define (main)
(let loop ()
(let ((input (readline "user> ")))
(when input
(guard
(ex ((error-object? ex)
(when (not (memv 'empty-input (error-object-irritants ex)))
(display "[error] ")
(display (error-object-message ex))
(newline))))
(display (rep input))
(newline))
(loop))))
(newline))
(if (null? args)
(main)
(rep (string-append "(load-file \"" (car args) "\")")))

212
scheme/step9_try.scm Normal file
View File

@ -0,0 +1,212 @@
(import (scheme base))
(import (scheme write))
(import (scheme process-context))
(import (lib util))
(import (lib reader))
(import (lib printer))
(import (lib types))
(import (lib env))
(import (lib core))
(define (READ input)
(read-str input))
(define (eval-ast ast env)
(let ((type (and (mal-object? ast) (mal-type ast)))
(value (and (mal-object? ast) (mal-value ast))))
(case type
((symbol) (env-get env value))
((list) (mal-list (map (lambda (item) (EVAL item env)) value)))
((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value)))
((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value)))
(else ast))))
(define (is-pair? ast)
(let ((type (and (mal-object? ast) (mal-type ast))))
(if (memq type '(list vector))
(pair? (->list (mal-value ast)))
#f)))
(define (QUASIQUOTE ast)
(if (not (is-pair? ast))
(mal-list (list (mal-symbol 'quote) ast))
(let* ((items (->list (mal-value ast)))
(a0 (car items)))
(if (and (mal-object? a0)
(eq? (mal-type a0) 'symbol)
(eq? (mal-value a0) 'unquote))
(cadr items)
(if (and (is-pair? a0)
(mal-object? (car (mal-value a0)))
(eq? (mal-type (car (mal-value a0))) 'symbol)
(eq? (mal-value (car (mal-value a0))) 'splice-unquote))
(mal-list (list (mal-symbol 'concat)
(cadr (mal-value a0))
(QUASIQUOTE (mal-list (cdr items)))))
(mal-list (list (mal-symbol 'cons)
(QUASIQUOTE a0)
(QUASIQUOTE (mal-list (cdr items))))))))))
(define (is-macro-call? ast env)
(if (mal-instance-of? ast 'list)
(let ((op (car-safe (mal-value ast))))
(if (mal-instance-of? op 'symbol)
(let ((x (env-find env (mal-value op))))
(if x
(if (and (func? x) (func-macro? x))
#t
#f)
#f))
#f))
#f))
(define (macroexpand ast env)
(let loop ((ast ast))
(if (is-macro-call? ast env)
(let* ((items (mal-value ast))
(op (car items))
(ops (cdr items))
(fn (func-fn (env-get env (mal-value op)))))
(loop (apply fn ops)))
ast)))
(define (EVAL ast env)
(define (handle-catch value handler)
(let* ((symbol (mal-value (cadr handler)))
(form (list-ref handler 2))
(env* (make-env env (list symbol) (list value))))
(EVAL form env*)))
(let ((type (and (mal-object? ast) (mal-type ast))))
(if (not (eq? type 'list))
(eval-ast ast env)
(if (null? (mal-value ast))
ast
(let* ((ast (macroexpand ast env))
(items (mal-value ast)))
(if (not (mal-instance-of? ast 'list))
(eval-ast ast env)
(let ((a0 (car items)))
(case (and (mal-object? a0) (mal-value a0))
((def!)
(let ((symbol (mal-value (cadr items)))
(value (EVAL (list-ref items 2) env)))
(env-set env symbol value)
value))
((defmacro!)
(let ((symbol (mal-value (cadr items)))
(value (EVAL (list-ref items 2) env)))
(when (func? value)
(func-macro?-set! value #t))
(env-set env symbol value)
value))
((macroexpand)
(macroexpand (cadr items) env))
((try*)
(let* ((form (cadr items))
(handler (mal-value (list-ref items 2))))
(guard
(ex ((error-object? ex)
(handle-catch
(mal-string (error-object-message ex))
handler))
((and (pair? ex) (eq? (car ex) 'user-error))
(handle-catch (cdr ex) handler)))
(EVAL form env))))
((let*)
(let ((env* (make-env env))
(binds (->list (mal-value (cadr items))))
(form (list-ref items 2)))
(let loop ((binds binds))
(when (pair? binds)
(let ((key (mal-value (car binds))))
(when (null? (cdr binds))
(error "unbalanced list"))
(let ((value (EVAL (cadr binds) env*)))
(env-set env* key value)
(loop (cddr binds))))))
(EVAL form env*))) ; TCO
((do)
(let ((forms (cdr items)))
(if (null? forms)
mal-nil
;; the evaluation order of map is unspecified
(let loop ((forms forms))
(let ((form (car forms))
(tail (cdr forms)))
(if (null? tail)
(EVAL form env) ; TCO
(begin
(EVAL form env)
(loop tail))))))))
((if)
(let* ((condition (EVAL (cadr items) env))
(type (and (mal-object? condition)
(mal-type condition))))
(if (memq type '(false nil))
(if (< (length items) 4)
mal-nil
(EVAL (list-ref items 3) env)) ; TCO
(EVAL (list-ref items 2) env)))) ; TCO
((quote)
(cadr items))
((quasiquote)
(EVAL (QUASIQUOTE (cadr items)) env)) ; TCO
((fn*)
(let* ((binds (->list (mal-value (cadr items))))
(binds (map mal-value binds))
(body (list-ref items 2))
(fn (lambda args
(let ((env* (make-env env binds args)))
(EVAL body env*)))))
(make-func body binds env fn)))
(else
(let* ((items (mal-value (eval-ast ast env)))
(op (car items))
(ops (cdr items)))
(if (func? op)
(let* ((outer (func-env op))
(binds (func-params op))
(env* (make-env outer binds ops)))
(EVAL (func-ast op) env*)) ; TCO
(apply op ops))))))))))))
(define (PRINT ast)
(pr-str ast #t))
(define repl-env (make-env #f))
(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns)
(define (rep input)
(PRINT (EVAL (READ input) repl-env)))
(define args (cdr (command-line)))
(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env)))
(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args))))
(rep "(def! not (fn* (a) (if a false true)))")
(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
(rep "(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)))))))")
(rep "(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))))))))")
(define (main)
(let loop ()
(let ((input (readline "user> ")))
(when input
(guard
(ex ((error-object? ex)
(when (not (memv 'empty-input (error-object-irritants ex)))
(display "[error] ")
(display (error-object-message ex))
(newline))))
(display (rep input))
(newline))
(loop))))
(newline))
(if (null? args)
(main)
(rep (string-append "(load-file \"" (car args) "\")")))

217
scheme/stepA_mal.scm Normal file
View File

@ -0,0 +1,217 @@
(import (scheme base))
(import (scheme write))
(import (scheme process-context))
(import (lib util))
(import (lib reader))
(import (lib printer))
(import (lib types))
(import (lib env))
(import (lib core))
(define (READ input)
(read-str input))
(define (eval-ast ast env)
(let ((type (and (mal-object? ast) (mal-type ast)))
(value (and (mal-object? ast) (mal-value ast))))
(case type
((symbol) (env-get env value))
((list) (mal-list (map (lambda (item) (EVAL item env)) value)))
((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value)))
((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value)))
(else ast))))
(define (is-pair? ast)
(let ((type (and (mal-object? ast) (mal-type ast))))
(if (memq type '(list vector))
(pair? (->list (mal-value ast)))
#f)))
(define (QUASIQUOTE ast)
(if (not (is-pair? ast))
(mal-list (list (mal-symbol 'quote) ast))
(let* ((items (->list (mal-value ast)))
(a0 (car items)))
(if (and (mal-object? a0)
(eq? (mal-type a0) 'symbol)
(eq? (mal-value a0) 'unquote))
(cadr items)
(if (and (is-pair? a0)
(mal-object? (car (mal-value a0)))
(eq? (mal-type (car (mal-value a0))) 'symbol)
(eq? (mal-value (car (mal-value a0))) 'splice-unquote))
(mal-list (list (mal-symbol 'concat)
(cadr (mal-value a0))
(QUASIQUOTE (mal-list (cdr items)))))
(mal-list (list (mal-symbol 'cons)
(QUASIQUOTE a0)
(QUASIQUOTE (mal-list (cdr items))))))))))
(define (is-macro-call? ast env)
(if (mal-instance-of? ast 'list)
(let ((op (car-safe (mal-value ast))))
(if (mal-instance-of? op 'symbol)
(let ((x (env-find env (mal-value op))))
(if x
(if (and (func? x) (func-macro? x))
#t
#f)
#f))
#f))
#f))
(define (macroexpand ast env)
(let loop ((ast ast))
(if (is-macro-call? ast env)
(let* ((items (mal-value ast))
(op (car items))
(ops (cdr items))
(fn (func-fn (env-get env (mal-value op)))))
(loop (apply fn ops)))
ast)))
(define (EVAL ast env)
(define (handle-catch value handler)
(let* ((symbol (mal-value (cadr handler)))
(form (list-ref handler 2))
(env* (make-env env (list symbol) (list value))))
(EVAL form env*)))
(let ((type (and (mal-object? ast) (mal-type ast))))
(if (not (eq? type 'list))
(eval-ast ast env)
(if (null? (mal-value ast))
ast
(let* ((ast (macroexpand ast env))
(items (mal-value ast)))
(if (not (mal-instance-of? ast 'list))
(eval-ast ast env)
(let ((a0 (car items)))
(case (and (mal-object? a0) (mal-value a0))
((def!)
(let ((symbol (mal-value (cadr items)))
(value (EVAL (list-ref items 2) env)))
(env-set env symbol value)
value))
((defmacro!)
(let ((symbol (mal-value (cadr items)))
(value (EVAL (list-ref items 2) env)))
(when (func? value)
(func-macro?-set! value #t))
(env-set env symbol value)
value))
((macroexpand)
(macroexpand (cadr items) env))
((try*)
(let* ((form (cadr items))
(handler (mal-value (list-ref items 2))))
(guard
(ex ((error-object? ex)
(handle-catch
(mal-string (error-object-message ex))
handler))
((and (pair? ex) (eq? (car ex) 'user-error))
(handle-catch (cdr ex) handler)))
(EVAL form env))))
((let*)
(let ((env* (make-env env))
(binds (->list (mal-value (cadr items))))
(form (list-ref items 2)))
(let loop ((binds binds))
(when (pair? binds)
(let ((key (mal-value (car binds))))
(when (null? (cdr binds))
(error "unbalanced list"))
(let ((value (EVAL (cadr binds) env*)))
(env-set env* key value)
(loop (cddr binds))))))
(EVAL form env*))) ; TCO
((do)
(let ((forms (cdr items)))
(if (null? forms)
mal-nil
;; the evaluation order of map is unspecified
(let loop ((forms forms))
(let ((form (car forms))
(tail (cdr forms)))
(if (null? tail)
(EVAL form env) ; TCO
(begin
(EVAL form env)
(loop tail))))))))
((if)
(let* ((condition (EVAL (cadr items) env))
(type (and (mal-object? condition)
(mal-type condition))))
(if (memq type '(false nil))
(if (< (length items) 4)
mal-nil
(EVAL (list-ref items 3) env)) ; TCO
(EVAL (list-ref items 2) env)))) ; TCO
((quote)
(cadr items))
((quasiquote)
(EVAL (QUASIQUOTE (cadr items)) env)) ; TCO
((fn*)
(let* ((binds (->list (mal-value (cadr items))))
(binds (map mal-value binds))
(body (list-ref items 2))
(fn (lambda args
(let ((env* (make-env env binds args)))
(EVAL body env*)))))
(make-func body binds env fn)))
(else
(let* ((items (mal-value (eval-ast ast env)))
(op (car items))
(ops (cdr items)))
(if (func? op)
(let* ((outer (func-env op))
(binds (func-params op))
(env* (make-env outer binds ops)))
(EVAL (func-ast op) env*)) ; TCO
(apply op ops))))))))))))
(define (PRINT ast)
(pr-str ast #t))
(define repl-env (make-env #f))
(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns)
(define (rep input)
(PRINT (EVAL (READ input) repl-env)))
(define args (cdr (command-line)))
(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env)))
(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args))))
(let ((scheme (or (get-environment-variable "scheme_MODE") "chibi")))
(env-set repl-env '*host-language* (mal-string (str "scheme (" scheme ")"))))
(rep "(def! not (fn* (a) (if a false true)))")
(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
(rep "(def! *gensym-counter* (atom 0))")
(rep "(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))")
(rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))")
(rep "(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)))))))")
(define (main)
(rep "(println (str \"Mal [\" *host-language* \"]\"))")
(let loop ()
(let ((input (readline "user> ")))
(when input
(guard
(ex ((error-object? ex)
(when (not (memv 'empty-input (error-object-irritants ex)))
(display "[error] ")
(display (error-object-message ex))
(newline))))
(display (rep input))
(newline))
(loop))))
(newline))
(if (null? args)
(main)
(rep (string-append "(load-file \"" (car args) "\")")))

16
scheme/tests/stepA_mal.mal Normal file
View File

@ -0,0 +1,16 @@
;; Testing basic Scheme interop
(scm-eval "(+ 1 1)")
;=>2
(scm-eval "(begin (display \"Hello World!\") (newline))")
; "Hello World!"
(scm-eval "(string->list \"MAL\")")
;=>("M" "A" "L")
(scm-eval "(map + '(1 2 3) '(4 5 6))")
;=>(5 7 9)
(scm-eval "(string-map (lambda (c) (integer->char (+ 65 (modulo (+ (- (char->integer c) 65) 13) 26)))) \"ZNY\")")
;=>"MAL"