├── .circleci └── config.yml ├── .gitignore ├── LICENSE.md ├── Makefile ├── README.md ├── btest.yaml ├── examples ├── advanced-dotted-pair.scm ├── bad-lex.scm ├── basic.scm ├── begin.scm ├── callstack.scm ├── car.scm ├── cdr.scm ├── comment.scm ├── compile-basic.scm ├── define-let.scm ├── define-scheme.scm ├── define.scm ├── dino.scm ├── dotted-pair.scm ├── ellipsis-syntax.scm ├── eval-list-proc.scm ├── eval-non-proc.scm ├── eval-simple.scm ├── eval.scm ├── export-hidden.scm ├── external-library.scm ├── if.scm ├── lambda-bind-all-to-symbol.scm ├── lambda.scm ├── let.scm ├── letstar.scm ├── library.scm ├── list-car.scm ├── list.scm ├── many-things.scm ├── map.scm ├── my-let.scm ├── plus.scm ├── quote-eval.scm ├── quote.scm ├── read-eval.scm ├── recursion-tco-begin.scm ├── recursion-tco.scm ├── recursion.scm ├── repeated-cdr.scm ├── set.scm ├── simple-dotted-pair.scm ├── simple-list.scm ├── simple-syntax.scm ├── simple.scm ├── string.scm ├── test.scm ├── test2.scm └── vector.scm ├── src ├── backends │ ├── d │ │ ├── bsdc.d │ │ ├── cg.d │ │ ├── context.d │ │ └── ir.d │ └── interpreter │ │ ├── bsdi.d │ │ ├── lib │ │ ├── bsds │ │ │ └── dbg.d │ │ └── scheme │ │ │ ├── base.d │ │ │ ├── eval.d │ │ │ ├── read.d │ │ │ └── write.d │ │ └── runtime.d ├── buffer.d ├── common.d ├── expand.d ├── lex.d ├── parse.d ├── utility.d └── value.d └── tests ├── bad-fun-call.yaml ├── car-cons.yaml ├── define-begin.yaml ├── define.yaml ├── dotted-pair.yaml ├── ellipsis-syntax.yaml ├── include.yaml ├── lambda-list-arg.yaml ├── lambda-symbol-bind.yaml ├── lambda.yaml ├── let.yaml ├── library-export.yaml ├── library-external.yaml ├── library.yaml ├── list-to-string.yaml ├── make-vector.yaml ├── my-let.yaml ├── quote-eval.yaml ├── quote.yaml ├── read-eval.yaml ├── recursion.yaml ├── set.yaml ├── simple-syntax.yaml ├── string-append.yaml ├── string-case.yaml ├── string-eq.yaml ├── string-fill.yaml ├── string-length.yaml ├── string-ref.yaml ├── string-set.yaml ├── string-to-list.yaml ├── string.yaml ├── stringp.yaml ├── substring.yaml ├── vector-append.yaml └── vector-to-string.yaml /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | jobs: 3 | build: 4 | docker: 5 | - image: dlanguage/ldc 6 | steps: 7 | - checkout 8 | - run: 9 | name: Install debian-packaged dependencies 10 | command: | 11 | apt update 12 | apt install -y git build-essential 13 | ln -s $(which ldc2) /usr/local/bin/ldc 14 | - run: 15 | name: Install btest 16 | command: | 17 | git clone https://github.com/briansteffens/btest 18 | cd btest 19 | make 20 | make install 21 | - run: 22 | name: Install bsdscheme 23 | command: | 24 | make 25 | make install 26 | - run: 27 | name: Run bsdscheme tests 28 | command: btest 29 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | bin 2 | 3 | .btest -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright 2017 Phil Eaton 2 | 3 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 4 | 5 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 6 | 7 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | 9 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 10 | 11 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all install uninstall clean 2 | 3 | all: bin/bsdi bin/bsdc 4 | 5 | bin/bsdi: src/backends/interpreter/*.d src/backends/interpreter/lib/scheme/*.d src/backends/interpreter/lib/bsds/*.d src/*.d 6 | ldc -of $@ $^ 7 | 8 | bin/bsdc: src/backends/d/*.d src/*.d 9 | ldc -of $@ $^ 10 | 11 | install: 12 | ln -s $(CURDIR)/bin/bsdi /usr/local/bin/bsdi 13 | ln -s $(CURDIR)/bin/bsdc /usr/local/bin/bsdc 14 | 15 | uninstall: 16 | rm /usr/local/bin/bsdi 17 | rm /usr/local/bin/bsdc 18 | 19 | clean: 20 | rm -rf bin 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # BSDScheme 2 | 3 | [![CircleCI](https://circleci.com/gh/eatonphil/bsdscheme.svg?style=svg)](https://circleci.com/gh/eatonphil/bsdscheme) 4 | 5 | This is a Scheme implementation written in D intended to eventually 6 | support Scheme R7RS. There is an interpreter backend which is more 7 | mature and there is a compiler backend that targets D. 8 | 9 | ## Installation 10 | 11 | ### Mac 12 | 13 | ``` 14 | $ brew install ldc 15 | $ make 16 | ``` 17 | 18 | ### FreeBSD 19 | 20 | ``` 21 | $ doas pkg install ldc 22 | $ make 23 | ``` 24 | 25 | ## Examples 26 | 27 | ### Recursion 28 | 29 | ``` 30 | $ cat examples/recursion-tco.scm 31 | (define (exp base pow accum) 32 | (if (= pow 0) 33 | accum 34 | (exp base (- pow 1) (* accum base)))) 35 | 36 | (define (main) 37 | (display (exp 2 100 1)) 38 | (newline)) 39 | $ ./bin/bsdi examples/exp.scm 40 | 1267650600228229401496703205376 41 | ``` 42 | 43 | ### Read/eval 44 | 45 | ``` 46 | $ cat examples/read-eval.scm 47 | (display (eval (read "(+ 1 2)"))) 48 | 49 | (newline) 50 | $ ./bin/bsdi examples/read-eval.scm 51 | 3 52 | ``` 53 | 54 | ### REPL 55 | 56 | ``` 57 | $ ./bin/bsdi 58 | BSDScheme v0.0.0 59 | > (define (show it) (display it) (newline)) 60 | > (show '(1 2 3)) 61 | (1 2 3) 62 | > (show (vector-ref #(1 2 3) 1)) 63 | 2 64 | ``` 65 | 66 | ### Compiler (and Macros) 67 | 68 | ``` 69 | $ cat examples/my-let.scm 70 | (define-syntax my-let* 71 | (syntax-rules () 72 | ((_ ((p v)) b ...) 73 | (let ((p v)) b ...)) 74 | ((_ ((p1 v1) (p2 v2) ...) b ...) 75 | (let ((p1 v1)) 76 | (my-let* ((p2 v2) ...) 77 | b ...))))) 78 | 79 | (define (main) 80 | (my-let* ((a 1) 81 | (b (+ a 2))) 82 | (display (+ a b)) 83 | (newline))) 84 | $ ./bin/bsdc examples/my-let.scm 85 | $ ./a 86 | 4 87 | ``` 88 | 89 | ## Current state 90 | 91 | * Supported: 92 | * Literals: strings, characters, boolean, vectors, lists, pairs 93 | * Read / eval / include 94 | * Comments 95 | * Command-line REPL 96 | * `if`, `let`, `define`, `begin` tail calls optimized (interpreter only) 97 | * R7RS Libraries (interpreter only) 98 | * Basic define-syntax/syntax-rules support (not hygienic) 99 | * Missing (but planned, R7RS is the obvious goal): 100 | * Labelled let 101 | * D FFI 102 | * Threading support 103 | 104 | ## Testing 105 | 106 | BSDScheme uses the [btest](https://github.com/briansteffens/btest) test framework. 107 | -------------------------------------------------------------------------------- /btest.yaml: -------------------------------------------------------------------------------- 1 | test_path: tests 2 | 3 | runners: 4 | - name: bsdi 5 | run: bsdi test.scm 6 | -------------------------------------------------------------------------------- /examples/advanced-dotted-pair.scm: -------------------------------------------------------------------------------- 1 | (define (main) 2 | (define a '((a b c) . (d e f))) 3 | (display a) 4 | (newline))) 5 | -------------------------------------------------------------------------------- /examples/bad-lex.scm: -------------------------------------------------------------------------------- 1 | (define f \#t) 2 | -------------------------------------------------------------------------------- /examples/basic.scm: -------------------------------------------------------------------------------- 1 | (display 1) 2 | (newline) 3 | -------------------------------------------------------------------------------- /examples/begin.scm: -------------------------------------------------------------------------------- 1 | (begin 2 | (display 1) 3 | (newline)) 4 | -------------------------------------------------------------------------------- /examples/callstack.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) (scheme write) (bsds dbg)) 2 | 3 | (define (b arg) 4 | (callstack) 5 | (display arg) 6 | (newline)) 7 | 8 | (define (a arg) 9 | (b (+ arg 1))) 10 | 11 | (define (main) 12 | (a 1) 13 | (a (a 2))) 14 | -------------------------------------------------------------------------------- /examples/car.scm: -------------------------------------------------------------------------------- 1 | (define (main) 2 | (define list (cons 2 (cons 1 '()))) 3 | (display (car list)) 4 | (newline)) 5 | -------------------------------------------------------------------------------- /examples/cdr.scm: -------------------------------------------------------------------------------- 1 | (define (main) 2 | (define list '(1 + 2)) 3 | (display (car (cdr list))) 4 | (newline)) 5 | -------------------------------------------------------------------------------- /examples/comment.scm: -------------------------------------------------------------------------------- 1 | ; displays 3 2 | (display (+ 1 2)) 3 | 4 | (newline) 5 | -------------------------------------------------------------------------------- /examples/compile-basic.scm: -------------------------------------------------------------------------------- 1 | (define (plus a b) 2 | (+ a b)) 3 | 4 | (define (main) 5 | (display (plus 1 2)) 6 | (newline)) 7 | -------------------------------------------------------------------------------- /examples/define-let.scm: -------------------------------------------------------------------------------- 1 | (define (main) 2 | (define (r a) (+ (- 3 2) a 3)) 3 | (display (r 7)) 4 | (newline)) 5 | -------------------------------------------------------------------------------- /examples/define-scheme.scm: -------------------------------------------------------------------------------- 1 | (define (main) 2 | (define a (cons 3 (cons 2 (cons 1 (quote ()))))) 3 | (display (car (cdr a))) 4 | (newline)) 5 | -------------------------------------------------------------------------------- /examples/define.scm: -------------------------------------------------------------------------------- 1 | (define (a b c) (- b c)) 2 | 3 | (display (a 2 1)) 4 | 5 | (newline) 6 | -------------------------------------------------------------------------------- /examples/dino.scm: -------------------------------------------------------------------------------- 1 | ; Credit to https://github.com/ddz 2 | ; Someday bsdscheme will run this 3 | 4 | (define map2 5 | (lambda (f ls1 ls2) 6 | (if (null? ls1) 7 | '() 8 | (cons (f (car ls1) (car ls2)) (map2 f (cdr ls1) (cdr ls2)))))) 9 | 10 | (define add1 11 | (lambda (x) 12 | (+ x 1))) 13 | 14 | (define sub1 15 | (lambda (x) 16 | (- x 1))) 17 | 18 | (define alt 19 | (lambda (ls) 20 | (let ((alt-row 1) (alt-col 1)) 21 | (set! alt-row 22 | (lambda (j k ls) 23 | (if (null? ls) 24 | '() 25 | (cons (* j (* k (car ls))) 26 | (alt-row j (* -1 k) (cdr ls)))))) 27 | (set! alt-col 28 | (lambda (l m ls) 29 | (if (null? ls) 30 | '() 31 | (cons (alt-row l m (car ls)) 32 | (alt-col (* -1 l) m (cdr ls)))))) 33 | (if (pair? (car ls)) 34 | (alt-col 1 1 ls) 35 | (alt-row 1 1 ls))))) 36 | 37 | (define sublist 38 | (lambda (ls n m) 39 | (let ((tail 1) (head 1)) 40 | (set! tail 41 | (lambda (ls n) 42 | (if (= n 0) 43 | ls 44 | (tail (cdr ls) (sub1 n))))) 45 | (set! head 46 | (lambda (ls m) 47 | (if (= m 0) 48 | '() 49 | (cons (car ls) (head (cdr ls) (sub1 m)))))) 50 | (head (tail ls n) (- m n))))) 51 | 52 | (define kill-row 53 | (lambda (A r) 54 | (append (sublist A 0 r) 55 | (sublist A (add1 r) (length A))))) 56 | 57 | (define kill-col 58 | (lambda (A c) 59 | (map (lambda (x) (kill-row x c)) A))) 60 | 61 | (define iota 62 | (lambda (n) 63 | (let ((loop 1)) 64 | (set! loop 65 | (lambda (m acc) 66 | (if (= m 0) 67 | acc 68 | (loop (sub1 m) (cons m acc))))) 69 | (loop n '())))) 70 | 71 | (define determinant 72 | (lambda (A) 73 | (let ((n (length A))) 74 | (if (= n 1) 75 | (car (car A)) 76 | (let ((B (kill-row A 0))) 77 | (let ((minors (map (lambda (x) (kill-col B (sub1 x))) (iota n)))) 78 | (let ((cofactors (map determinant minors))) 79 | (apply + (map2 * (alt (list-ref A 0)) cofactors))))))))) 80 | 81 | (define A '((1 2 3 4 5) 82 | (6 -5 4 -3 2) 83 | (1 3 6 2 4) 84 | (3 4 5 -1 -3) 85 | (1 0 -1 0 -1))) 86 | 87 | (define B '((1 2 3 4 5 6) 88 | (6 -5 4 -3 2 -4) 89 | (1 3 6 2 4 2) 90 | (3 4 5 -1 -3 0) 91 | (1 0 -1 0 -1 -1) 92 | (5 4 1 -2 4 -2))) 93 | 94 | (define C '((1 2 3 4 5 6 7) 95 | (6 -5 4 -3 2 -4 2) 96 | (1 3 6 2 4 2 -1) 97 | (3 4 5 -1 -3 0 -2) 98 | (1 0 -1 0 -1 -1 -3) 99 | (5 4 1 -2 4 -2 -4) 100 | (7 6 5 4 3 2 1))) 101 | 102 | (determinant A) 103 | (determinant B) 104 | (determinant C) 105 | -------------------------------------------------------------------------------- /examples/dotted-pair.scm: -------------------------------------------------------------------------------- 1 | (define (main) 2 | (define a (+ 1 . (2))) 3 | (display a) 4 | (newline)) 5 | -------------------------------------------------------------------------------- /examples/ellipsis-syntax.scm: -------------------------------------------------------------------------------- 1 | (define-syntax when 2 | (syntax-rules () 3 | ((when test result ...) 4 | (if test (begin result ...) '())))) 5 | 6 | (define (main) 7 | (when #t 8 | (display "heyy") 9 | (newline) 10 | (newline))) 11 | -------------------------------------------------------------------------------- /examples/eval-list-proc.scm: -------------------------------------------------------------------------------- 1 | (display ((car '(+)) 1 2)) 2 | 3 | (newline) 4 | -------------------------------------------------------------------------------- /examples/eval-non-proc.scm: -------------------------------------------------------------------------------- 1 | ('(car (cons + ())) 1 2) 2 | -------------------------------------------------------------------------------- /examples/eval-simple.scm: -------------------------------------------------------------------------------- 1 | (display (eval '(cons 1 '()))) 2 | 3 | (newline) 4 | -------------------------------------------------------------------------------- /examples/eval.scm: -------------------------------------------------------------------------------- 1 | (define a '(cons 1 (cons 2 ()))) 2 | 3 | (display (car (eval a))) 4 | 5 | (newline) 6 | -------------------------------------------------------------------------------- /examples/export-hidden.scm: -------------------------------------------------------------------------------- 1 | (define-library (helper) 2 | (import (scheme base)) 3 | (begin 4 | (define p 123))) 5 | 6 | (import (scheme base) (scheme write) (helper)) 7 | 8 | (define (main) 9 | (display p)) 10 | -------------------------------------------------------------------------------- /examples/external-library.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) (scheme write)) 2 | 3 | (set! *library-include-path* "examples") 4 | 5 | (import (test2)) 6 | 7 | (define (main) 8 | (display abc) 9 | (newline)) 10 | -------------------------------------------------------------------------------- /examples/if.scm: -------------------------------------------------------------------------------- 1 | (display (if (= 1 1) 2 | (+ 45 5) 3 | (+ 1 2))) 4 | 5 | (newline) 6 | -------------------------------------------------------------------------------- /examples/lambda-bind-all-to-symbol.scm: -------------------------------------------------------------------------------- 1 | (display ((lambda a a) '(1 2 3))) 2 | 3 | (newline) 4 | -------------------------------------------------------------------------------- /examples/lambda.scm: -------------------------------------------------------------------------------- 1 | (define (main) 2 | (define a 1) 3 | (display ((lambda (b) (+ a b)) 12))) 4 | -------------------------------------------------------------------------------- /examples/let.scm: -------------------------------------------------------------------------------- 1 | (define (main) 2 | (display 3 | (let ((a 7) 4 | (b 4)) 5 | (+ (- b 2) a b)))) 6 | -------------------------------------------------------------------------------- /examples/letstar.scm: -------------------------------------------------------------------------------- 1 | (define (main) 2 | (let* ((a 1) 3 | (b (+ 1 a))) 4 | (display (+ a b)) 5 | (newline))) 6 | -------------------------------------------------------------------------------- /examples/library.scm: -------------------------------------------------------------------------------- 1 | (define-library (test) 2 | (import (scheme base)) 3 | (export +) 4 | (begin 5 | (define (+ a b) (- a b)))) 6 | 7 | (import (scheme base) (scheme write)) 8 | 9 | (define (main) 10 | (import (test)) 11 | 12 | (display (+ 7 4)) 13 | (newline)) 14 | -------------------------------------------------------------------------------- /examples/list-car.scm: -------------------------------------------------------------------------------- 1 | (define a '(1 cons 123 8)) 2 | 3 | (display (car (cdr a))) 4 | 5 | (newline) 6 | -------------------------------------------------------------------------------- /examples/list.scm: -------------------------------------------------------------------------------- 1 | (display '(1 cons 4 a)) 2 | 3 | (newline) 4 | -------------------------------------------------------------------------------- /examples/many-things.scm: -------------------------------------------------------------------------------- 1 | (display (+ 1 (- 4 3) (* 1 9))) 2 | -------------------------------------------------------------------------------- /examples/map.scm: -------------------------------------------------------------------------------- 1 | (define (pp a) 2 | (+ a 1)) 3 | 4 | (define (main) 5 | (display (map pp '(1 2 3))) 6 | (newline)) 7 | -------------------------------------------------------------------------------- /examples/my-let.scm: -------------------------------------------------------------------------------- 1 | (define-syntax my-let* 2 | (syntax-rules () 3 | ((_ ((p v)) b ...) 4 | (let ((p v)) b ...)) 5 | ((_ ((p1 v1) (p2 v2) ...) b ...) 6 | (let ((p1 v1)) 7 | (my-let* ((p2 v2) ...) 8 | b ...))))) 9 | 10 | (define (main) 11 | (my-let* ((a 1) 12 | (b (+ a 2))) 13 | (display (+ a b)) 14 | (newline))) 15 | -------------------------------------------------------------------------------- /examples/plus.scm: -------------------------------------------------------------------------------- 1 | (display (+ 1 2)) 2 | -------------------------------------------------------------------------------- /examples/quote-eval.scm: -------------------------------------------------------------------------------- 1 | (define x 3) 2 | 3 | (display (eval 'x)) 4 | 5 | (newline) 6 | -------------------------------------------------------------------------------- /examples/quote.scm: -------------------------------------------------------------------------------- 1 | (define (main) 2 | (display (quote ((+ 1 2) "foo" (- "foo" "bar")))) 3 | (newline)) 4 | -------------------------------------------------------------------------------- /examples/read-eval.scm: -------------------------------------------------------------------------------- 1 | (display (eval (read "(+ 1 2)"))) 2 | 3 | (newline) 4 | -------------------------------------------------------------------------------- /examples/recursion-tco-begin.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) (scheme write) (bsds debug)) 2 | 3 | (define (exp base pow accum) 4 | (if (= pow 0) 5 | accum 6 | (begin (callstack) (exp base (- pow 1) (* accum base))))) 7 | 8 | (define (main) 9 | (display (exp 2 100 1)) 10 | (newline)) 11 | -------------------------------------------------------------------------------- /examples/recursion-tco.scm: -------------------------------------------------------------------------------- 1 | (define (exp base pow accum) 2 | (if (= pow 0) 3 | accum 4 | (exp base (- pow 1) (* accum base)))) 5 | 6 | (define (main) 7 | (display (exp 2 100 1)) 8 | (newline)) 9 | -------------------------------------------------------------------------------- /examples/recursion.scm: -------------------------------------------------------------------------------- 1 | (define (exp base pow) 2 | (if (= pow 0) 3 | 1 4 | (* base (exp base (- pow 1))))) 5 | 6 | (define (main) 7 | (display (exp 2 16)) 8 | (newline)) 9 | -------------------------------------------------------------------------------- /examples/repeated-cdr.scm: -------------------------------------------------------------------------------- 1 | (define a (cons 3 (cons 1 (cons 2 '())))) 2 | 3 | (display (car (cdr (cdr a)))) 4 | 5 | (newline) 6 | -------------------------------------------------------------------------------- /examples/set.scm: -------------------------------------------------------------------------------- 1 | (define (main) 2 | (define a 4) 3 | (set! a 12) 4 | (display a) 5 | (newline)) 6 | -------------------------------------------------------------------------------- /examples/simple-dotted-pair.scm: -------------------------------------------------------------------------------- 1 | (define a '(1 . 2)) 2 | 3 | (display a) 4 | 5 | (newline) 6 | -------------------------------------------------------------------------------- /examples/simple-list.scm: -------------------------------------------------------------------------------- 1 | (display (let ((a 7)) a)) 2 | 3 | (newline) 4 | -------------------------------------------------------------------------------- /examples/simple-syntax.scm: -------------------------------------------------------------------------------- 1 | (define-syntax when 2 | (syntax-rules () 3 | ((when test result) 4 | (if test result '())))) 5 | 6 | (define (main) 7 | (when #t< (display "heyy\n"))) 8 | -------------------------------------------------------------------------------- /examples/simple.scm: -------------------------------------------------------------------------------- 1 | (display (+ 1 2)) 2 | 3 | (newline) 4 | -------------------------------------------------------------------------------- /examples/string.scm: -------------------------------------------------------------------------------- 1 | (define (show it) 2 | (display it) 3 | (newline) 4 | (newline)) 5 | 6 | 7 | (define s "Hello world!") 8 | 9 | (show s) 10 | 11 | (show (string-length s)) 12 | 13 | (show (string-ref s 1)) 14 | 15 | (show (string=? s "Hello world!" s)) 16 | 17 | (show (string=? s "Hello world?")) 18 | 19 | (show (string? 1)) 20 | 21 | (show (string? "foo")) 22 | 23 | (string-set! s 0 #\C) 24 | 25 | (show s) 26 | 27 | (show (string-append s " This is BSDScheme!" " What are you?")) 28 | 29 | (define l '(#\a #\b #\c)) 30 | (show (list->string l)) 31 | 32 | (show (string-upcase s)) 33 | 34 | (show (string-downcase s)) 35 | 36 | (show (substring s 0 5)) 37 | 38 | (show '(1 2 3)) 39 | 40 | (show (string->list s)) 41 | 42 | (string-fill! s #\T) 43 | 44 | (show s) 45 | 46 | (show (string-length s)) 47 | 48 | (define s "Hello") 49 | 50 | (string-fill! s #\T 2 4) 51 | 52 | (show s) 53 | -------------------------------------------------------------------------------- /examples/test.scm: -------------------------------------------------------------------------------- 1 | (display (+ (+ 1 2) 4)) 2 | 3 | (newline) 4 | -------------------------------------------------------------------------------- /examples/test2.scm: -------------------------------------------------------------------------------- 1 | (define-library (test2) 2 | (import (scheme base)) 3 | (export abc) 4 | (begin 5 | (define abc 123))) 6 | -------------------------------------------------------------------------------- /examples/vector.scm: -------------------------------------------------------------------------------- 1 | (define (show it) 2 | (display it) 3 | (newline) 4 | (newline)) 5 | 6 | (define v #(1 2 3)) 7 | 8 | (show v) 9 | 10 | (show (vector-length v)) 11 | 12 | (show (vector-ref v 1)) 13 | 14 | (vector-set! v 1 5) 15 | 16 | (show v) 17 | -------------------------------------------------------------------------------- /src/backends/d/bsdc.d: -------------------------------------------------------------------------------- 1 | import std.array; 2 | import std.algorithm; 3 | import std.file; 4 | import std.format; 5 | import std.functional; 6 | import std.process; 7 | import std.stdio; 8 | 9 | import common; 10 | import expand : expand; 11 | import parse; 12 | import utility; 13 | import value; 14 | 15 | import cg; 16 | import context; 17 | import ir; 18 | 19 | void generate(string outFile, string prologue, IR ir, string epilogue) { 20 | auto f = File(outFile, "w"); 21 | 22 | f.write(prologue); 23 | f.write(CG.fromIR(ir, true)); 24 | f.write(epilogue); 25 | } 26 | 27 | void build(string buildFile, string[] localDImports, string outFile) { 28 | string[] importsWithPath; 29 | 30 | foreach (imp; localDImports) { 31 | importsWithPath ~= format("src/%s", imp); 32 | } 33 | 34 | string[] cmd = ["ldc", buildFile] ~ importsWithPath ~ ["-of", outFile]; 35 | auto execution = execute(cmd); 36 | if (execution.status != 0) { 37 | writeln(execution.output); 38 | } 39 | } 40 | 41 | int main(string[] args) { 42 | auto source = cast(char[])read(args[1]); 43 | Value value = parse.read(source); 44 | value = expand(value); 45 | 46 | auto ctx = Context.getDefault(); 47 | IR ir = IR.fromAST(withBegin(value), ctx); 48 | 49 | string[] dImports = ["std.stdio"]; 50 | string[] localDImports = ["lex", "common", "parse", "utility", "value", "buffer"]; 51 | 52 | string[] prologue; 53 | foreach (imp; dImports ~ localDImports) { 54 | prologue ~= format("import %s;", imp); 55 | } 56 | prologue ~= "\n"; 57 | 58 | string epilogue = "\nvoid main() { BSDScheme_main(nilValue, cast(void**)0); }"; 59 | 60 | auto buildFile = args.length > 2 ? args[2] : "a.d"; 61 | generate(buildFile, prologue.join("\n"), ir, epilogue); 62 | 63 | auto outFile = args.length > 3 ? args[3] : "a"; 64 | build(buildFile, localDImports, outFile); 65 | 66 | return 0; 67 | } 68 | -------------------------------------------------------------------------------- /src/backends/d/cg.d: -------------------------------------------------------------------------------- 1 | import std.array; 2 | import std.format; 3 | import std.stdio; 4 | import std.string; 5 | 6 | import ir; 7 | 8 | void cgError(string error) { 9 | throw new Exception(format("[CG][ERROR]: %s", error)); 10 | } 11 | 12 | void cgWarning(string warning) { 13 | writeln(format("[CG][WARNING]: %s", warning)); 14 | } 15 | 16 | bool nonLiteral(IR arg) { 17 | return cast(VariableIR)arg is null && 18 | cast(LiteralIR!string)arg is null && 19 | cast(LiteralIR!long)arg is null && 20 | cast(LiteralIR!bool)arg is null && 21 | cast(LiteralIR!char)arg is null; 22 | } 23 | 24 | class CG { 25 | static string fromIR(IR ir, bool topLevel) { 26 | if (auto sir = cast(LiteralIR!string)ir) { 27 | return format("makeStringValue(\"%s\")", sir.value); 28 | } else if (auto bir = cast(LiteralIR!bool)ir) { 29 | return format("makeBoolValue(%b)", bir.value); 30 | } else if (auto cir = cast(LiteralIR!char)ir) { 31 | return format("makeCharValue(%c)", cir.value); 32 | } else if (auto iir = cast(LiteralIR!long)ir) { 33 | return format("makeIntegerValue(%d)", iir.value); 34 | } else if (auto nir = cast(NilIR)ir) { 35 | return "nilValue"; 36 | } else if (auto fir = cast(FuncallIR)ir) { 37 | return FuncallCG.fromIR(fir); 38 | } else if (auto dir = cast(DefineFunctionIR)ir) { 39 | return DefineFunctionCG.fromIR(dir); 40 | } else if (auto dir = cast(DefineIR)ir) { 41 | return DefineCG.fromIR(dir); 42 | } else if (auto bir = cast(BeginIR)ir) { 43 | return BeginCG.fromIR(bir, topLevel); 44 | } else if (auto iir = cast(IfIR)ir) { 45 | return IfCG.fromIR(iir); 46 | } else if (auto vir = cast(VariableIR)ir) { 47 | return VariableCG.fromIR(vir); 48 | } else if (auto air = cast(AssignmentIR)ir) { 49 | return AssignmentCG.fromIR(air); 50 | } else if (auto lir = cast(LetXIR)ir) { 51 | return LetCG.fromIR(lir); 52 | } else if (auto mir = cast(MapIR)ir) { 53 | return MapCG.fromIR(mir); 54 | } else if (auto lir = cast(ListIR)ir) { 55 | return ListCG.fromIR(lir); 56 | } else if (auto qir = cast(QuoteIR)ir) { 57 | return QuoteCG.fromIR(qir); 58 | } else { 59 | cgError(format("Invalid IR.")); 60 | assert(0); 61 | } 62 | } 63 | } 64 | 65 | class FuncallCG : CG { 66 | static string fromIR(FuncallIR fir) { 67 | string[] argInitializers; 68 | string[] args; 69 | 70 | string fnInit = fir.init is null ? "" : format("%s;\n\t", CG.fromIR(fir.init, false)); 71 | 72 | foreach (arg; fir.arguments) { 73 | if (nonLiteral(arg)) { 74 | argInitializers ~= CG.fromIR(arg, false); 75 | } 76 | args ~= CG.fromIR(arg.getReturnIR(), false); 77 | } 78 | 79 | string initializers = argInitializers.join(";\n\t"); 80 | if (argInitializers.length) { 81 | initializers ~= ";\n\t"; 82 | } 83 | 84 | return format("%s%s\n\tValue %s = %s(vectorToList([%s]), null)", 85 | fnInit, 86 | initializers, 87 | fir.returnVariable, 88 | fir.name, 89 | args.join(", ")); 90 | } 91 | } 92 | 93 | class DefineFunctionCG : CG { 94 | static string fromIR(DefineFunctionIR fir) { 95 | string functionHeader = format("Value %s(Value %s, void** ctx) {\n\t", fir.name, ARGUMENTS); 96 | string functionFooter = format("}\n"); 97 | 98 | string block = fir.parameters.length ? 99 | format("Value[] %s = listToVector(%s);\n\t", fir.tmp, ARGUMENTS) : 100 | ""; 101 | foreach (i, parameter; fir.parameters) { 102 | block ~= format("Value %s = %s[%d];\n\t", parameter, fir.tmp, i); 103 | } 104 | 105 | block ~= BeginCG.fromIR(fir.block, false); 106 | block ~= format(";\n\treturn %s;\n", CG.fromIR(fir.block.getReturnIR(), false)); 107 | 108 | return format("%s%s%s", functionHeader, block, functionFooter); 109 | } 110 | } 111 | 112 | class BeginCG : CG { 113 | static string fromIR(BeginIR bir, bool topLevel) { 114 | string[] block; 115 | 116 | if (bir.expressions.length) { 117 | foreach (expression; bir.expressions) { 118 | block ~= CG.fromIR(expression, false); 119 | } 120 | } 121 | 122 | if (topLevel) { 123 | return block.join("\n"); 124 | } 125 | return block.join(";\n\t"); 126 | } 127 | } 128 | 129 | class DefineCG : CG { 130 | static string fromIR(DefineIR dir) { 131 | // TODO: support global initialization 132 | return CG.fromIR(dir.value, false); 133 | } 134 | } 135 | 136 | class IfCG : CG { 137 | static string fromIR(IfIR iir) { 138 | string init = nonLiteral(iir.test) ? CG.fromIR(iir.test, false) : ""; 139 | 140 | return format("%s;\n\tValue %s;\n\tif (truthy(%s)) {\n\t%s;\n\t%s = %s;\n\t} else {\n\t%s;\n\t%s = %s;\n\t}", 141 | init, 142 | iir.returnVariable, 143 | CG.fromIR(iir.test.getReturnIR(), false), 144 | CG.fromIR(iir.ifThen, false), 145 | iir.returnVariable, 146 | CG.fromIR(iir.ifThen.getReturnIR(), false), 147 | CG.fromIR(iir.ifElse, false), 148 | iir.returnVariable, 149 | CG.fromIR(iir.ifElse.getReturnIR(), false)); 150 | } 151 | } 152 | 153 | class VariableCG : CG { 154 | static string fromIR(VariableIR vir) { 155 | return vir.name; 156 | } 157 | } 158 | 159 | class AssignmentCG : CG { 160 | static string fromIR(AssignmentIR air) { 161 | string init = nonLiteral(air.value) ? 162 | format("%s;\n\t", CG.fromIR(air.value, false)) : 163 | ""; 164 | 165 | return format("%s%s%s = %s", 166 | init, 167 | air.shadowing ? "" : "Value ", 168 | air.assignTo, 169 | CG.fromIR(air.value.getReturnIR(), false)); 170 | } 171 | } 172 | 173 | class LetCG : CG { 174 | static string fromIR(LetXIR lir) { 175 | string[] assignments; 176 | 177 | foreach (asn; lir.assignments) { 178 | assignments ~= CG.fromIR(asn, false); 179 | } 180 | 181 | return format("%s;\n\t%s", 182 | assignments.join(";\n\t"), 183 | BeginCG.fromIR(lir.block, false)); 184 | } 185 | } 186 | 187 | class MapCG : CG { 188 | static string fromIR(MapIR mir) { 189 | string init = nonLiteral(mir.list) ? CG.fromIR(mir.list, false) : ""; 190 | string tmp = format("Value[] %s", mir.tmp); 191 | string foreachHeaderBody = 192 | format("foreach (item; listToVector(%s)) {\n\t", 193 | CG.fromIR(mir.list.getReturnIR(), false)) ~ 194 | format("%s ~= %s(makeListValue(item, nilValue), null)", 195 | mir.tmp, CG.fromIR(mir.fn, false)); 196 | string foreachFooter = format("}\n\tValue %s = vectorToList(%s)", 197 | mir.returnVariable, mir.tmp); 198 | return [init, tmp, foreachHeaderBody, foreachFooter].join(";\n\t"); 199 | } 200 | } 201 | 202 | class ListCG : CG { 203 | static string fromIR(ListIR lir) { 204 | string[] inits; 205 | string[] returns; 206 | 207 | foreach (e; lir.list) { 208 | if (nonLiteral(e)) { 209 | inits ~= CG.fromIR(e, false); 210 | } 211 | returns ~= CG.fromIR(e.getReturnIR(), false); 212 | } 213 | 214 | string init = inits.join(";\n\t") ~ (inits.length ? ";\n\t" : ""); 215 | 216 | return format("%sValue %s = vectorToList([%s])", 217 | init, 218 | lir.returnVariable, 219 | returns.join(", ")); 220 | } 221 | } 222 | 223 | class QuoteCG : CG { 224 | static string fromIR(QuoteIR qir) { 225 | auto safeSerialized = qir.serialized.translate(['"': "\\\""]); 226 | return format("Value %s = car(read(\"%s\".dup))", qir.tmp, safeSerialized); 227 | } 228 | } 229 | -------------------------------------------------------------------------------- /src/backends/d/context.d: -------------------------------------------------------------------------------- 1 | import std.algorithm; 2 | import std.format; 3 | import std.stdio; 4 | 5 | class Context { 6 | string[string] ctx; 7 | bool[string] tmps; 8 | 9 | this(string[string] initCtx) { 10 | ctx = initCtx; 11 | } 12 | 13 | this() {} 14 | 15 | string set(string key, string value, bool requireUnique) { 16 | if (requireUnique) { 17 | long i = 0; 18 | while (key in ctx) { 19 | key = format("%s_%d", key, i++); 20 | } 21 | } 22 | 23 | ctx[key] = value; 24 | return key; 25 | } 26 | 27 | string set(string key, string value) { 28 | return set(key, value, true); 29 | } 30 | 31 | string get(string key) { 32 | return ctx[key]; 33 | } 34 | 35 | string setTmp(string key) { 36 | long i = 0; 37 | while ((key in tmps) !is null || contains(key)) { 38 | key = format("%s_%d", key, i++); 39 | } 40 | 41 | tmps[key] = true; 42 | return key; 43 | } 44 | 45 | Context dup() { 46 | auto d = new Context; 47 | d.ctx = ctx.dup(); 48 | d.tmps = tmps; 49 | return d; 50 | } 51 | 52 | bool contains(string key) { 53 | return (key in ctx) !is null; 54 | } 55 | 56 | static Context getDefault() { 57 | return new Context([ 58 | "+": "plus", 59 | "-": "minus", 60 | "*": "times", 61 | "=": "equals", 62 | "cons": "cons", 63 | "car": "_car", 64 | "cdr": "_cdr", 65 | "display": "display", 66 | "newline": "newline", 67 | "read": "_read", 68 | "string?": "stringP", 69 | "make-string": "makeString", 70 | "string": "stringFun", 71 | "string-length": "stringLength", 72 | "string-ref": "stringRef", 73 | "string=?": "stringEquals", 74 | "string-append": "stringAppend", 75 | "list->string": "listToString", 76 | "string-upcase": "stringUpcase", 77 | "string-downcase": "stringDowncase", 78 | "substring": "substring", 79 | "string->list": "stringToList", 80 | "vector-length": "vectorLength", 81 | "vector-ref": "vectorRef", 82 | "vector?": "vectorP", 83 | "vector->string": "vectorToString", 84 | "string->vector": "stringToVector", 85 | "vector->list": "_vectorToList", 86 | "list->vector": "_listToVector", 87 | "vector-append": "vectorAppend", 88 | "make-vector": "makeVector", 89 | ]); 90 | } 91 | } 92 | -------------------------------------------------------------------------------- /src/backends/d/ir.d: -------------------------------------------------------------------------------- 1 | import std.format; 2 | import std.stdio; 3 | 4 | import value; 5 | import utility; 6 | 7 | import context; 8 | 9 | void irError(string error) { 10 | throw new Exception(format("[IR][ERROR]: %s", error)); 11 | } 12 | 13 | void irWarning(string warning) { 14 | writeln(format("[IR][WARNING]: %s", warning)); 15 | } 16 | 17 | class IR { 18 | static IR fromAST(Value value, Context ctx) { 19 | switch (tagOfValue(value)) { 20 | case ValueTag.Symbol: 21 | return VariableIR.fromAST(value, ctx); 22 | case ValueTag.String: 23 | auto s = valueToString(value); 24 | return new LiteralIR!string(s); 25 | case ValueTag.Integer: 26 | auto i = valueToInteger(value); 27 | return new LiteralIR!long(i); 28 | case ValueTag.Bool: 29 | auto b = valueToBool(value); 30 | return new LiteralIR!bool(b); 31 | case ValueTag.Char: 32 | auto c = valueToChar(value); 33 | return new LiteralIR!char(c); 34 | case ValueTag.Nil: 35 | return NilIR.get(); 36 | case ValueTag.List: 37 | return FuncallIR.fromAST(value, ctx); 38 | default: 39 | irError(format("Bad value: %s", tagOfValue(value))); 40 | assert(0); 41 | } 42 | } 43 | 44 | IR getReturnIR() { 45 | return this; 46 | } 47 | } 48 | 49 | class NilIR : IR { 50 | static NilIR nir; 51 | 52 | static NilIR get() { 53 | if (NilIR.nir is null) { 54 | NilIR.nir = new NilIR; 55 | } 56 | 57 | return NilIR.nir; 58 | } 59 | } 60 | 61 | class LiteralIR(T) : IR { 62 | T value; 63 | 64 | this(T initValue) { 65 | value = initValue; 66 | } 67 | } 68 | 69 | class VariableIR : IR { 70 | string name; 71 | 72 | // Assumes the variable is already accessible in scope. 73 | this(string initName) { 74 | name = initName; 75 | } 76 | 77 | static VariableIR fromAST(Value value, Context ctx) { 78 | string symbol = valueToSymbol(value); 79 | if (!ctx.contains(symbol)) { 80 | irError(format("Undefined symbol: %s", symbol)); 81 | assert(0); 82 | } 83 | 84 | return new VariableIR(symbol); 85 | } 86 | } 87 | 88 | class FuncallIR : IR { 89 | string name; 90 | string returnVariable; 91 | IR[] arguments; 92 | IR init; 93 | 94 | this(string initName, IR[] initArguments, string initReturnVariable, IR initInit) { 95 | name = initName; 96 | arguments = initArguments; 97 | returnVariable = initReturnVariable; 98 | init = initInit; 99 | } 100 | 101 | this(string initName, IR[] initArguments, string initReturnVariable) { 102 | this(initName, initArguments, initReturnVariable, NilIR.get()); 103 | } 104 | 105 | static IR fromAST(Value value, Context ctx) { 106 | IR init; 107 | auto v = valueToList(value); 108 | 109 | string fn; 110 | if (valueIsSymbol(v[0])) { 111 | string symbol = valueToSymbol(v[0]); 112 | 113 | switch (symbol) { 114 | case "define": 115 | return DefineIR.fromAST(v[1], ctx); 116 | case "begin": 117 | return BeginIR.fromAST(v[1], ctx); 118 | case "if": 119 | return IfIR.fromAST(v[1], ctx); 120 | case "let": 121 | return LetIR.fromAST(v[1], ctx); 122 | case "let*": 123 | return LetStarIR.fromAST(v[1], ctx); 124 | case "set!": 125 | return SetIR.fromAST(v[1], ctx); 126 | case "map": 127 | return MapIR.fromAST(v[1], ctx); 128 | case "apply": 129 | return ApplyIR.fromAST(v[1], ctx); 130 | case "for-each": 131 | return ForeachIR.fromAST(v[1], ctx); 132 | case "list": 133 | return ListIR.fromAST(v[1], ctx); 134 | case "lambda": 135 | return LambdaIR.fromAST(v[1], ctx); 136 | case "quote": 137 | return QuoteIR.fromAST(v[1], ctx); 138 | default: 139 | break; 140 | } 141 | 142 | if (!ctx.contains(symbol)) { 143 | irError(format("Call to unknown function: %s", symbol)); 144 | assert(0); 145 | } 146 | 147 | fn = ctx.get(symbol); 148 | } else if (valueIsList(v[0])) { 149 | init = IR.fromAST(v[0], ctx); 150 | auto returnIR = init.getReturnIR(); 151 | if (auto vir = cast(VariableIR)returnIR) { 152 | fn = vir.name; 153 | } else { 154 | irError(format("Invalid funcall near: %s", formatValue(value))); 155 | } 156 | } 157 | 158 | string returnVariable = ctx.setTmp(format("%s_result", fn)); 159 | auto fir = new FuncallIR(fn, [], returnVariable, init); 160 | 161 | foreach (arg; listToVector(v[1])) { 162 | fir.arguments ~= IR.fromAST(arg, ctx); 163 | } 164 | 165 | return fir; 166 | } 167 | 168 | override IR getReturnIR() { 169 | return new VariableIR(returnVariable); 170 | } 171 | } 172 | 173 | class AssignmentIR : IR { 174 | string assignTo; 175 | IR value; 176 | bool shadowing; 177 | 178 | this(string initAssignTo, IR initValue, bool initShadowing) { 179 | assignTo = initAssignTo; 180 | value = initValue; 181 | shadowing = initShadowing; 182 | } 183 | 184 | this(string assignTo, IR value) { 185 | this(assignTo, value, false); 186 | } 187 | 188 | override IR getReturnIR() { 189 | return new VariableIR(assignTo); 190 | } 191 | } 192 | 193 | const string ARGUMENTS = "arguments"; 194 | 195 | class DefineFunctionIR : IR { 196 | string name; 197 | string tmp; 198 | string[] parameters; 199 | BeginIR block; 200 | 201 | static IR fromAST(Value definition, Value block, Context ctx) { 202 | auto functionName = car(definition); 203 | string symbol = valueToSymbol(functionName); 204 | 205 | auto dir = new DefineFunctionIR; 206 | 207 | if (ctx.contains(symbol)) { 208 | irWarning(format("Shadowing assignment: %s", symbol)); 209 | } 210 | dir.name = symbol == "main" ? "BSDScheme_main" : symbol; 211 | ctx.set(symbol, dir.name, false); 212 | 213 | auto arg2 = cdr(definition); 214 | string[] parameters; 215 | 216 | foreach (i, parameter; listToVector(arg2)) { 217 | string p = valueToString(parameter); 218 | ctx.set(p, "", false); 219 | dir.parameters ~= p; 220 | } 221 | 222 | auto newCtx = ctx.dup(); 223 | newCtx.tmps.clear; 224 | 225 | dir.tmp = newCtx.setTmp("tmp"); 226 | dir.block = BeginIR.fromAST(block, newCtx); 227 | 228 | return dir; 229 | } 230 | 231 | override IR getReturnIR() { 232 | return new VariableIR(name); 233 | } 234 | } 235 | 236 | class DefineIR : IR { 237 | IR value; 238 | 239 | static IR fromAST(Value value, Context ctx) { 240 | auto dir = new DefineIR; 241 | 242 | auto definition = car(value); 243 | 244 | // (define (fn ...) ...) 245 | if (valueIsList(definition)) { 246 | return DefineFunctionIR.fromAST(definition, cdr(value), ctx); 247 | } 248 | 249 | if (!valueIsSymbol(definition)) { 250 | irError("Unexpected define structure"); 251 | assert(0); 252 | } 253 | 254 | string symbol = valueToSymbol(definition); 255 | 256 | auto arg2 = car(cdr(value)); 257 | auto ir = IR.fromAST(arg2, ctx); 258 | 259 | if (ctx.contains(symbol)) { 260 | irWarning(format("Shadowing assignment: %s", symbol)); 261 | } 262 | ctx.set(symbol, symbol, false); 263 | dir.value = new AssignmentIR(symbol, ir); 264 | 265 | return dir; 266 | } 267 | 268 | override IR getReturnIR() { 269 | return value.getReturnIR(); 270 | } 271 | } 272 | 273 | class BeginIR : IR { 274 | IR[] expressions; 275 | 276 | static BeginIR fromAST(Value value, Context ctx) { 277 | auto bir = new BeginIR; 278 | 279 | auto vector = listToVector(value); 280 | foreach (i, arg; vector) { 281 | bir.expressions ~= IR.fromAST(arg, ctx); 282 | } 283 | 284 | return bir; 285 | } 286 | 287 | override IR getReturnIR() { 288 | auto length = this.expressions.length; 289 | if (!length) { 290 | return NilIR.get(); 291 | } 292 | 293 | auto lastExp = this.expressions[length - 1]; 294 | return lastExp.getReturnIR(); 295 | } 296 | } 297 | 298 | class IfIR : IR { 299 | IR test; 300 | IR ifThen; 301 | IR ifElse; 302 | string returnVariable; 303 | 304 | static IfIR fromAST(Value value, Context ctx) { 305 | auto iir = new IfIR; 306 | 307 | auto vector = listToVector(value); 308 | auto arg1 = vector[0]; 309 | iir.test = IR.fromAST(arg1, ctx); 310 | 311 | auto arg2 = vector[1]; 312 | iir.ifThen = IR.fromAST(arg2, ctx); 313 | 314 | auto arg3 = vector.length == 3 ? vector[2] : nilValue; 315 | iir.ifElse = IR.fromAST(arg3, ctx); 316 | 317 | iir.returnVariable = ctx.setTmp("if_result"); 318 | 319 | return iir; 320 | } 321 | 322 | override IR getReturnIR() { 323 | return new VariableIR(returnVariable); 324 | } 325 | } 326 | 327 | LetXIR letXIRFromAST(Value value, Context ctx, bool letStar) { 328 | auto defs = car(value); 329 | auto block = cdr(value); 330 | 331 | auto lir = new LetIR; 332 | foreach (def; listToVector(defs)) { 333 | auto key = valueToString(car(def)); 334 | auto val = car(cdr(def)); 335 | 336 | bool shadowing = ctx.contains(key); 337 | 338 | if (letStar) { 339 | ctx.set(key, "", false); 340 | } 341 | lir.assignments ~= new AssignmentIR(key, IR.fromAST(val, ctx.dup()), shadowing); 342 | if (!letStar) { 343 | ctx.set(key, "", false); 344 | } 345 | } 346 | 347 | auto newCtx = ctx.dup(); 348 | lir.block = BeginIR.fromAST(block, newCtx); 349 | 350 | return lir; 351 | } 352 | 353 | class LetXIR : IR { 354 | AssignmentIR[] assignments; 355 | BeginIR block; 356 | 357 | override IR getReturnIR() { 358 | return block.getReturnIR(); 359 | } 360 | } 361 | 362 | class LetIR : LetXIR { 363 | static LetXIR fromAST(Value value, Context ctx) { 364 | return letXIRFromAST(value, ctx, false); 365 | } 366 | } 367 | 368 | class LetStarIR : LetXIR { 369 | static LetXIR fromAST(Value value, Context ctx) { 370 | return letXIRFromAST(value, ctx, true); 371 | } 372 | } 373 | 374 | class SetIR : IR { 375 | static AssignmentIR fromAST(Value value, Context ctx) { 376 | auto v = listToVector(value); 377 | auto symbol = valueToString(v[0]); 378 | auto val = v[1]; 379 | 380 | if (!ctx.contains(symbol)) { 381 | irError(format("Attempted to set! undefined symbol: %s", symbol)); 382 | } 383 | 384 | return new AssignmentIR(symbol, IR.fromAST(val, ctx), true); 385 | } 386 | } 387 | 388 | class MapIR : IR { 389 | IR fn; 390 | IR list; 391 | string tmp; 392 | string returnVariable; 393 | 394 | static MapIR fromAST(Value value, Context ctx) { 395 | auto v = listToVector(value); 396 | auto mir = new MapIR; 397 | mir.fn = IR.fromAST(v[0], ctx); 398 | mir.list = IR.fromAST(v[1], ctx); 399 | mir.tmp = ctx.setTmp("map_vector_result"); 400 | mir.returnVariable = ctx.setTmp("map_result"); 401 | return mir; 402 | } 403 | 404 | override IR getReturnIR() { 405 | return new VariableIR(returnVariable); 406 | } 407 | } 408 | 409 | class ForeachIR : MapIR { 410 | static ForeachIR fromAST(Value value, Context ctx) { 411 | auto fir = new ForeachIR; 412 | auto mir = MapIR.fromAST(value, ctx); 413 | fir.fn = mir.fn; 414 | fir.list = mir.list; 415 | fir.tmp = mir.tmp; 416 | fir.returnVariable = mir.returnVariable; 417 | delete mir; 418 | return fir; 419 | } 420 | 421 | override IR getReturnIR() { 422 | return NilIR.get(); 423 | } 424 | } 425 | 426 | class ApplyIR : IR { 427 | IR fn; 428 | IR args; 429 | 430 | static IR fromAST(Value value, Context ctx) { 431 | return FuncallIR.fromAST(value, ctx); 432 | } 433 | } 434 | 435 | class ListIR : IR { 436 | IR[] list; 437 | string returnVariable; 438 | 439 | static IR fromAST(Value value, Context ctx) { 440 | auto lir = new ListIR; 441 | foreach (el; listToVector(value)) { 442 | lir.list ~= IR.fromAST(el, ctx); 443 | } 444 | lir.returnVariable = ctx.setTmp("list"); 445 | return lir; 446 | } 447 | 448 | override IR getReturnIR() { 449 | return new VariableIR(returnVariable); 450 | } 451 | } 452 | 453 | class LambdaIR : IR { 454 | static IR fromAST(Value value, Context ctx) { 455 | auto lambdaName = makeStringValue(ctx.setTmp("lambda")); 456 | auto defineArgsTransform = makeListValue(makeListValue(lambdaName, 457 | car(value)), 458 | cdr(value)); 459 | return DefineIR.fromAST(defineArgsTransform, ctx); 460 | } 461 | } 462 | 463 | class QuoteIR : IR { 464 | string tmp; 465 | string serialized; 466 | 467 | static IR fromAST(Value value, Context ctx) { 468 | auto qir = new QuoteIR; 469 | qir.tmp = ctx.setTmp("quoted"); 470 | qir.serialized = formatValue(car(value)); 471 | return qir; 472 | } 473 | 474 | override IR getReturnIR() { 475 | return new VariableIR(tmp); 476 | } 477 | } 478 | -------------------------------------------------------------------------------- /src/backends/interpreter/bsdi.d: -------------------------------------------------------------------------------- 1 | import std.stdio; 2 | import std.string; 3 | 4 | import expand : expand; 5 | import parse; 6 | import utility; 7 | import value; 8 | 9 | import base : include; 10 | import eval : eval; 11 | import runtime; 12 | 13 | void info() { 14 | writeln("BSDScheme v0.0.0"); 15 | } 16 | 17 | void repl() { 18 | string line; 19 | Context ctx = new Context; 20 | write("> "); 21 | while ((line = readln()) !is null) { 22 | line = line.strip(); 23 | 24 | if (line.length) { 25 | Value value = car(read(line.dup)); 26 | value = expand(value); 27 | eval(value, cast(void**)[ctx]); 28 | } 29 | 30 | write("> "); 31 | } 32 | } 33 | 34 | int main(string[] args) { 35 | if (args.length > 1) { 36 | Context ctx = new Context; 37 | auto source = makeStringValue(args[1]); 38 | auto includeArgs = makeListValue(source, nilValue); 39 | include(includeArgs, cast(void**)[ctx]); 40 | 41 | if (!valueIsNil(ctx.get("main", false))) { 42 | auto fn = valueToFunction(ctx.get("main")); 43 | fn[1](nilValue, cast(void**)[ctx]); 44 | } 45 | } else { 46 | info(); 47 | repl(); 48 | } 49 | 50 | return 0; 51 | } 52 | -------------------------------------------------------------------------------- /src/backends/interpreter/lib/bsds/dbg.d: -------------------------------------------------------------------------------- 1 | import std.format; 2 | import std.functional; 3 | import std.stdio; 4 | 5 | import common; 6 | import utility; 7 | import value; 8 | 9 | import runtime; 10 | 11 | Value callstack(Value arguments, void** rest) { 12 | Context ctx = cast(Context)(*rest); 13 | 14 | for (int i = 0; i < ctx.callingContext.index; i++) { 15 | string indent = ""; 16 | for (int j = 0; j < i; j++) { 17 | indent ~= " "; 18 | } 19 | writeln(format("%s%s", indent, ctx.callingContext.buffer[i][0])); 20 | } 21 | return nilValue; 22 | } 23 | 24 | class BSDSDbg : Context { 25 | private this() { 26 | set("callstack", makeFunctionValue("callstack", toDelegate(&callstack), false)); 27 | setSpecial("copy-context", makeCopyContext(null, this)); 28 | } 29 | 30 | private static BSDSDbg instance; 31 | static BSDSDbg getContext() { 32 | if (instance is null) { 33 | instance = new BSDSDbg; 34 | } 35 | 36 | return instance; 37 | } 38 | } 39 | -------------------------------------------------------------------------------- /src/backends/interpreter/lib/scheme/base.d: -------------------------------------------------------------------------------- 1 | import std.file : read; 2 | import std.format; 3 | import std.functional; 4 | import std.stdio; 5 | import std.typecons; 6 | 7 | import common; 8 | import expand : expand; 9 | import utility; 10 | import value; 11 | 12 | import runtime; 13 | 14 | import eval : eval; 15 | 16 | Value ifFun(Value arguments, void** rest) { 17 | auto test = eval(car(arguments), rest); 18 | auto ok = truthy(test); 19 | 20 | auto ifBody = cdr(arguments); 21 | 22 | if (ok) { 23 | return eval(car(ifBody), rest, true); 24 | } 25 | 26 | auto ifElse = cdr(ifBody); 27 | if (valueIsNil(ifElse)) { 28 | return nilValue; 29 | } 30 | 31 | return eval(car(ifElse), rest, true); 32 | } 33 | 34 | Value letVariant(Value arguments, void** rest, bool star, bool rec) { 35 | Context ctx = cast(Context)(*rest); 36 | 37 | auto bindings = car(arguments); 38 | auto letBody = cdr(arguments); 39 | 40 | Context newCtx = ctx.dup; 41 | 42 | auto iterator = bindings; 43 | while (valueIsList(iterator)) { 44 | auto arg = car(iterator); 45 | string key = valueToSymbol(car(arg)); 46 | 47 | Context valueCtx = ctx.dup; 48 | if (star) { 49 | valueCtx = newCtx.dup; 50 | } 51 | 52 | // TODO: handle rec and recstar 53 | 54 | Value value = eval(car(cdr(arg)), cast(void**)[valueCtx]); 55 | newCtx.set(key, value); 56 | 57 | iterator = cdr(iterator); 58 | } 59 | 60 | return eval(withBegin(letBody), cast(void**)[newCtx]); 61 | } 62 | 63 | Value let(Value arguments, void** rest) { 64 | return letVariant(arguments, rest, false, false); 65 | } 66 | 67 | Value letStar(Value arguments, void** rest) { 68 | return letVariant(arguments, rest, true, false); 69 | } 70 | 71 | Value letRec(Value arguments, void** rest) { 72 | return letVariant(arguments, rest, false, true); 73 | } 74 | 75 | Value letRecStar(Value arguments, void** rest) { 76 | return letVariant(arguments, rest, true, true); 77 | } 78 | 79 | Value namedLambda(Value arguments, Context ctx, string name) { 80 | auto funArguments = car(arguments); 81 | auto funBody = cdr(arguments); 82 | 83 | Value defined(Value parameters, void** rest) { 84 | Context newCtx = ctx.dup; 85 | 86 | // Copy the runtime calling context to the new context. 87 | Context runtimeCtx = cast(Context)(*rest); 88 | auto runtimeCallingContext = runtimeCtx.callingContext; 89 | newCtx.callingContext = runtimeCallingContext.dup; 90 | 91 | Value result; 92 | bool tailCalling = false; 93 | while (true) { 94 | if (valueIsList(funArguments)) { 95 | auto keyTmp = valueToList(funArguments); 96 | auto valueTmp = valueToList(parameters); 97 | while (true) { 98 | auto key = valueToSymbol(keyTmp[0]); 99 | auto value = valueTmp[0]; 100 | 101 | newCtx.set(key, value); 102 | 103 | // TODO: handle arg count mismatch 104 | if (valueIsList(keyTmp[1])) { 105 | keyTmp = valueToList(keyTmp[1]); 106 | valueTmp = valueToList(valueTmp[1]); 107 | } else { 108 | break; 109 | } 110 | } 111 | } else if (valueIsSymbol(funArguments)) { 112 | auto key = valueToSymbol(funArguments); 113 | newCtx.set(key, car(parameters)); 114 | } else if (!valueIsNil(funArguments)) { 115 | error("Expected symbol or list in lambda formals", funArguments); 116 | } 117 | 118 | if (!tailCalling) { 119 | newCtx.callingContext.push(Tuple!(string, Delegate)(name, &defined)); 120 | } 121 | 122 | result = eval(withBegin(funBody), cast(void**)[newCtx]); 123 | 124 | if (newCtx.doTailCall == &defined) { 125 | tailCalling = true; 126 | parameters = result; 127 | newCtx.doTailCall = null; 128 | } else { 129 | break; 130 | } 131 | } 132 | 133 | return result; 134 | } 135 | 136 | return makeFunctionValue(name, &defined, false); 137 | } 138 | 139 | Value lambda(Value arguments, void** rest) { 140 | Context ctx = cast(Context)(*rest); 141 | return namedLambda(arguments, ctx, "lambda"); 142 | } 143 | 144 | Value define(Value arguments, void** rest) { 145 | Context ctx = cast(Context)(*rest); 146 | auto tuple = valueToList(arguments); 147 | auto name = valueToSymbol(tuple[0]); 148 | Value value = nilValue; 149 | 150 | // (define (a b) b) 151 | if (valueIsList(tuple[0])) { 152 | auto nameTuple = valueToList(tuple[0]); 153 | name = valueToSymbol(nameTuple[0]); 154 | value = namedLambda(makeListValue(nameTuple[1], tuple[1]), ctx, name); 155 | } else { // (define a) 156 | if (valueIsNil(tuple[1])) { 157 | error("expected value to bind to symbol", tuple[0]); 158 | } else { // (define a 4) 159 | value = eval(valueToList(tuple[1])[0], cast(void**)[ctx]); 160 | } 161 | } 162 | 163 | ctx.set(name, value); 164 | return value; 165 | } 166 | 167 | Value setFun(Value arguments, void** rest) { 168 | Context ctx = cast(Context)(*rest); 169 | auto tuple = valueToList(arguments); 170 | auto name = valueToSymbol(tuple[0]); 171 | auto value = eval(car(tuple[1]), cast(void**)[ctx]); 172 | ctx.set(name, value); 173 | return value; 174 | } 175 | 176 | Value stringSet(Value arguments, void** rest) { 177 | auto arg1 = car(arguments); 178 | auto symbol = valueToSymbol(arg1); 179 | auto value = eval(arg1, rest); 180 | 181 | auto arg2 = eval(car(cdr(arguments)), rest); 182 | long k = valueToInteger(arg2); 183 | 184 | auto arg3 = eval(car(cdr(cdr(arguments))), rest); 185 | char c = valueToChar(arg3); 186 | 187 | updateValueString(value, k, c); 188 | return value; 189 | } 190 | 191 | Value stringFill(Value arguments, void** rest) { 192 | auto arg1 = car(arguments); 193 | string symbol = valueToSymbol(arg1); 194 | auto value = eval(arg1, rest); 195 | char[] s = valueToString(value).dup; 196 | 197 | auto arg2 = eval(car(cdr(arguments)), rest); 198 | char c = valueToChar(arg2); 199 | 200 | long start = 0, end = s.length; 201 | 202 | auto cddr = cdr(cdr(arguments)); 203 | if (!valueIsNil(cddr)) { 204 | auto arg3 = eval(car(cddr), rest); 205 | start = valueToInteger(arg3); 206 | 207 | auto cdddr = cdr(cddr); 208 | if (!valueIsNil(cdddr)) { 209 | auto arg4 = eval(car(cdddr), rest); 210 | end = valueToInteger(arg4); 211 | } 212 | } 213 | 214 | for (long i = start; i < end; i++) { 215 | updateValueString(value, i, c); 216 | } 217 | 218 | return value; 219 | } 220 | 221 | Value vectorFun(Value arguments, void** rest) { 222 | Value[] vector; 223 | auto iterator = car(arguments); 224 | while (!valueIsNil(iterator)) { 225 | vector ~= eval(car(iterator), rest); 226 | iterator = cdr(iterator); 227 | } 228 | 229 | auto f = makeVectorValue(vector); 230 | return f; 231 | } 232 | 233 | Value vectorSet(Value arguments, void** rest) { 234 | auto arg1 = car(arguments); 235 | string symbol = valueToSymbol(arg1); 236 | auto value = eval(arg1, rest); 237 | 238 | auto arg2 = eval(car(cdr(arguments)), rest); 239 | long index = valueToInteger(arg2); 240 | 241 | auto arg3 = eval(car(cdr(cdr(arguments))), rest); 242 | 243 | updateValueVector(value, index, arg3); 244 | return value; 245 | } 246 | 247 | Value vectorFill(Value arguments, void** rest) { 248 | auto arg1 = car(arguments); 249 | string symbol = valueToSymbol(arg1); 250 | auto value = eval(arg1, rest); 251 | auto vector = valueToVector(value); 252 | 253 | auto arg2 = eval(car(cdr(arguments)), rest); 254 | 255 | long start = 0, end = vector.length; 256 | 257 | auto cddr = cdr(cdr(arguments)); 258 | if (!valueIsNil(cddr)) { 259 | auto arg3 = eval(car(cddr), rest); 260 | start = valueToInteger(arg3); 261 | 262 | auto cdddr = cdr(cddr); 263 | if (!valueIsNil(cdddr)) { 264 | auto arg4 = eval(car(cdddr), rest); 265 | end = valueToInteger(arg4); 266 | } 267 | } 268 | 269 | for (long i = start; i < end; i++) { 270 | updateValueVector(value, i, arg2); 271 | } 272 | 273 | return value; 274 | } 275 | 276 | Value include(Value arguments, void** rest) { 277 | Value arg1 = car(arguments); 278 | string includeFile = valueToString(arg1); 279 | string fileContents = (cast(char[])read(includeFile)).dup; 280 | Value source = makeStringValue(fileContents); 281 | Value readArgs = makeListValue(source, nilValue); 282 | Value parsed = _read(readArgs, rest); 283 | parsed = expand(parsed); 284 | return eval(parsed, rest); 285 | } 286 | 287 | class SchemeBase : Context { 288 | private this() { 289 | auto builtins = [ 290 | "+": &plus, 291 | "-": &minus, 292 | "*": ×, 293 | "=": &equals, 294 | "cons": &cons, 295 | "car": &_car, 296 | "cdr": &_cdr, 297 | "newline": &newline, 298 | "string?": &stringP, 299 | "make-string": &makeString, 300 | "string": &stringFun, 301 | "string-length": &stringLength, 302 | "string-ref": &stringRef, 303 | "string=?": &stringEquals, 304 | "string-append": &stringAppend, 305 | "list->string": &listToString, 306 | "string-upcase": &stringUpcase, 307 | "string-downcase": &stringDowncase, 308 | "substring": &substring, 309 | "string->list": &stringToList, 310 | "vector-length": &vectorLength, 311 | "vector-ref": &vectorRef, 312 | "vector?": &vectorP, 313 | "vector->string": &vectorToString, 314 | "string->vector": &stringToVector, 315 | "vector->list": &_vectorToList, 316 | "list->vector": &_listToVector, 317 | "vector-append": &vectorAppend, 318 | "make-vector": &makeVector, 319 | "include": &include, 320 | ]; 321 | 322 | foreach (key, value; builtins) { 323 | set(key, makeFunctionValue(key, toDelegate(value), false)); 324 | } 325 | 326 | auto builtinSpecials = [ 327 | "if": &ifFun, 328 | "let": &let, 329 | "let*": &letStar, 330 | "define": &define, 331 | "lambda": &lambda, 332 | "set!": &setFun, 333 | "quote": "e, 334 | "string-set!": &stringSet, 335 | "string-fill!": &stringFill, 336 | "vector": &vectorFun, 337 | "vector-set!": &vectorSet, 338 | "vector-fill!": &vectorFill, 339 | ]; 340 | 341 | foreach (key, value; builtinSpecials) { 342 | setSpecial(key, toDelegate(value)); 343 | } 344 | 345 | setSpecial("copy-context", makeCopyContext(null, this)); 346 | } 347 | 348 | private static SchemeBase instance; 349 | static SchemeBase getContext() { 350 | if (instance is null) { 351 | instance = new SchemeBase; 352 | } 353 | 354 | return instance; 355 | } 356 | } 357 | -------------------------------------------------------------------------------- /src/backends/interpreter/lib/scheme/eval.d: -------------------------------------------------------------------------------- 1 | import std.functional; 2 | 3 | import common; 4 | import utility; 5 | import value; 6 | 7 | import runtime; 8 | 9 | Value eval(Value value, void** rest, bool tailCallPosition) { 10 | Context ctx = cast(Context)(*rest); 11 | 12 | switch (tagOfValue(value)) { 13 | case ValueTag.Symbol: 14 | return ctx.get(valueToSymbol(value)); 15 | break; 16 | case ValueTag.List: 17 | auto v = valueToList(value); 18 | 19 | auto car = eval(v[0], rest); 20 | auto cdr = v[1]; 21 | 22 | if (!valueIsFunction(car)) { 23 | error("Call of non-procedure", car); 24 | return nilValue; 25 | } 26 | 27 | auto fn = valueToFunction(car); 28 | string fnName = fn[0]; 29 | auto fnDelegate = fn[1]; 30 | bool fnIsSpecial = fn[2]; 31 | 32 | auto args = v[1]; 33 | // Evaluate all arguments unless this is a special function. 34 | if (!fnIsSpecial) { 35 | args = mapValues(toDelegate(&eval), args, rest); 36 | } 37 | 38 | if (tailCallPosition) { 39 | auto cc = ctx.callingContext; 40 | for (int i = 0; i < cc.index; i++) { 41 | auto callStackDelegate = cc.buffer[i][1]; 42 | if (callStackDelegate == fnDelegate) { 43 | ctx.doTailCall = fnDelegate; 44 | return args; 45 | } 46 | } 47 | } 48 | 49 | return fnDelegate(args, rest); 50 | break; 51 | default: 52 | return value; 53 | break; 54 | } 55 | } 56 | 57 | Value eval(Value arguments, void** rest) { 58 | return eval(arguments, rest, false); 59 | } 60 | 61 | Value _eval(Value arguments, void** rest) { 62 | return eval(eval(car(arguments), rest), rest); 63 | } 64 | 65 | class SchemeEval : Context { 66 | private this() { 67 | setSpecial("eval", toDelegate(&_eval)); 68 | setSpecial("copy-context", makeCopyContext(null, this)); 69 | } 70 | 71 | private static SchemeEval instance; 72 | static SchemeEval getContext() { 73 | if (instance is null) { 74 | instance = new SchemeEval; 75 | } 76 | 77 | return instance; 78 | } 79 | } 80 | -------------------------------------------------------------------------------- /src/backends/interpreter/lib/scheme/read.d: -------------------------------------------------------------------------------- 1 | import std.functional; 2 | 3 | import common; 4 | 5 | import runtime; 6 | 7 | class SchemeRead : Context { 8 | private this() { 9 | setSpecial("read", toDelegate(&_read)); 10 | setSpecial("copy-context", makeCopyContext(null, this)); 11 | } 12 | 13 | private static SchemeRead instance; 14 | static SchemeRead getContext() { 15 | if (instance is null) { 16 | instance = new SchemeRead; 17 | } 18 | 19 | return instance; 20 | } 21 | } 22 | -------------------------------------------------------------------------------- /src/backends/interpreter/lib/scheme/write.d: -------------------------------------------------------------------------------- 1 | import std.functional; 2 | 3 | import common; 4 | import value; 5 | 6 | import runtime; 7 | 8 | class SchemeWrite : Context { 9 | private this() { 10 | set("display", makeFunctionValue("display", toDelegate(&display), false)); 11 | setSpecial("copy-context", makeCopyContext(null, this)); 12 | } 13 | 14 | private static SchemeWrite instance; 15 | static SchemeWrite getContext() { 16 | if (instance is null) { 17 | instance = new SchemeWrite; 18 | } 19 | 20 | return instance; 21 | } 22 | } 23 | -------------------------------------------------------------------------------- /src/backends/interpreter/runtime.d: -------------------------------------------------------------------------------- 1 | import core.stdc.stdlib; 2 | import core.vararg; 3 | import std.algorithm; 4 | import std.algorithm.mutation; 5 | import std.bigint; 6 | import std.conv; 7 | import std.format; 8 | import std.functional; 9 | import std.stdio; 10 | import std.string; 11 | import std.typecons; 12 | import std.uni; 13 | 14 | import common; 15 | import value; 16 | import parse; 17 | import utility; 18 | import buffer; 19 | 20 | import dbg; 21 | 22 | import base; 23 | import read; 24 | import write; 25 | import eval : eval, SchemeEval; 26 | 27 | alias Delegate = Value delegate(Value, void**); 28 | alias Function = Value function(Value, void**); 29 | 30 | Value mapValues(Value delegate(Value, void**, bool) f, Value arguments, void** rest) { 31 | Value mapped; 32 | 33 | auto iterator = arguments; 34 | while (valueIsList(iterator)) { 35 | Value mappedElement = f(car(iterator), rest, false); 36 | mapped = appendList(mapped, makeListValue(mappedElement, nilValue)); 37 | iterator = cdr(iterator); 38 | } 39 | 40 | return mapped; 41 | } 42 | 43 | string specsToString(Value arguments) { 44 | string[] specs; 45 | 46 | foreach (spec; listToVector(arguments)) { 47 | if (valueIsList(spec)) { 48 | specs ~= specsToString(spec); 49 | } else { 50 | specs ~= valueToSymbol(spec); 51 | } 52 | } 53 | 54 | return specs.join("."); 55 | } 56 | 57 | Value delegate(Value, void**) makeCopyContext(string[]* exports, Context libraryCtx) { 58 | // TODO: support renaming 59 | Value copyContext(Value arguments, void** rest) { 60 | Context ctx = cast(Context)(*rest); 61 | 62 | if (exports is null) { 63 | foreach (key, value; libraryCtx.map) { 64 | ctx.set(key, value); 65 | } 66 | } else { 67 | foreach (symbol; *exports) { 68 | ctx.set(symbol, libraryCtx.get(symbol)); 69 | } 70 | } 71 | 72 | return nilValue; 73 | } 74 | 75 | return ©Context; 76 | } 77 | 78 | Value defineLibrary(Value arguments, void** rest) { 79 | Context libraryCtx = new Context; 80 | 81 | auto arg1 = car(arguments); 82 | string library = specsToString(arg1); 83 | 84 | string[] exports; 85 | Value _export(Value arguments, void** rest) { 86 | foreach (arg; listToVector(arguments)) { 87 | exports ~= valueToSymbol(arg); 88 | } 89 | return nilValue; 90 | } 91 | 92 | libraryCtx.setSpecial("export", &_export); 93 | 94 | foreach (exp; listToVector(cdr(arguments))) { 95 | eval(exp, cast(void**)[libraryCtx]); 96 | } 97 | 98 | libraryCtx.setSpecial("copy-context", makeCopyContext(&exports, libraryCtx)); 99 | modules[library] = libraryCtx; 100 | 101 | return nilValue; 102 | } 103 | 104 | static Context[string] modules; 105 | 106 | Context getLibraryContext(string path, string lib) { 107 | if (!modules.length) { 108 | auto builtinModules = [ 109 | "scheme.base": SchemeBase.getContext(), 110 | "scheme.read": SchemeRead.getContext(), 111 | "scheme.write": SchemeWrite.getContext(), 112 | "scheme.eval": SchemeEval.getContext(), 113 | "bsds.dbg": BSDSDbg.getContext(), 114 | ]; 115 | 116 | foreach (key, value; builtinModules) { 117 | modules[key] = value; 118 | } 119 | } 120 | 121 | if (lib !in modules) { 122 | auto fileValue = makeStringValue(format("%s/%s.scm", 123 | path, 124 | lib.replace(".", "/"))); 125 | 126 | // Compile the file. 127 | Context ctx = new Context; 128 | include(makeListValue(fileValue, nilValue), cast(void**)[ctx]); 129 | } 130 | 131 | return modules[lib]; 132 | } 133 | 134 | Value _import(Value arguments, void** rest) { 135 | Context ctx = cast(Context)(*rest); 136 | string path = valueToString(ctx.get("*library-include-path*")); 137 | foreach (spec; listToVector(arguments)) { 138 | string lib = valueIsList(spec) ? specsToString(spec) : valueToSymbol(spec); 139 | auto loadCtx = getLibraryContext(path, lib); 140 | 141 | // Copy the exported symbols into the current context. 142 | auto fn = valueToFunction(loadCtx.get("copy-context")); 143 | fn[1](nilValue, cast(void**)[ctx]); 144 | } 145 | 146 | return nilValue; 147 | } 148 | 149 | Value begin(Value arguments, void** rest) { 150 | Value result = arguments; 151 | 152 | auto iterator = arguments; 153 | while (!valueIsNil(iterator)) { 154 | auto exp = car(iterator); 155 | bool tcoPosition = valueIsNil(cdr(iterator)); 156 | result = eval(exp, rest, tcoPosition); 157 | iterator = cdr(iterator); 158 | } 159 | 160 | return result; 161 | } 162 | 163 | class Context { 164 | Buffer!(Tuple!(string, Delegate)) callingContext; 165 | Delegate doTailCall; 166 | Value[string] map; 167 | 168 | this() { 169 | set("*library-include-path*", makeStringValue("src/lib")); 170 | setSpecial("begin", toDelegate(&begin)); 171 | setSpecial("import", toDelegate(&_import)); 172 | setSpecial("define-library", toDelegate(&defineLibrary)); 173 | 174 | callingContext = new Buffer!(Tuple!(string, Delegate))(); 175 | } 176 | 177 | Context dup() { 178 | auto dup = new Context(); 179 | dup.map = map.dup; 180 | dup.callingContext = callingContext.dup; 181 | return dup; 182 | } 183 | 184 | void set(string key, Value value) { 185 | this.map[key] = value; 186 | } 187 | 188 | void setSpecial(string key, Value delegate(Value, void**) value) { 189 | this.map[key] = makeFunctionValue(key, value, true); 190 | } 191 | 192 | Value get(string key, bool failIfNotFound) { 193 | if (key in map) { 194 | return map[key]; 195 | } else if (failIfNotFound) { 196 | error("Undefined symbol", makeSymbolValue(key)); 197 | } 198 | 199 | return nilValue; 200 | } 201 | 202 | Value get(string key) { 203 | return get(key, true); 204 | } 205 | } 206 | -------------------------------------------------------------------------------- /src/buffer.d: -------------------------------------------------------------------------------- 1 | class Buffer(T) { 2 | int index; 3 | T[] buffer; 4 | 5 | this(T[] buffer) { 6 | this.buffer = buffer; 7 | this.index = 0; 8 | } 9 | 10 | this() { 11 | this.buffer = []; 12 | this.buffer.length = 16; 13 | } 14 | 15 | T current() { 16 | return this.buffer[this.index]; 17 | } 18 | 19 | bool next() { 20 | if (this.index + 1 >= this.buffer.length) { 21 | return false; 22 | } 23 | 24 | this.index++; 25 | return true; 26 | } 27 | 28 | void increase(int size) { 29 | this.buffer.length += size; 30 | } 31 | 32 | bool previous() { 33 | if (this.index == 0) { 34 | return false; 35 | } 36 | 37 | this.index--; 38 | return true; 39 | } 40 | 41 | void push(T item) { 42 | if (this.index / this.buffer.length > .75) { 43 | this.buffer.length *= 2; 44 | } 45 | 46 | this.buffer[this.index++] = item; 47 | } 48 | 49 | T pop() { 50 | return this.buffer[this.index--]; 51 | } 52 | 53 | Buffer!T dup() { 54 | auto dup = new Buffer!T(); 55 | dup.buffer = buffer.dup; 56 | dup.index = index; 57 | return dup; 58 | } 59 | } 60 | -------------------------------------------------------------------------------- /src/common.d: -------------------------------------------------------------------------------- 1 | import core.stdc.stdlib; 2 | import core.vararg; 3 | import std.bigint; 4 | import std.format; 5 | import std.functional; 6 | import std.stdio; 7 | import std.uni; 8 | 9 | import value; 10 | import parse; 11 | import utility; 12 | 13 | void error(string msg, Value value) { 14 | writeln(format("[ERROR] %s: %s", msg, formatValue(value))); 15 | exit(1); 16 | } 17 | 18 | Value reduceValues(Value delegate(Value, Value) f, Value arguments, ref Value initial) { 19 | Value result = initial; 20 | 21 | auto iterator = arguments; 22 | while (valueIsList(iterator)) { 23 | result = f(result, car(iterator)); 24 | iterator = cdr(iterator); 25 | } 26 | 27 | return result; 28 | } 29 | 30 | Value plus(Value arguments, void** rest) { 31 | Value _plus(Value previous, Value current) { 32 | if (valueIsBigInteger(previous) || valueIsBigInteger(current)) { 33 | BigInt a, b; 34 | 35 | if (valueIsBigInteger(previous)) { 36 | a = valueToBigInteger(previous); 37 | } else { 38 | a = BigInt(valueToInteger(previous)); 39 | } 40 | 41 | if (valueIsBigInteger(current)) { 42 | b = valueToBigInteger(current); 43 | } else { 44 | b = BigInt(valueToInteger(current)); 45 | } 46 | 47 | return makeBigIntegerValue(a + b); 48 | } 49 | 50 | long a = valueToInteger(previous); 51 | long b = valueToInteger(current); 52 | 53 | if (b > 0 && a > long.max - b || 54 | b < 0 && a < long.max - b) { 55 | BigInt bA = BigInt(a); 56 | BigInt bB = BigInt(b); 57 | return makeBigIntegerValue(bA + bB); 58 | } 59 | 60 | return makeIntegerValue(a + b); 61 | } 62 | 63 | return reduceValues(&_plus, arguments, zeroValue); 64 | } 65 | 66 | Value times(Value arguments, void** rest) { 67 | Value _times(Value previous, Value current) { 68 | if (valueIsBigInteger(previous) || valueIsBigInteger(current)) { 69 | BigInt a, b; 70 | 71 | if (valueIsBigInteger(previous)) { 72 | a = valueToBigInteger(previous); 73 | } else { 74 | a = BigInt(valueToInteger(previous)); 75 | } 76 | 77 | if (valueIsBigInteger(current)) { 78 | b = valueToBigInteger(current); 79 | } else { 80 | b = BigInt(valueToInteger(current)); 81 | } 82 | 83 | return makeBigIntegerValue(a * b); 84 | } 85 | 86 | long a = valueToInteger(previous); 87 | long b = valueToInteger(current); 88 | 89 | if (a > long.max / b) { 90 | BigInt bA = BigInt(a); 91 | BigInt bB = BigInt(b); 92 | return makeBigIntegerValue(bA * bB); 93 | } 94 | 95 | return makeIntegerValue(a * b); 96 | } 97 | 98 | auto tuple = valueToList(arguments); 99 | return reduceValues(&_times, tuple[1], tuple[0]); 100 | } 101 | 102 | // TODO: unify plus and minus 103 | Value minus(Value arguments, void** rest) { 104 | Value _minus(Value previous, Value current) { 105 | if (valueIsBigInteger(previous) || valueIsBigInteger(current)) { 106 | BigInt a, b; 107 | 108 | if (valueIsBigInteger(previous)) { 109 | a = valueToBigInteger(previous); 110 | } else { 111 | a = BigInt(valueToInteger(previous)); 112 | } 113 | 114 | if (valueIsBigInteger(current)) { 115 | b = valueToBigInteger(current); 116 | } else { 117 | b = BigInt(valueToInteger(current)); 118 | } 119 | 120 | return makeBigIntegerValue(a - b); 121 | } 122 | 123 | long a = valueToInteger(previous); 124 | long b = valueToInteger(current); 125 | 126 | if (b > 0 && a > long.max - b || 127 | b < 0 && a < long.max - b) { 128 | BigInt bA = BigInt(a); 129 | BigInt bB = BigInt(b); 130 | return makeBigIntegerValue(bA - bB); 131 | } 132 | 133 | return makeIntegerValue(a - b); 134 | } 135 | 136 | auto tuple = valueToList(arguments); 137 | return reduceValues(&_minus, tuple[1], tuple[0]); 138 | } 139 | 140 | Value equals(Value arguments, void** rest) { 141 | auto tuple = valueToList(arguments); 142 | auto left = tuple[0]; 143 | auto right = car(tuple[1]); 144 | 145 | bool b; 146 | 147 | switch (tagOfValue(left)) { 148 | case ValueTag.Integer: 149 | b = valueIsInteger(right) && valueToInteger(left) == valueToInteger(right); 150 | break; 151 | case ValueTag.Char: 152 | b = valueIsChar(right) && valueToChar(left) == valueToChar(right); 153 | break; 154 | case ValueTag.String: 155 | b = valueIsString(right) && valueToString(left) == valueToString(right); 156 | break; 157 | case ValueTag.Symbol: 158 | b = valueIsSymbol(right) && valueToSymbol(left) == valueToSymbol(right); 159 | break; 160 | case ValueTag.Function: 161 | b = valueIsFunction(right) && valueToFunction(left)[1] == valueToFunction(right)[1]; 162 | break; 163 | case ValueTag.Bool: 164 | b = valueIsBool(right) && valueToBool(left) == valueToBool(right); 165 | break; 166 | default: 167 | b = false; 168 | } 169 | 170 | return makeBoolValue(b); 171 | } 172 | 173 | Value display(Value arguments, void** rest) { 174 | Value head = car(arguments); 175 | write(formatValue(head)); 176 | return nilValue; 177 | } 178 | 179 | Value newline(Value arguments, void** rest) { 180 | write("\n"); 181 | return nilValue; 182 | } 183 | 184 | Value quote(Value arguments, void** rest) { 185 | return car(arguments); 186 | } 187 | 188 | Value cons(Value arguments, void** rest) { 189 | return arguments; 190 | } 191 | 192 | Value _car(Value arguments, void** rest) { 193 | return car(car(arguments)); 194 | } 195 | 196 | Value _cdr(Value arguments, void** rest) { 197 | return valueToList(car(arguments))[1]; 198 | } 199 | 200 | Value begin(Value arguments, void** rest) { 201 | Value result = arguments; 202 | auto tmp = valueToList(arguments); 203 | 204 | while (true) { 205 | result = tmp[0]; 206 | 207 | if (valueIsList(tmp[1])) { 208 | tmp = valueToList(tmp[1]); 209 | } else { 210 | break; 211 | } 212 | } 213 | 214 | return result; 215 | } 216 | 217 | Value stringP(Value arguments, void** rest) { 218 | auto arg1 = car(arguments); 219 | bool b = valueIsString(arg1); 220 | return makeBoolValue(b); 221 | } 222 | 223 | Value makeString(Value arguments, void** rest) { 224 | auto arg1 = car(arguments); 225 | long k = valueToInteger(arg1); 226 | char[] s; 227 | s.length = k; 228 | 229 | char fill = '\0'; 230 | 231 | auto _cdr = cdr(arguments); 232 | if (!valueIsNil(_cdr)) { 233 | auto arg2 = car(_cdr); 234 | fill = valueToChar(arg2); 235 | } 236 | 237 | for (int i = 0; i < k; i++) { 238 | s[i] = fill; 239 | } 240 | 241 | return makeStringValue(s.dup); 242 | } 243 | 244 | Value stringFun(Value arguments, void** rest) { 245 | string s = ""; 246 | 247 | auto iterator = arguments; 248 | while (!valueIsNil(iterator)) { 249 | auto arg = car(iterator); 250 | char c = valueToChar(arg); 251 | s ~= c; 252 | iterator = cdr(iterator); 253 | } 254 | 255 | return makeStringValue(s); 256 | } 257 | 258 | Value stringLength(Value arguments, void** rest) { 259 | auto arg1 = car(arguments); 260 | long l = valueToString(arg1).length; 261 | return makeIntegerValue(l); 262 | } 263 | 264 | Value stringRef(Value arguments, void** rest) { 265 | auto arg1 = car(arguments); 266 | auto arg2 = car(cdr(arguments)); 267 | string s = valueToString(arg1); 268 | long i = valueToInteger(arg2); 269 | return makeCharValue(s[i]); 270 | } 271 | 272 | Value stringEquals(Value arguments, void** rest) { 273 | auto arg1 = car(arguments); 274 | string s = valueToString(arg1); 275 | 276 | auto iterator = cdr(arguments); 277 | while (!valueIsNil(iterator)) { 278 | auto arg = car(iterator); 279 | if (s != valueToString(arg)) { 280 | return makeBoolValue(false); 281 | } 282 | iterator = cdr(iterator); 283 | } 284 | 285 | return makeBoolValue(true); 286 | } 287 | 288 | Value stringAppend(Value arguments, void** rest) { 289 | string s = ""; 290 | 291 | auto iterator = arguments; 292 | while (!valueIsNil(iterator)) { 293 | auto arg = car(iterator); 294 | s ~= valueToString(arg); 295 | iterator = cdr(iterator); 296 | } 297 | 298 | return makeStringValue(s); 299 | } 300 | 301 | Value listToString(Value arguments, void** rest) { 302 | return stringFun(car(arguments), null); 303 | } 304 | 305 | Value stringUpcase(Value arguments, void** rest) { 306 | auto arg1 = car(arguments); 307 | auto s = valueToString(arg1); 308 | return makeStringValue(toUpper(s)); 309 | } 310 | 311 | Value stringDowncase(Value arguments, void** rest) { 312 | auto arg1 = car(arguments); 313 | auto s = valueToString(arg1); 314 | return makeStringValue(toLower(s)); 315 | } 316 | 317 | Value substring(Value arguments, void** rest) { 318 | auto arg1 = car(arguments); 319 | char[] s = valueToString(arg1).dup; 320 | 321 | auto arg2 = car(cdr(arguments)); 322 | long start = valueToInteger(arg2); 323 | 324 | auto arg3 = car(cdr(cdr(arguments))); 325 | long end = valueToInteger(arg3); 326 | 327 | return makeStringValue(s[start .. end].dup); 328 | } 329 | 330 | Value stringToList(Value arguments, void** rest) { 331 | auto arg1 = car(arguments); 332 | char[] s = valueToString(arg1).dup; 333 | 334 | auto value = nilValue; 335 | 336 | foreach (char c; s) { 337 | auto cValue = makeCharValue(c); 338 | auto part = makeListValue(cValue, nilValue); 339 | value = appendList(value, part); 340 | } 341 | 342 | return value; 343 | } 344 | 345 | Value vectorLength(Value arguments, void** rest) { 346 | auto arg1 = car(arguments); 347 | auto vector = valueToVector(arg1); 348 | return makeIntegerValue(vector.length); 349 | } 350 | 351 | Value vectorRef(Value arguments, void** rest) { 352 | auto arg1 = car(arguments); 353 | auto vector = valueToVector(arg1); 354 | 355 | auto arg2 = car(cdr(arguments)); 356 | long i = valueToInteger(arg2); 357 | 358 | return vector[i]; 359 | } 360 | 361 | Value vectorP(Value arguments, void** rest) { 362 | auto arg1 = car(arguments); 363 | return makeBoolValue(valueIsVector(arg1)); 364 | } 365 | 366 | Value vectorToString(Value arguments, void** rest) { 367 | auto arg1 = car(arguments); 368 | auto vector = valueToVector(arg1); 369 | 370 | string s = ""; 371 | 372 | foreach (c; vector) { 373 | s ~= valueToChar(c); 374 | } 375 | 376 | return makeStringValue(s); 377 | } 378 | 379 | Value stringToVector(Value arguments, void** rest) { 380 | auto arg1 = car(arguments); 381 | auto s = valueToString(arg1); 382 | 383 | Value[] v; 384 | 385 | foreach (c; s) { 386 | v ~= makeCharValue(c); 387 | } 388 | 389 | return makeVectorValue(v); 390 | } 391 | 392 | Value _vectorToList(Value arguments, void** rest) { 393 | auto arg1 = car(arguments); 394 | return vectorToList(valueToVector(arg1)); 395 | } 396 | 397 | Value _listToVector(Value arguments, void** rest) { 398 | return makeVectorValue(listToVector(car(arguments))); 399 | } 400 | 401 | Value vectorAppend(Value arguments, void** rest) { 402 | Value[] vector; 403 | 404 | auto iterator = arguments; 405 | while (!valueIsNil(iterator)) { 406 | auto arg = car(iterator); 407 | auto vArg = valueToVector(arg); 408 | vector ~= vArg; 409 | iterator = cdr(iterator); 410 | } 411 | 412 | return makeVectorValue(vector); 413 | } 414 | 415 | Value makeVector(Value arguments, void** rest) { 416 | auto arg1 = car(arguments); 417 | auto k = valueToInteger(arg1); 418 | 419 | char c = '\0'; 420 | auto _cdr = cdr(arguments); 421 | if (!valueIsNil(_cdr)) { 422 | auto arg2 = car(_cdr); 423 | c = valueToChar(arg2); 424 | } 425 | 426 | Value[] v; 427 | v.length = k; 428 | 429 | foreach (i, _; v) { 430 | v[i] = makeCharValue(c); 431 | } 432 | 433 | return makeVectorValue(v); 434 | } 435 | 436 | Value _read(Value arguments, void** rest) { 437 | Value arg1 = car(arguments); 438 | string s = valueToString(arg1); 439 | string sWithBegin = format("(begin %s)", s); 440 | return quote(parse.read(sWithBegin.dup), null); 441 | } 442 | -------------------------------------------------------------------------------- /src/expand.d: -------------------------------------------------------------------------------- 1 | import std.algorithm.searching; 2 | import std.format; 3 | import std.stdio; 4 | import std.typecons; 5 | 6 | import utility; 7 | import value; 8 | 9 | void exError(string error) { 10 | throw new Exception(format("[EX][ERROR]: %s", error)); 11 | } 12 | 13 | void exWarning(string warning) { 14 | writeln(format("[EX][WARNING]: %s", warning)); 15 | } 16 | 17 | alias Extension = Value delegate(Value); 18 | alias Extensions = Extension[string]; 19 | 20 | /* 21 | * (define-syntax (when) 22 | * (syntax-rules () 23 | * ((_ test then ...) 24 | * (if test (begin then ...) '()))))) 25 | * 26 | * (when #t (display "here\n")) 27 | */ 28 | 29 | bool matchRuleAndBind(Value rule, string[] keywords, Value args, ref Value[][string] ctx) { 30 | if (valueIsNil(rule)) { 31 | if (!valueIsNil(args)) { 32 | return false; 33 | } 34 | 35 | return true; 36 | } 37 | 38 | if (valueIsList(rule)) { 39 | auto a1 = args; 40 | if (valueIsList(args)) { 41 | a1 = car(args); 42 | } 43 | 44 | auto r1 = car(rule); 45 | 46 | auto ellipsisMatched = false; 47 | if (valueIsSymbol(r1)) { 48 | auto sym = valueToSymbol(r1); 49 | if (sym == "...") { 50 | if (sym !in ctx) { 51 | ctx["..."] = []; 52 | ellipsisMatched = true; 53 | } 54 | 55 | ctx["..."] ~= args; 56 | 57 | return true; 58 | } 59 | } 60 | 61 | if (!matchRuleAndBind(r1, keywords, a1, ctx)) { 62 | return false; 63 | } 64 | 65 | if (valueIsList(args) && !matchRuleAndBind(cdr(rule), keywords, cdr(args), ctx)) { 66 | return false; 67 | } 68 | 69 | return true; 70 | } else { 71 | auto rSym = valueToSymbol(rule); 72 | 73 | // Match keyword 74 | if (keywords.canFind(rSym)) { 75 | if (valueIsSymbol(args) && valueToSymbol(args) == rSym) { 76 | return false; 77 | } 78 | 79 | return true; 80 | } 81 | 82 | switch (rSym) { 83 | case "_": // Match anything/nothing; 84 | return true; 85 | case "...": 86 | // Already handled in the above case. 87 | return true; 88 | default: 89 | ctx[rSym] = [args]; 90 | return true; 91 | } 92 | } 93 | 94 | return false; 95 | } 96 | 97 | Value bindTransformation(Value tfm, Value[][string] bindings) { 98 | if (valueIsNil(tfm)) { 99 | return tfm; 100 | } else if (valueIsList(tfm)) { 101 | auto _car = bindTransformation(car(tfm), bindings); 102 | auto _cdr = bindTransformation(cdr(tfm), bindings); 103 | 104 | if (valueIsList(_cdr)) { 105 | auto cadr = car(cdr(tfm)); 106 | if (valueIsSymbol(cadr) && valueToSymbol(cadr) == "...") { 107 | if ("..." !in bindings) { 108 | exError(format("No matching ellipsis to bind near '%s'", formatValue(tfm))); 109 | assert(0); 110 | } 111 | 112 | if (bindings["..."].length == 1) { 113 | bindings["..."] = []; 114 | } else { 115 | bindings["..."] = bindings["..."][1 .. bindings["..."].length]; 116 | } 117 | return appendList(makeListValue(_car, nilValue), car(_cdr)); 118 | } 119 | } 120 | return makeListValue(_car, _cdr); 121 | } else { 122 | auto sym = valueToSymbol(tfm); 123 | if (sym in bindings) { 124 | return bindings[sym][0]; 125 | } 126 | 127 | return tfm; 128 | } 129 | } 130 | 131 | Extension syntaxRules(Value ast) { 132 | auto _keywords = listToVector(car(ast)); 133 | auto rules = listToVector(cdr(ast)); 134 | string[] keywords; 135 | 136 | foreach (k; _keywords) { 137 | keywords ~= valueToSymbol(k); 138 | } 139 | 140 | return delegate Value (Value ast) { 141 | foreach (i, ruleAndTransformation; rules) { 142 | auto rule = car(ruleAndTransformation); 143 | auto tfm = car(cdr(ruleAndTransformation)); 144 | Value[][string] ctx = [" ": [nilValue]]; 145 | auto matched = matchRuleAndBind(rule, keywords, ast, ctx); 146 | if (matched) { 147 | return bindTransformation(tfm, ctx); 148 | } 149 | } 150 | 151 | exError(format("Syntax did not match any patterns: %s", formatValue(ast))); 152 | assert(0); 153 | }; 154 | } 155 | 156 | Extension makeTransformer(Value transformerAst) { 157 | auto _cdr = cdr(transformerAst); 158 | auto transformer = valueToString(car(transformerAst)); 159 | switch (transformer) { 160 | case "syntax-rules": 161 | return syntaxRules(_cdr); 162 | default: 163 | exError(format("%s syntax transformer is not supported: ", formatValue(transformerAst))); 164 | assert(0); 165 | } 166 | } 167 | 168 | void defineSyntax(Value ast, ref Extensions extensions) { 169 | auto dispatcher = valueToString(car(ast)); 170 | auto transformer = car(cdr(ast)); 171 | extensions[dispatcher] = makeTransformer(transformer); 172 | } 173 | 174 | Value _expand(Value ast, ref Extensions extensions) { 175 | if (valueIsList(ast)) { 176 | if (valueIsSymbol(car(ast))) { 177 | auto sym = valueToSymbol(car(ast)); 178 | switch (sym) { 179 | case "define-syntax": 180 | defineSyntax(cdr(ast), extensions); 181 | return nilValue; 182 | case "let-syntax": 183 | writeln("let-syntax not supported yet"); 184 | assert(0); 185 | case "letrec-syntax": 186 | writeln("letrec-syntax not supported yet"); 187 | assert(0); 188 | case "syntax-error": 189 | writeln("Syntax error"); 190 | assert(0); 191 | default: 192 | if (sym in extensions) { 193 | return _expand(extensions[sym](ast), extensions); 194 | } 195 | } 196 | } 197 | 198 | auto _car = _expand(car(ast), extensions); 199 | auto _cdr = _expand(cdr(ast), extensions); 200 | return makeListValue(_car, _cdr); 201 | } 202 | 203 | return ast; 204 | } 205 | 206 | Value expand(Value ast) { 207 | Value delegate(Value)[string] syntaxExtensions; 208 | 209 | // Filter out nilValues in top-level 210 | auto values = listToVector(_expand(ast, syntaxExtensions)); 211 | Value[] r; 212 | foreach (v; values) { 213 | if (valueIsNil(v)) { 214 | continue; 215 | } 216 | 217 | r ~= v; 218 | } 219 | 220 | return vectorToList(r); 221 | } 222 | -------------------------------------------------------------------------------- /src/lex.d: -------------------------------------------------------------------------------- 1 | import std.conv; 2 | import std.string; 3 | import std.stdio; 4 | 5 | import buffer; 6 | 7 | enum TokenType { 8 | LeftParen, 9 | RightParen, 10 | Special, 11 | Atom, 12 | Dot, 13 | } 14 | 15 | enum SchemeType { 16 | String, 17 | Char, 18 | Symbol, 19 | Integer, 20 | Bool, 21 | } 22 | 23 | struct Token { 24 | int line; 25 | int lineOffset; 26 | string filename; 27 | string value; 28 | TokenType type; 29 | SchemeType schemeType; 30 | } 31 | 32 | alias Buffer!(char) StringBuffer; 33 | 34 | Token* lexLeftParen(StringBuffer input, int line, int column) { 35 | char c = input.current(); 36 | if (c == '(' || c == '[') { 37 | return new Token(line, column, "", to!string(c), TokenType.LeftParen); 38 | } 39 | 40 | return null; 41 | } 42 | 43 | Token* lexRightParen(StringBuffer input, int line, int column) { 44 | char c = input.current(); 45 | if (c == ')' || c == ']') { 46 | return new Token(line, column, "", to!string(c), TokenType.RightParen); 47 | } 48 | 49 | return null; 50 | } 51 | 52 | Token* lexQuote(StringBuffer input, int line, int column) { 53 | if (input.current() == '\'') { 54 | return new Token(line, column, "", "quote", TokenType.Special, SchemeType.Symbol); 55 | } 56 | 57 | return null; 58 | } 59 | 60 | Token* lexBool(StringBuffer input, int line, ref int column) { 61 | if (input.current() == '#') { 62 | input.next(); 63 | 64 | column++; 65 | auto c = input.current(); 66 | if (c == 't' || c == 'f') { 67 | column++; 68 | input.next(); 69 | return new Token(line, column, "", format("#%c", c), TokenType.Atom, SchemeType.Bool); 70 | } 71 | 72 | column--; 73 | input.previous(); 74 | } 75 | 76 | return null; 77 | } 78 | 79 | Token* lexChar(StringBuffer input, int line, ref int column) { 80 | if (input.current() == '#') { 81 | input.next(); 82 | column++; 83 | 84 | if (input.current() == '\\') { 85 | column++; 86 | input.next(); 87 | 88 | char[1] s = [input.current()]; 89 | return new Token(line, column, "", s.dup, TokenType.Atom, SchemeType.Char); 90 | } 91 | 92 | column--; 93 | input.previous(); 94 | } 95 | 96 | return null; 97 | } 98 | 99 | Token* lexSymbol(StringBuffer input, int line, ref int column) { 100 | char[] symbol; 101 | 102 | loop: do { 103 | auto c = input.current(); 104 | 105 | switch (c) { 106 | case '(': 107 | case ')': 108 | case '#': 109 | case '\'': 110 | case ' ': 111 | case '\n': 112 | case '\t': 113 | case '"': 114 | case '[': 115 | case ']': 116 | break loop; 117 | break; 118 | default: 119 | column++; 120 | symbol ~= c; 121 | } 122 | } while (input.next()); 123 | 124 | if (symbol.length) { 125 | column--; 126 | input.previous(); 127 | 128 | auto schemeType = SchemeType.Symbol; 129 | if (isNumeric(symbol)) { 130 | schemeType = SchemeType.Integer; 131 | } 132 | 133 | return new Token(line, column, "", symbol.dup, TokenType.Atom, schemeType); 134 | } 135 | 136 | return null; 137 | } 138 | 139 | Token* lexString(StringBuffer input, int line, ref int column) { 140 | char[] s; 141 | 142 | if (input.current() != '"') { 143 | return null; 144 | } 145 | 146 | column++; 147 | input.next(); 148 | 149 | do { 150 | auto c = input.current(); 151 | 152 | if (c == '"') { 153 | break; 154 | } 155 | 156 | column++; 157 | s ~= c; 158 | } while (input.next()); 159 | 160 | if (s.length) { 161 | auto schemeType = SchemeType.String; 162 | return new Token(line, column, "", s.dup, TokenType.Atom, schemeType); 163 | } 164 | 165 | return null; 166 | } 167 | 168 | Token* lexVector(StringBuffer input, int line, int column) { 169 | if (input.current() == '#') { 170 | input.next(); 171 | char c = input.current(); 172 | input.previous(); 173 | 174 | if (c == '(') { 175 | return new Token(line, column, "", "vector", TokenType.Special, SchemeType.Symbol); 176 | } 177 | } 178 | 179 | return null; 180 | } 181 | 182 | Token* lexDot(StringBuffer input, int line, int column) { 183 | if (input.current() == '.') { 184 | input.next(); 185 | if (input.current() == '.') { 186 | input.previous(); 187 | return null; 188 | } 189 | 190 | // Match single dot only. 191 | return new Token(line, column, "", ".", TokenType.Dot, SchemeType.Symbol); 192 | } 193 | 194 | return null; 195 | } 196 | 197 | Token* lexComment(StringBuffer input, int line, ref int column) { 198 | if (input.current() == ';') { 199 | do { 200 | column++; 201 | if (input.current() == '\n') { 202 | break; 203 | } 204 | } while (input.next()); 205 | } 206 | 207 | return null; 208 | } 209 | 210 | alias Buffer!(Token*) TokenBuffer; 211 | 212 | TokenBuffer lex(StringBuffer input) { 213 | auto tokens = new TokenBuffer(); 214 | 215 | int line = 1; 216 | int column = 0; 217 | do { 218 | column++; 219 | 220 | auto token = lexLeftParen(input, line, column); 221 | if (token is null) { 222 | token = lexRightParen(input, line, column); 223 | } 224 | 225 | if (token is null) { 226 | token = lexRightParen(input, line, column); 227 | } 228 | 229 | if (token is null) { 230 | token = lexQuote(input, line, column); 231 | } 232 | 233 | if (token is null) { 234 | token = lexDot(input, line, column); 235 | } 236 | 237 | if (token is null) { 238 | token = lexSymbol(input, line, column); 239 | } 240 | 241 | if (token is null) { 242 | token = lexChar(input, line, column); 243 | } 244 | 245 | if (token is null) { 246 | token = lexBool(input, line, column); 247 | } 248 | 249 | if (token is null) { 250 | token = lexString(input, line, column); 251 | } 252 | 253 | if (token is null) { 254 | token = lexComment(input, line, column); 255 | } 256 | 257 | if (token is null) { 258 | token = lexVector(input, line, column); 259 | } 260 | 261 | if (token !is null) { 262 | tokens.push(token); 263 | } else { 264 | char c = input.current(); 265 | 266 | if (c == '\n') { 267 | line++; 268 | column = -1; 269 | continue; 270 | } 271 | 272 | if (c == ' ' || c == '\t') { 273 | continue; 274 | } 275 | 276 | throw new Exception(format("[LEX]: Unexpected token at (%d, %d): %c", line, column, input.current())); 277 | } 278 | } while (input.next()); 279 | 280 | return tokens; 281 | } 282 | 283 | TokenBuffer lex(char[] input) { 284 | return lex(new StringBuffer(input)); 285 | } 286 | -------------------------------------------------------------------------------- /src/parse.d: -------------------------------------------------------------------------------- 1 | import std.typecons; 2 | import std.conv; 3 | import std.stdio; 4 | 5 | import value; 6 | import lex : lex, Token, TokenType, SchemeType; 7 | import utility; 8 | 9 | Tuple!(Token*[], Value) parse(Token*[] tokens) { 10 | Value list; 11 | int i = 0; 12 | 13 | while (true) { 14 | if (i == tokens.length || tokens[i] is null) { 15 | break; 16 | } 17 | 18 | auto token = tokens[i]; 19 | 20 | switch (token.type) { 21 | case TokenType.LeftParen: 22 | auto program = parse(tokens[i + 1 .. tokens.length]); 23 | auto tmp = program[1]; 24 | list = appendList(list, makeListValue(tmp, nilValue)); 25 | i = -1; 26 | tokens = program[0]; 27 | break; 28 | case TokenType.RightParen: 29 | return Tuple!(Token*[], Value)(tokens[i + 1 .. tokens.length], list); 30 | break; 31 | case TokenType.Dot: 32 | auto nextToken = tokens[i + 1]; 33 | bool cdrIsList = nextToken.type == TokenType.LeftParen; 34 | 35 | auto program = parse(tokens[i + 1 .. tokens.length]); 36 | auto pTuple = valueToList(program[1]); 37 | auto tuple = valueToList(list); 38 | 39 | if (cdrIsList) { 40 | list = appendList(list, pTuple[0]); 41 | } else { 42 | list = makeListValue(tuple[0], pTuple[0]); 43 | } 44 | 45 | return Tuple!(Token*[], Value)(program[0], list); 46 | break; 47 | case TokenType.Special: 48 | Value symbol = makeSymbolValue(token.value); 49 | 50 | auto program = parse(tokens[i + 1 .. tokens.length]); 51 | auto special = makeListValue(symbol, program[1]); 52 | list = appendList(list, makeListValue(special, nilValue)); 53 | 54 | tokens = [new Token(0, 0, "", ")", TokenType.RightParen)]; 55 | foreach (nextToken; program[0]) { 56 | tokens ~= nextToken; 57 | } 58 | 59 | i = -1; 60 | break; 61 | default: 62 | Value atom; 63 | switch (token.schemeType) { 64 | case SchemeType.Bool: 65 | atom = token.value == "#t" ? trueValue : falseValue; 66 | break; 67 | case SchemeType.Integer: 68 | atom = makeIntegerValue(to!int(token.value)); 69 | break; 70 | case SchemeType.String: 71 | atom = makeStringValue(token.value); 72 | break; 73 | case SchemeType.Char: 74 | atom = makeCharValue(token.value[0]); 75 | break; 76 | default: 77 | atom = makeSymbolValue(token.value); 78 | break; 79 | } 80 | list = appendList(list, makeListValue(atom, nilValue)); 81 | } 82 | 83 | i += 1; 84 | } 85 | 86 | ret: 87 | 88 | if (i > 0) { 89 | return Tuple!(Token*[], Value)(tokens[i + 1 .. tokens.length], list); 90 | } 91 | 92 | return Tuple!(Token*[], Value)([], list); 93 | } 94 | 95 | Value read(char[] source) { 96 | auto tokens = lex(source); 97 | auto buffer = tokens.buffer; 98 | Token*[] filteredBuffer; 99 | foreach (token; buffer) { 100 | if (token !is null) { 101 | filteredBuffer ~= token; 102 | } 103 | } 104 | return parse(filteredBuffer)[1]; 105 | } 106 | -------------------------------------------------------------------------------- /src/utility.d: -------------------------------------------------------------------------------- 1 | import value; 2 | 3 | Value nilValue = { data: 0, header: ValueTag.Nil }; 4 | Value zeroValue = makeIntegerValue(0); 5 | Value trueValue = makeBoolValue(true); 6 | Value falseValue = makeBoolValue(false); 7 | 8 | Value appendList(Value l1, Value l2) { 9 | if (valueIsNil(l1)) { 10 | return l2; 11 | } 12 | 13 | auto tuple = valueToList(l1); 14 | Value car = tuple[0]; 15 | Value cdr = appendList(tuple[1], l2); 16 | return makeListValue(car, cdr); 17 | } 18 | 19 | Value reverseList(Value value) { 20 | if (valueIsList(value)) { 21 | auto tuple = valueToList(value); 22 | return appendList(reverseList(tuple[1]), 23 | makeListValue(tuple[0], nilValue)); 24 | } 25 | 26 | return value; 27 | } 28 | 29 | Value car(Value arguments) { 30 | return valueToList(arguments)[0]; 31 | } 32 | 33 | Value cdr(Value arguments) { 34 | return valueToList(arguments)[1]; 35 | } 36 | 37 | Value[] listToVector(Value list) { 38 | Value[] vector; 39 | while (!valueIsNil(list)) { 40 | vector ~= car(list); 41 | list = cdr(list); 42 | } 43 | return vector; 44 | } 45 | 46 | Value vectorToList(Value[] vector) { 47 | Value list; 48 | foreach (i; vector) { 49 | list = appendList(list, makeListValue(i, nilValue)); 50 | } 51 | return list; 52 | } 53 | 54 | Value withBegin(Value beginBody) { 55 | Value begin = makeSymbolValue("begin"); 56 | Value beginList = makeListValue(begin, nilValue); 57 | return appendList(beginList, beginBody); 58 | } 59 | 60 | bool truthy(Value test) { 61 | return valueIsInteger(test) && valueToInteger(test) || 62 | valueIsString(test) && valueToString(test).length || 63 | valueIsSymbol(test) || 64 | valueIsFunction(test) || 65 | valueIsBool(test) && valueToBool(test); 66 | } 67 | -------------------------------------------------------------------------------- /src/value.d: -------------------------------------------------------------------------------- 1 | import std.bigint; 2 | import std.conv; 3 | import std.math; 4 | import std.string; 5 | import std.typecons; 6 | import std.stdio; 7 | 8 | static const long WORD_SIZE = 64; 9 | static const int HEADER_TAG_WIDTH = 8; 10 | 11 | enum ValueTag { 12 | Nil, 13 | Integer, 14 | Char, 15 | Bool, 16 | BigInteger, 17 | String, 18 | Symbol, 19 | List, 20 | Vector, 21 | Function, 22 | } 23 | 24 | struct Value { 25 | long header; 26 | long data; 27 | } 28 | 29 | string formatValue(Value v) { 30 | switch (tagOfValue(v)) { 31 | case ValueTag.Integer: 32 | return to!(string)(valueToInteger(v)); 33 | case ValueTag.Bool: 34 | return valueToBool(v) ? "#t" : "#f"; 35 | case ValueTag.Symbol: 36 | return valueToSymbol(v); 37 | case ValueTag.Char: 38 | return format("#\\%c", valueToChar(v)); 39 | case ValueTag.String: 40 | return valueToString(v); 41 | case ValueTag.Nil: 42 | return "()"; 43 | case ValueTag.BigInteger: 44 | return valueToBigInteger(v).toDecimalString(); 45 | case ValueTag.Function: 46 | return "#"; 47 | case ValueTag.List: 48 | auto fmt = "("; 49 | auto tuple = valueToList(v); 50 | 51 | while (true) { 52 | fmt = format("%s%s", fmt, formatValue(tuple[0])); 53 | 54 | if (valueIsList(tuple[1])) { 55 | tuple = valueToList(tuple[1]); 56 | fmt = format("%s ", fmt); 57 | } else if (valueIsNil(tuple[1])) { 58 | break; 59 | } else { 60 | fmt = format("%s . %s", fmt, formatValue(tuple[1])); 61 | break; 62 | } 63 | } 64 | 65 | return format("%s)", fmt); 66 | break; 67 | case ValueTag.Vector: 68 | auto vector = valueToVector(v); 69 | auto fmt = format("#(%s", formatValue(vector[0])); 70 | 71 | foreach (Value i; vector[1 .. vector.length]) { 72 | fmt = format("%s %s", fmt, formatValue(i)); 73 | } 74 | 75 | return format("%s)", fmt); 76 | break; 77 | default: 78 | return ""; 79 | } 80 | } 81 | 82 | ValueTag tagOfValue(Value v) { 83 | return cast(ValueTag)(v.header & (pow(2, HEADER_TAG_WIDTH) - 1)); 84 | } 85 | 86 | bool isValue(Value v, ValueTag vt) { 87 | return tagOfValue(v) == vt; 88 | } 89 | 90 | bool valueIsNil(Value v) { return isValue(v, ValueTag.Nil); } 91 | 92 | Value makeIntegerValue(long i) { 93 | Value v = { data: i, header: ValueTag.Integer }; 94 | return v; 95 | } 96 | 97 | bool valueIsInteger(Value v) { return isValue(v, ValueTag.Integer); } 98 | 99 | long valueToInteger(Value v) { 100 | return cast(long)v.data; 101 | } 102 | 103 | Value makeCharValue(char c) { 104 | Value v = { data: c, header: ValueTag.Char }; 105 | return v; 106 | } 107 | 108 | bool valueIsChar(Value v) { return isValue(v, ValueTag.Char); } 109 | 110 | char valueToChar(Value v) { 111 | return cast(char)v.data; 112 | } 113 | 114 | Value makeBoolValue(bool b) { 115 | Value v = { data: b, header: ValueTag.Bool }; 116 | return v; 117 | } 118 | 119 | bool valueIsBool(Value v) { return isValue(v, ValueTag.Bool); } 120 | 121 | bool valueToBool(Value v) { 122 | return cast(bool)v.data; 123 | } 124 | 125 | Value makeBigIntegerValue(BigInt i) { 126 | Value v = { data: cast(long)new BigInt(i), header: ValueTag.BigInteger }; 127 | return v; 128 | } 129 | 130 | bool valueIsBigInteger(Value v) { return isValue(v, ValueTag.BigInteger); } 131 | 132 | BigInt valueToBigInteger(Value v) { 133 | return *cast(BigInt*)v.data; 134 | } 135 | 136 | static const ulong MAX_VALUE_LENGTH = pow(2, WORD_SIZE) - 1; 137 | 138 | Tuple!(void*, ulong) copyString(string s) { 139 | ulong size = s.length + 1 > MAX_VALUE_LENGTH ? MAX_VALUE_LENGTH : s.length + 1; 140 | 141 | auto heapString = new char[size]; 142 | foreach (i, c; s[0 .. size - 1]) { 143 | heapString[i] = c; 144 | } 145 | heapString[size - 1] = '\0'; 146 | return Tuple!(void*, ulong)(cast(void*)heapString, size); 147 | } 148 | 149 | Value makeStringValue(string s) { 150 | auto string = copyString(s); 151 | Value v = { data: cast(long)string[0], header: string[1] << HEADER_TAG_WIDTH | ValueTag.String }; 152 | return v; 153 | } 154 | 155 | bool valueIsString(Value v) { return isValue(v, ValueTag.String); } 156 | 157 | char* valueToByteVector(Value v) { 158 | return cast(char*)v.data; 159 | } 160 | 161 | string valueToString(Value v) { 162 | return fromStringz(valueToByteVector(v)).dup; 163 | } 164 | 165 | void updateValueString(Value v, long index, char c) { 166 | auto vector = valueToByteVector(v); 167 | vector[index] = c; 168 | } 169 | 170 | Value makeSymbolValue(string s) { 171 | Value v = makeStringValue(s); 172 | v.header >>= HEADER_TAG_WIDTH; 173 | v.header <<= HEADER_TAG_WIDTH; 174 | v.header |= ValueTag.Symbol; 175 | return v; 176 | } 177 | 178 | bool valueIsSymbol(Value v) { return isValue(v, ValueTag.Symbol); } 179 | 180 | string valueToSymbol(Value v) { 181 | return valueToString(v); 182 | } 183 | 184 | Value makeListValue(Value head, Value tail) { 185 | Value v; 186 | v.header = ValueTag.List; 187 | Value** tuple = cast(Value**)new Value*[2]; 188 | foreach (i, item; [head, tail]) { 189 | tuple[i] = new Value; 190 | tuple[i].header = item.header; 191 | tuple[i].data = item.data; 192 | } 193 | v.data = cast(long)tuple; 194 | return v; 195 | } 196 | 197 | bool valueIsList(Value v) { return isValue(v, ValueTag.List); } 198 | 199 | Tuple!(Value, Value) valueToList(Value v) { 200 | Value** m = cast(Value**)v.data; 201 | return Tuple!(Value, Value)(*m[0], *m[1]); 202 | } 203 | 204 | Value makeVectorValue(Value[] v) { 205 | ulong size = v.length > MAX_VALUE_LENGTH ? MAX_VALUE_LENGTH : v.length; 206 | Value[] vCopy = new Value[v.length]; 207 | foreach (i, e; v) { 208 | vCopy[i] = e; 209 | } 210 | 211 | Value ve = { data: cast(long)vCopy.ptr, header: size << HEADER_TAG_WIDTH | ValueTag.Vector }; 212 | return ve; 213 | } 214 | 215 | bool valueIsVector(Value v) { return isValue(v, ValueTag.Vector); } 216 | 217 | Value[] valueToVector(Value v) { 218 | long size = v.header >> HEADER_TAG_WIDTH; 219 | Value[] vector; 220 | vector = (cast(Value*)v.data)[0 .. size]; 221 | return vector; 222 | } 223 | 224 | void updateValueVector(Value v, long index, Value element) { 225 | auto vector = valueToVector(v); 226 | vector[index] = element; 227 | } 228 | 229 | Value makeFunctionValue(string name, Value delegate(Value, void**) f, bool special) { 230 | void* namePtr = copyString(name)[0]; 231 | Value v; 232 | v.header = ValueTag.Function; 233 | long* tuple = cast(long*)new long[3]; 234 | tuple[0] = cast(long)namePtr; 235 | tuple[0] <<= HEADER_TAG_WIDTH; 236 | tuple[0] |= cast(int)special; 237 | tuple[1] = cast(long)f.ptr; 238 | tuple[2] = cast(long)f.funcptr; 239 | v.data = cast(long)tuple; 240 | return v; 241 | } 242 | 243 | bool valueIsFunction(Value v) { return isValue(v, ValueTag.Function); } 244 | 245 | Tuple!(string, Value delegate(Value, void**), bool) valueToFunction(Value v) { 246 | Value delegate(Value, void**) f; 247 | long* tuple = cast(long*)v.data; 248 | bool special = cast(bool)(tuple[0] & (pow(2, HEADER_TAG_WIDTH) - 1)); 249 | void* namePtr = cast(void*)(tuple[0] >> HEADER_TAG_WIDTH); 250 | string name = fromStringz(cast(char*)namePtr).dup; 251 | f.ptr = cast(void*)tuple[1]; 252 | f.funcptr = cast(Value function(Value, void**))(tuple[2]); 253 | return Tuple!(string, Value delegate(Value, void**), bool)(name, f, special); 254 | } 255 | -------------------------------------------------------------------------------- /tests/bad-fun-call.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: 1 is not a function 3 | status: 1 4 | stdout: "[ERROR] Call of non-procedure: 1\n" 5 | 6 | templates: 7 | - test.scm: | 8 | (1) 9 | -------------------------------------------------------------------------------- /tests/car-cons.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: car and cons 3 | status: 0 4 | stdout: 2 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | 10 | (define list (cons 2 (cons 1 '()))) 11 | 12 | (display (car list)) 13 | -------------------------------------------------------------------------------- /tests/define-begin.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: define has implicit begin 3 | status: 0 4 | stdout: "Hey!Hey!" 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | 10 | (define (show it) 11 | (display it) 12 | (display it)) 13 | 14 | (show "Hey!") 15 | -------------------------------------------------------------------------------- /tests/define.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: define function 3 | status: 0 4 | stdout: 30 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | 10 | (define (myfun a b) (+ a b)) 11 | 12 | (display (myfun 21 9)) 13 | -------------------------------------------------------------------------------- /tests/dotted-pair.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: basic 3 | status: 0 4 | stdout: (1 . 2) 5 | 6 | pair: "'(1 . 2)" 7 | 8 | - name: second arg is list 9 | status: 0 10 | stdout: 3 11 | 12 | pair: (+ 1 . (2)) 13 | 14 | - name: first and second args are list 15 | status: 0 16 | stdout: ((a b c) d e f) 17 | 18 | pair: "'((a b c) . (d e f))" 19 | 20 | templates: 21 | - test.scm: | 22 | (import (scheme base) (scheme write)) 23 | (define a {{ pair }}) 24 | (display a) 25 | -------------------------------------------------------------------------------- /tests/ellipsis-syntax.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: syntax extensions with ellipsis 3 | status: 0 4 | stdout: "Hey!Hey!Hey!" 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | 10 | (define-syntax when 11 | (syntax-rules () 12 | ((when test result ...) 13 | (if test (begin result ...) '())))) 14 | 15 | (define (main) 16 | (when #t 17 | (display "Hey!") 18 | (display "Hey!") 19 | (display "Hey!"))) 20 | -------------------------------------------------------------------------------- /tests/include.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: displays a string defined by in an included file 3 | status: 0 4 | stdout: This is my included string 5 | 6 | templates: 7 | - helper.scm: | 8 | 9 | (define str "This is my included string") 10 | 11 | - test.scm: | 12 | (import (scheme base) (scheme write)) 13 | 14 | (include "helper.scm") 15 | 16 | (display str) 17 | 18 | -------------------------------------------------------------------------------- /tests/lambda-list-arg.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: pass list to lambda 3 | status: 0 4 | stdout: "(1 2 3)" 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | (display ((lambda (a) a) '(1 2 3))) 10 | -------------------------------------------------------------------------------- /tests/lambda-symbol-bind.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: lambda bind all to symbol 3 | status: 0 4 | stdout: "(1 2 3)" 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | (display ((lambda a a) '(1 2 3))) 10 | -------------------------------------------------------------------------------- /tests/lambda.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: call a lambda directly 3 | status: 0 4 | stdout: 21 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | (display ((lambda (a) (+ a 1)) 20)) 10 | -------------------------------------------------------------------------------- /tests/let.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: basic let 3 | status: 0 4 | stdout: 11 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | (display (let ((a 7)) (+ (- 3 2) a 3))) 10 | -------------------------------------------------------------------------------- /tests/library-export.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: library hides non-exported symbols 3 | status: 1 4 | stdout: "[ERROR] Undefined symbol: p\n" 5 | 6 | templates: 7 | - helper.scm: | 8 | (define-library (helper) 9 | (import (scheme base)) 10 | (begin 11 | (define p 123))) 12 | 13 | - test.scm: | 14 | (import (scheme base) (scheme write)) 15 | 16 | (set! *library-include-path* "./") 17 | 18 | (import (helper)) 19 | 20 | (define (main) 21 | (display p)) 22 | -------------------------------------------------------------------------------- /tests/library-external.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: imports a library defined in an external file 3 | status: 0 4 | stdout: 3 5 | 6 | templates: 7 | - helper.scm: | 8 | (define-library (helper) 9 | (import (scheme base)) 10 | (export +) 11 | (begin 12 | (define (+ a b) (- a b)))) 13 | 14 | - test.scm: | 15 | (import (scheme base) (scheme write)) 16 | 17 | (set! *library-include-path* "./") 18 | 19 | (import (helper)) 20 | 21 | (define (main) 22 | (display (+ 7 4)) 23 | -------------------------------------------------------------------------------- /tests/library.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: imports a library defined in the same file 3 | status: 0 4 | stdout: 3 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | 10 | (define-library (test) 11 | (import (scheme base)) 12 | (export +) 13 | (begin 14 | (define (+ a b) (- a b)))) 15 | 16 | (define (main) 17 | (import (test)) 18 | (display (+ 7 4)) 19 | -------------------------------------------------------------------------------- /tests/list-to-string.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: basic 3 | status: 0 4 | stdout: abc 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | (display (list->string '(#\a #\b #\c))) 10 | -------------------------------------------------------------------------------- /tests/make-vector.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: simple 3 | status: 0 4 | stdout: "#(cats cats cats)#(cats dog cats)" 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | (define t (make-vector 3)) 10 | (vector-fill! t "cats") 11 | (display t) 12 | (vector-set! t 1 "dog") 13 | (display t) 14 | -------------------------------------------------------------------------------- /tests/my-let.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: syntax extensions with multiple rules and multiple ellipsis 3 | status: 0 4 | stdout: 4 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | 10 | (define-syntax my-let* 11 | (syntax-rules () 12 | ((_ ((p v)) b ...) 13 | (let ((p v)) b ...)) 14 | ((_ ((p1 v1) (p2 v2) ...) b ...) 15 | (let ((p1 v1)) 16 | (my-let* ((p2 v2) ...) 17 | b ...))))) 18 | 19 | (define (main) 20 | (my-let* ((a 1) 21 | (b (+ a 2))) 22 | (display (+ a b)))) 23 | -------------------------------------------------------------------------------- /tests/quote-eval.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: eval a quoted form 3 | status: 0 4 | stdout: 3 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write) (scheme eval)) 9 | (define x '(+ 1 2)) 10 | (display (eval x)) 11 | -------------------------------------------------------------------------------- /tests/quote.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: car of quoted function call is the function symbol 3 | status: 0 4 | stdout: + 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | (display (car (cdr (quote (1 + 2))))) 10 | -------------------------------------------------------------------------------- /tests/read-eval.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: read and eval 3 | status: 0 4 | stdout: "3" 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write) (scheme eval) (scheme read)) 9 | (display (eval (read "(+ 1 2)"))) 10 | -------------------------------------------------------------------------------- /tests/recursion.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: simple recursion 3 | status: 0 4 | stdout: 81 5 | 6 | b: 3 7 | p: 4 8 | 9 | - name: max fixed int recursion 10 | status: 0 11 | stdout: 4611686018427387904 12 | 13 | b: 2 14 | p: 62 15 | 16 | - name: big int recursion 17 | status: 0 18 | stdout: "18446744073709551616" 19 | 20 | b: 2 21 | p: 64 22 | 23 | 24 | templates: 25 | - test.scm: | 26 | (import (scheme base) (scheme write)) 27 | 28 | (define (exp base pow accum) 29 | (if (= pow 0) 30 | accum 31 | (exp base (- pow 1) (* accum base)))) 32 | 33 | (define (main) 34 | (display (exp {{ b }} {{ p }} 1))) 35 | -------------------------------------------------------------------------------- /tests/set.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: set! alters a defined variable 3 | status: 0 4 | stdout: 5 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | 10 | (define f 4) 11 | 12 | (set! f 5) 13 | 14 | (display f) 15 | -------------------------------------------------------------------------------- /tests/simple-syntax.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: simple syntax extension example 3 | status: 0 4 | stdout: "Hey!" 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | 10 | (define-syntax when 11 | (syntax-rules () 12 | ((when test result) 13 | (if test result '())))) 14 | 15 | (define (main) 16 | (when #t (display "Hey!"))) 17 | -------------------------------------------------------------------------------- /tests/string-append.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: basic 3 | status: 0 4 | stdout: "Hey! There!" 5 | 6 | v: "\"Hey!\" \" There!\"" 7 | 8 | - name: multiple 9 | status: 0 10 | stdout: "Hey! There! Fellow!" 11 | 12 | v: "\"Hey!\" \" There!\" \" Fellow!\"" 13 | 14 | templates: 15 | - test.scm: | 16 | (import (scheme base) (scheme write)) 17 | 18 | (display (string-append {{ v }}) 19 | -------------------------------------------------------------------------------- /tests/string-case.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: upcase 3 | status: 0 4 | stdout: "HELLO!" 5 | 6 | fun: string-upcase 7 | 8 | - name: multiple 9 | status: 0 10 | stdout: "hello!" 11 | 12 | fun: string-downcase 13 | 14 | templates: 15 | - test.scm: | 16 | (import (scheme base) (scheme write)) 17 | 18 | (display ({{ fun }} "Hello!") 19 | -------------------------------------------------------------------------------- /tests/string-eq.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: basic true 3 | status: 0 4 | stdout: "#t" 5 | 6 | t: "\"Hello world!\"" 7 | 8 | - name: basic false 9 | status: 0 10 | stdout: "#f" 11 | 12 | t: "\"Not\"" 13 | 14 | - name: basic multiple args true 15 | status: 0 16 | stdout: "#t" 17 | 18 | t: "s \"Hello world!\"" 19 | 20 | - name: basic multiple args false 21 | status: 0 22 | stdout: "#f" 23 | 24 | t: "s \"Nope\"" 25 | 26 | templates: 27 | - test.scm: | 28 | (import (scheme base) (scheme write)) 29 | (define s "Hello world!") 30 | (display (string=? s {{ t }}) 31 | -------------------------------------------------------------------------------- /tests/string-fill.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: basic 3 | status: 0 4 | stdout: "TTTTT" 5 | 6 | a: "" 7 | 8 | - name: with start 9 | status: 0 10 | stdout: "HeTTT" 11 | 12 | a: "2" 13 | 14 | - name: with start and end 15 | status: 0 16 | stdout: "HeTTo" 17 | 18 | a: "2 4" 19 | 20 | templates: 21 | - test.scm: | 22 | (import (scheme base) (scheme write)) 23 | (define s "Hello") 24 | (string-fill! s #\T {{ a }}) 25 | (display s) 26 | -------------------------------------------------------------------------------- /tests/string-length.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: basic 3 | status: 0 4 | stdout: 12 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | (display (string-length "Hello world!") 10 | -------------------------------------------------------------------------------- /tests/string-ref.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: basic 3 | status: 0 4 | stdout: "#\\e" 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | (display (string-ref "Hello world!" 1) 10 | -------------------------------------------------------------------------------- /tests/string-set.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: basic 3 | status: 0 4 | stdout: "Cello world!" 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | (define s "Hello world!") 10 | (string-set! s 0 #\C) 11 | (display s) 12 | -------------------------------------------------------------------------------- /tests/string-to-list.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: basic 3 | status: 0 4 | stdout: "(#\\H #\\e #\\l #\\l #\\o)" 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | (display (string->list "Hello")) 10 | -------------------------------------------------------------------------------- /tests/string.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: basic 3 | status: 0 4 | stdout: "Hello world!" 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | (display "Hello world!") 10 | -------------------------------------------------------------------------------- /tests/stringp.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: basic true 3 | status: 0 4 | stdout: "#t" 5 | 6 | v: "\"Hello world!\"" 7 | 8 | - name: basic false 9 | status: 0 10 | stdout: "#f" 11 | 12 | v: 1 13 | 14 | templates: 15 | - test.scm: | 16 | (import (scheme base) (scheme write)) 17 | (display (string? {{ v }}) 18 | -------------------------------------------------------------------------------- /tests/substring.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: basic 3 | status: 0 4 | stdout: "Hello" 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | (display (substring "Hello world!" 0 5)) 10 | -------------------------------------------------------------------------------- /tests/vector-append.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: simple 3 | status: 0 4 | stdout: "#(#\\f #\\o #\\o #\\b #\\a #\\r)" 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | (display (vector-append (string->vector "foo") (string->vector "bar"))) 10 | -------------------------------------------------------------------------------- /tests/vector-to-string.yaml: -------------------------------------------------------------------------------- 1 | cases: 2 | - name: simple 3 | status: 0 4 | stdout: "foobar|foobar1|foobar2|foobar3" 5 | 6 | templates: 7 | - test.scm: | 8 | (import (scheme base) (scheme write)) 9 | (display (vector->string (string->vector "foobar"))) 10 | (display "|") 11 | (display (vector->string (list->vector (vector->list (string->vector "foobar1"))))) 12 | (display "|") 13 | (display (vector->string (list->vector (vector->list (string->vector "foobar2"))))) 14 | (display "|") 15 | (display (vector->string (vector-append (string->vector "foo") (string->vector "bar3")))) 16 | --------------------------------------------------------------------------------