mirror of
https://github.com/kanaka/mal.git
synced 2024-09-21 10:37:58 +03:00
Merge pull request #273 from wasamasa/r7rs-implementation
R7RS implementation
This commit is contained in:
commit
de37556cd2
@ -71,6 +71,13 @@ matrix:
|
||||
- {env: IMPL=ruby, services: [docker]}
|
||||
- {env: IMPL=rust, 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=swift NO_DOCKER=1, os: osx, osx_image: xcode7}
|
||||
- {env: IMPL=swift3, services: [docker]}
|
||||
|
15
Makefile
15
Makefile
@ -52,6 +52,8 @@ haxe_MODE = neko
|
||||
matlab_MODE = octave
|
||||
# python, python2 or python3
|
||||
python_MODE = python
|
||||
# scheme (chibi, kawa, gauche, chicken, sagittarius, cyclone, foment)
|
||||
scheme_MODE = chibi
|
||||
|
||||
# Extra options to pass to runtest.py
|
||||
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 \
|
||||
haxe io java julia js kotlin logo lua make mal ocaml matlab miniMAL \
|
||||
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 \
|
||||
vimscript livescript elm
|
||||
python r racket rexx rpython ruby rust scala scheme skew swift swift3 tcl \
|
||||
ts vb vhdl vimscript livescript elm
|
||||
|
||||
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_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_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
|
||||
rust_STEP_TO_PROG = rust/target/release/$($(1))
|
||||
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
|
||||
swift_STEP_TO_PROG = swift/$($(1))
|
||||
swift3_STEP_TO_PROG = swift3/$($(1))
|
||||
|
36
README.md
36
README.md
@ -6,7 +6,7 @@
|
||||
|
||||
Mal is a Clojure inspired Lisp interpreter.
|
||||
|
||||
Mal is implemented in 68 languages:
|
||||
Mal is implemented in 69 languages:
|
||||
|
||||
* Ada
|
||||
* GNU awk
|
||||
@ -68,6 +68,7 @@ Mal is implemented in 68 languages:
|
||||
* Ruby
|
||||
* Rust
|
||||
* Scala
|
||||
* Scheme (R7RS)
|
||||
* Skew
|
||||
* Swift
|
||||
* Swift 3
|
||||
@ -864,6 +865,39 @@ sbt compile
|
||||
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 ###
|
||||
|
||||
*The Skew implementation was created by [Dov Murik](https://github.com/dubek)*
|
||||
|
11
scheme/.gitignore
vendored
Normal file
11
scheme/.gitignore
vendored
Normal 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
59
scheme/Dockerfile
Normal 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
114
scheme/Makefile
Normal 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
0
scheme/eggs/.keep
Normal file
291
scheme/lib/core.sld
Normal file
291
scheme/lib/core.sld
Normal 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
49
scheme/lib/env.sld
Normal 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
62
scheme/lib/printer.sld
Normal 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
178
scheme/lib/reader.sld
Normal 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
70
scheme/lib/types.sld
Normal 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
162
scheme/lib/util.sld
Normal 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
26
scheme/run
Executable 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
33
scheme/step0_repl.scm
Normal 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
36
scheme/step1_read_print.scm
Normal 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
62
scheme/step2_eval.scm
Normal 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
83
scheme/step3_env.scm
Normal 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
111
scheme/step4_if_fn_do.scm
Normal 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
117
scheme/step5_tco.scm
Normal 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
127
scheme/step6_file.scm
Normal 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
155
scheme/step7_quote.scm
Normal 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
196
scheme/step8_macros.scm
Normal 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
212
scheme/step9_try.scm
Normal 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
217
scheme/stepA_mal.scm
Normal 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
16
scheme/tests/stepA_mal.mal
Normal 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"
|
Loading…
Reference in New Issue
Block a user