├── .gitignore ├── Dockerfile ├── LICENSE.txt ├── README.md ├── docs ├── paper.pdf └── tutorial.pdf └── src ├── Makefile ├── README.md ├── bootlib.scm ├── compiler-tests.scm ├── compiler.scm ├── cps.scm ├── ctest.c ├── ctest.sh ├── lib.scm ├── reader.scm ├── repl.scm ├── runtime-rust ├── Cargo.toml ├── README.md ├── bindings.h ├── build.rs ├── src │ └── main.rs └── tests-driver-modif.scm ├── scheme_entry.h ├── self.scm ├── startup.c ├── startup.h ├── tests-1.1-req.scm ├── tests-1.2-req.scm ├── tests-1.3-req.scm ├── tests-1.4-req.scm ├── tests-1.5-req.scm ├── tests-1.6-opt.scm ├── tests-1.6-req.scm ├── tests-1.7-req.scm ├── tests-1.8-req.scm ├── tests-1.9-req.scm ├── tests-1.9.1-req.scm ├── tests-1.9.2-req.scm ├── tests-1.9.3-req.scm ├── tests-2.1-req.scm ├── tests-2.2-req.scm ├── tests-2.3-req.scm ├── tests-2.4-req.scm ├── tests-2.4.1-req.scm ├── tests-2.4.2-req.scm ├── tests-2.6-req.scm ├── tests-2.8-req.scm ├── tests-2.9-req.scm ├── tests-3.1-req.scm ├── tests-3.2-req.scm ├── tests-3.3-req.scm ├── tests-3.4-req.scm ├── tests-4.1-req.scm ├── tests-4.1.1-req.scm ├── tests-4.1.2-req.scm ├── tests-4.1.3-req.scm ├── tests-4.2-req.scm ├── tests-4.2.1-req.scm ├── tests-4.2.2-req.scm ├── tests-4.2.3-req.scm ├── tests-4.3-req.scm ├── tests-5.1-req.scm ├── tests-5.2-req.scm ├── tests-5.3-req.scm ├── tests-5.6-req.scm ├── tests-6.1-req.scm ├── tests-6.2-req.scm ├── tests-6.3-req.scm ├── tests-6.4-req.scm ├── tests-6.4.1-req.scm ├── tests-6.4.2-req.scm ├── tests-6.5-req.scm ├── tests-6.6-req.scm ├── tests-6.7-req.scm └── tests-driver.scm /.gitignore: -------------------------------------------------------------------------------- 1 | /src/lib.s 2 | /src/stst 3 | /src/stst.out 4 | /src/stst.s 5 | /src/stst.tmp 6 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM debian:latest 2 | WORKDIR /inc 3 | 4 | # Setup base image deps 5 | RUN apt-get update && apt-get install -y \ 6 | build-essential \ 7 | gcc-multilib \ 8 | libncurses5-dev \ 9 | libx11-dev \ 10 | uuid-dev \ 11 | wget \ 12 | && rm -rf /var/lib/apt/lists/* 13 | 14 | # Install chez from source 15 | RUN cd /tmp \ 16 | && wget -q https://github.com/cisco/ChezScheme/releases/download/v9.5.2/csv9.5.2.tar.gz \ 17 | && tar -xf csv9.5.2.tar.gz \ 18 | && cd csv9.5.2 \ 19 | && ./configure \ 20 | && make install \ 21 | && cd - \ 22 | && rm -rf csv9.5.2.tar.gz csv9.5.2 23 | 24 | ADD . /inc 25 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2011 Nada Amin, Abdulaziz Ghuloum, Matt Might 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Step-by-step development of a Scheme-to-x86 compiler, based on 2 | Abdulaziz Ghuloum's [paper][1], _An Incremental Approach to Compiler 3 | Construction_, and extended draft [tutorial][2], _Compilers: Backend to 4 | Frontend and Back to Front Again_. 5 | 6 | The CPS conversion is based on Matt Might's [web article][3], _How to 7 | compile with continuations_. 8 | 9 | [1]: https://github.com/namin/inc/blob/master/docs/paper.pdf?raw=true 10 | [2]: https://github.com/namin/inc/blob/master/docs/tutorial.pdf?raw=true 11 | [3]: http://matt.might.net/articles/cps-conversion/ 12 | 13 | ## More on `inc` 14 | 15 | See the [src](src) directory. 16 | 17 | ## Docker cheatsheet 18 | 19 | - `docker build -t=namin/inc .` 20 | - `docker run -i -t namin/inc /bin/bash` 21 | - `docker run -it -v $(pwd):/inc-live namin/inc /bin/bash` 22 | -------------------------------------------------------------------------------- /docs/paper.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/namin/inc/3f683935e290848485f8d4d165a4f727f6658d1d/docs/paper.pdf -------------------------------------------------------------------------------- /docs/tutorial.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/namin/inc/3f683935e290848485f8d4d165a4f727f6658d1d/docs/tutorial.pdf -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | # Generate the testable executable inc 2 | # 3 | # -m32 forces to compile for 32bit target, this prevents accidental surprises. 4 | # 5 | # `-g3 -ggdb3` generates as much debug symbols as possible, notably the latter 6 | # allows the use of macros in gdb prompt. As of now, only GCC seems to support 7 | # this option. 8 | # 9 | # Omitting the frame pointer with `-fomit-frame-pointer` removes the standard 10 | # function preamble and post when not needed. This makes the assembly slightly 11 | # easier to read and harder to debug. 12 | # 13 | # `-fno-asynchronous-unwind-tables` gets rid of all the '.cfi' directives from 14 | # the generated asm. 15 | 16 | lib.s: tests-driver.scm compiler.scm lib.scm 17 | echo '(compile-lib)' | scheme compiler.scm --quiet 18 | 19 | bootlib.s: bootlib.scm tests-driver.scm compiler.scm self.scm reader.scm startup.c lib.s 20 | echo "" | scheme bootlib.scm --quiet 21 | make stst 22 | ./stst 23 | 24 | boot: repl.scm tests-driver.scm compiler.scm self.scm reader.scm startup.c lib.s 25 | echo "" | scheme repl.scm --quiet 26 | make stst 27 | mv stst boot 28 | 29 | .PHONY: stst 30 | stst: startup.c lib.s stst.s 31 | gcc -m32 \ 32 | -Wall \ 33 | -g3 -ggdb3 \ 34 | -fomit-frame-pointer \ 35 | -fno-asynchronous-unwind-tables \ 36 | -O0 startup.c lib.s stst.s \ 37 | -o stst 38 | 39 | .PHONY: test 40 | test: lib.s 41 | echo '(test-all)' | scheme compiler-tests.scm --quiet 42 | 43 | .PHONY: clean 44 | clean: 45 | rm -f boot stst.s lib.s stst stst.out 46 | -------------------------------------------------------------------------------- /src/README.md: -------------------------------------------------------------------------------- 1 | Inc: an incrementally developed compiler 2 | ======================================= 3 | 4 | The compiler can now compile itself. 5 | Do `make boot` to create a standalone repl. 6 | (The booted compiler supports a smaller range of fixnums due to double shifting.) 7 | 8 | The tests are now loaded in `compiler-tests.scm`. 9 | 10 | To run all the tests, do `make test` at a shell. 11 | The tests can run for both the hosted and booted compiler. 12 | By toggling `enable-boot-tests` in `tests-driver.scm`, 13 | the booted compiler can be included or excluded from the tests. 14 | 15 | ### possible TODOs 16 | 17 | - [ ] generate code for loaded definitions in advance, as for lib primitives 18 | 19 | - [ ] understand why the booted compiler runs out of memory compiling itself, 20 | and optimize accordingly 21 | 22 | - [ ] update the rust runtime for the booted compiler 23 | 24 | Full original instructions 25 | -------------------------- 26 | 27 | To run the tests, make sure that your compiler file is called 28 | `compiler.scm`, and that at the top of that file, you have: 29 | `(load "tests-driver.scm")` ; this should come first 30 | `(load "tests-1.1-req.scm")` ; and any other test files you may have. 31 | 32 | Also, make sure that your compiler defines the function 33 | `emit-program` that takes an expression and uses `emit` to emit the 34 | appropriate instructions. 35 | 36 | The `tests-driver` defines the procedure `test-all` that will run all 37 | the tests provided, get the output, redirect it to a file `stst.s`, 38 | and invokes gcc on that file as well as the startup.c file that you 39 | should have written, and the `lib.s` file that is generated from the 40 | `compile-lib` thunk, which you'll need to call once and every time you 41 | change the `emit-library` thunk, which you can define. 42 | 43 | The tests-driver is written for [Petite] Chez Scheme 7. You can 44 | obtain a copy of Petite Chez Scheme from: 45 | [http://www.scheme.com](http://www.scheme.com) 46 | 47 | The `tests-driver` also assumes that you have the GNU C compiler `gcc` 48 | already setup and added to your pathname. How you do this depends 49 | on your platform. If you have a different C compiler that you wish 50 | to use, you can edit the `tests-driver` yourself (look for the 51 | definition of the `build` procedure). 52 | 53 | If all is well, then invoking `petite` on your compiler and typing 54 | `(test-all)` should run all the tests as in the following sample 55 | transcript. 56 | 57 | $ petite compiler.scm 58 | Petite Chez Scheme Version 7.0a 59 | Copyright (c) 1985-2005 Cadence Research Systems 60 | 61 | > (test-all) 62 | test 0:#f ... ok 63 | test 1:#t ... ok 64 | test 2:() ... ok 65 | test 3:0 ... ok 66 | test 4:1 ... ok 67 | test 5:-1 ... ok 68 | test 6:2736 ... ok 69 | test 7:-2736 ... ok 70 | test 8:536870911 ... ok 71 | test 9:-536870912 ... ok 72 | test 10:#\nul ... ok 73 | ... 74 | test 131:#\y ... ok 75 | test 132:#\z ... ok 76 | test 133:#\{ ... ok 77 | test 134:#\| ... ok 78 | test 135:#\} ... ok 79 | test 136:#\~ ... ok 80 | test 137:#\rubout ... ok 81 | passed all 138 tests 82 | > 83 | 84 | Enjoy. 85 | 86 | Abdulaziz Ghuloum 87 | -------------------------------------------------------------------------------- /src/bootlib.scm: -------------------------------------------------------------------------------- 1 | (load "compiler.scm") 2 | 3 | (compile-program 4 | '(let () 5 | (load "self.scm") 6 | (load "reader.scm") 7 | (load "compiler.scm") 8 | (parameterize ([lib-file "bootlib.s"]) 9 | (compile-lib)))) 10 | 11 | -------------------------------------------------------------------------------- /src/compiler-tests.scm: -------------------------------------------------------------------------------- 1 | (load "compiler.scm") 2 | (when enable-boot-tests 3 | (unless enable-cps 4 | (load "tests-6.7-req.scm") 5 | (load "tests-6.6-req.scm") 6 | (load "tests-6.5-req.scm") 7 | (load "tests-6.4-req.scm")) 8 | (load "tests-6.4.2-req.scm") 9 | (load "tests-6.4.1-req.scm") 10 | (load "tests-6.3-req.scm") 11 | (load "tests-6.2-req.scm") 12 | (load "tests-6.1-req.scm")) 13 | (when enable-cps 14 | (load "tests-5.3-req.scm")) 15 | (load "tests-5.2-req.scm") 16 | (load "tests-4.2-req.scm") 17 | (load "tests-4.1-req.scm") 18 | (load "tests-3.4-req.scm") 19 | (load "tests-3.3-req.scm") 20 | (load "tests-3.2-req.scm") 21 | (load "tests-3.1-req.scm") 22 | (load "tests-2.9-req.scm") 23 | (load "tests-2.8-req.scm") 24 | (load "tests-2.6-req.scm") 25 | (load "tests-2.4-req.scm") 26 | (load "tests-2.3-req.scm") 27 | (load "tests-2.2-req.scm") 28 | (load "tests-2.1-req.scm") 29 | (load "tests-1.9-req.scm") 30 | (load "tests-1.8-req.scm") 31 | (load "tests-1.7-req.scm") 32 | (load "tests-1.6-opt.scm") 33 | (load "tests-1.6-req.scm") 34 | (load "tests-1.5-req.scm") 35 | (load "tests-1.4-req.scm") 36 | (load "tests-1.3-req.scm") 37 | (load "tests-1.2-req.scm") 38 | (load "tests-1.1-req.scm") 39 | 40 | -------------------------------------------------------------------------------- /src/compiler.scm: -------------------------------------------------------------------------------- 1 | (load "tests-driver.scm") 2 | (define enable-cps #f) 3 | (define fxshift 2) 4 | (define fxmask #x03) 5 | (define fxtag #x00) 6 | (define bool-f #x2F) 7 | (define bool-t #x6F) 8 | (define bool-bit 6) 9 | (define boolmask #xBF) 10 | (define list-nil #x3F) 11 | (define eof-obj #x7F) 12 | (define charshift 8) 13 | (define charmask #x3F) 14 | (define chartag #x0F) 15 | (define objshift 3) 16 | (define objmask #x07) 17 | (define pairtag #x01) 18 | (define pairsize 8) 19 | (define paircar 0) 20 | (define paircdr 4) 21 | (define vectortag #x05) 22 | (define stringtag #x06) 23 | (define closuretag #x02) 24 | (define symboltag #x03) 25 | (define wordsize 4) ; bytes 26 | (define wordshift 2) 27 | (define global-offset 4) 28 | (define edi-offset 8) 29 | (define return-addr #x17) 30 | 31 | (define registers 32 | '((eax scratch) 33 | (ebx preserve) 34 | (ecx scratch) 35 | (edx scratch) 36 | (esi preserve) 37 | (edi preserve) 38 | (ebp preserve) 39 | (esp preserve))) 40 | (define (reg-name reg) (car reg)) 41 | (define (reg-preserve? reg) (eq? 'preserve (cadr reg))) 42 | 43 | (define fixnum-bits (- (* wordsize 8) fxshift)) 44 | (define fxlower (- (expt 2 (- fixnum-bits 1)))) 45 | (define fxupper (sub1 (expt 2 (- fixnum-bits 1)))) 46 | (define (fxnum? x) 47 | (and (integer? x) (exact? x) (<= fxlower x) (<= x fxupper))) 48 | 49 | (define (immediate? x) 50 | (or (fxnum? x) (boolean? x) (null? x) (char? x))) 51 | 52 | (define (immediate-rep x) 53 | (cond 54 | [(fxnum? x) (ash x fxshift)] 55 | [(boolean? x) (if x bool-t bool-f)] 56 | [(null? x) list-nil] 57 | [(char? x) (bitwise-ior (ash (char->integer x) charshift) chartag)] 58 | [else #f])) 59 | 60 | (define (emit-immediate x) 61 | (emit " mov $~s, %eax" (immediate-rep x))) 62 | 63 | (define (make-begin lst) 64 | (cond 65 | [(null? (cdr lst)) (car lst)] 66 | [else (cons 'begin lst)])) 67 | (define (begin? expr) 68 | (and (tagged-list 'begin expr) 69 | (or (not (null? (begin-seq expr))) 70 | (error 'begin? (format "empty begin"))))) 71 | (define begin-seq cdr) 72 | 73 | (define (make-set! lhs rhs) 74 | (list 'set! lhs rhs)) 75 | (define (set? expr) 76 | (tagged-list 'set! expr)) 77 | (define set-lhs cadr) 78 | (define set-rhs caddr) 79 | (define make-let list) 80 | (define (let-form? let-kind expr) 81 | (and (tagged-list let-kind expr) 82 | (or (not (null? (cddr expr))) 83 | (error 'let-form? (format "let without body ~s" expr))))) 84 | (define let-kind car) 85 | (define (any-let? expr) 86 | (and (pair? expr) 87 | (member (let-kind expr) '(let let* letrec)) 88 | (let-form? (let-kind expr) expr))) 89 | (define (let? expr) (let-form? 'let expr)) 90 | (define (let*? expr) (let-form? 'let* expr)) 91 | (define (letrec? expr) (or (let-form? 'letrec expr) (let-form? 'letrec* expr))) 92 | (define let-bindings cadr) 93 | (define letrec-bindings let-bindings) 94 | (define labels-bindings let-bindings) 95 | (define make-body make-begin) 96 | (define let-body-seq cddr) 97 | (define (let-body expr) 98 | (make-body (let-body-seq expr))) 99 | (define letrec-body let-body) 100 | (define labels-body let-body) 101 | (define empty? null?) 102 | (define (bind lhs rhs) 103 | (check-variable lhs) 104 | (list lhs rhs)) 105 | (define first car) 106 | (define rest cdr) 107 | (define rhs cadr) 108 | (define (lhs binding) 109 | (check-variable (car binding))) 110 | (define (check-variable var) 111 | (if (variable? var) 112 | var 113 | (error 'lhs (format "~s is not a variable" var)))) 114 | (define (make-initial-env bindings) 115 | bindings) 116 | (define (bulk-extend-env vars vals env) 117 | (append (map list vars vals) env)) 118 | (define (extend-env var si env) 119 | (cons (list var si) env)) 120 | (define (lookup var env) 121 | (cond 122 | [(assv var env) => cadr] 123 | [else #f])) 124 | 125 | (define variable? symbol?) 126 | (define (tagged-list tag expr) 127 | (and (list? expr) (not (null? expr)) (eq? (car expr) tag))) 128 | 129 | (define (lambda? expr) (tagged-list 'lambda expr)) 130 | (define lambda-formals cadr) 131 | (define (formals-to-vars formals) 132 | (cond 133 | [(list? formals) (map (lambda (x) (if (list? x) (car x) x)) formals)] 134 | [(pair? formals) (cons (car formals) (formals-to-vars (cdr formals)))] 135 | [else (list formals)])) 136 | (define (lambda-vars expr) 137 | (formals-to-vars (lambda-formals expr))) 138 | (define (map-formals f formals) 139 | (cond 140 | [(list? formals) (map (lambda (x) (if (pair? x) (cons (f (car x)) (cdr x)) (f x))) formals)] 141 | [(pair? formals) (cons (f (car formals)) (map-formals f (cdr formals)))] 142 | [else (f formals)])) 143 | (define (lambda-body expr) (make-body (cddr expr))) 144 | (define (make-lambda formals body) 145 | (list 'lambda formals body)) 146 | 147 | (define lib-primitives '()) 148 | (define-syntax define-primitive 149 | (syntax-rules () 150 | [(_ (prim-name si env arg* ...) b b* ...) 151 | (begin 152 | (putprop 'prim-name '*is-prim* #t) 153 | (putprop 'prim-name '*arg-count* 154 | (length '(arg* ...))) 155 | (putprop 'prim-name '*emitter* 156 | (lambda (si env arg* ...) b b* ...)))] 157 | [(_ (prim-name si env arg* ... . vararg) b b* ...) 158 | (begin 159 | (putprop 'prim-name '*is-prim* #t) 160 | (putprop 'prim-name '*arg-count* 161 | (length '(arg* ...))) 162 | (putprop 'prim-name '*vararg* #t) 163 | (putprop 'prim-name '*emitter* 164 | (lambda (si env arg* ... . vararg) b b* ...)))])) 165 | (define-syntax define-lib-primitive 166 | (syntax-rules () 167 | [(_ (prim-name arg* ...) b b* ...) 168 | (begin 169 | (set! lib-primitives (cons 'prim-name lib-primitives)) 170 | (putprop 'prim-name '*is-lib-prim* #t) 171 | (putprop 'prim-name '*arg-count* 172 | (length '(arg* ...))) 173 | (putprop 'prim-name '*lib-code* 174 | (make-lambda '(arg* ...) (make-begin '(b b* ...)))))] 175 | [(_ (prim-name . varargs) b b* ...) 176 | (begin 177 | (set! lib-primitives (cons 'prim-name lib-primitives)) 178 | (putprop 'prim-name '*is-lib-prim* #t) 179 | (putprop 'prim-name '*arg-count* 0) 180 | (putprop 'prim-name '*vararg* #t) 181 | (putprop 'prim-name '*lib-code* 182 | (make-lambda 'varargs (make-begin '(b b* ...)))))] 183 | [(_ prim-name b) 184 | (begin 185 | (set! lib-primitives (cons 'prim-name lib-primitives)) 186 | (putprop 'prim-name '*is-lib-prim* #t) 187 | (putprop 'prim-name '*lib-code* 'b))])) 188 | (load "lib.scm") 189 | 190 | (define (primitive? x) 191 | (and (symbol? x) (getprop x '*is-prim*))) 192 | 193 | (define (lib-primitive? x) 194 | (and (symbol? x) (getprop x '*is-lib-prim*))) 195 | 196 | (define (lib-primitive-code x) 197 | (or (getprop x '*lib-code*) (error 'lib-primitive-code (format "primitive ~s has no lib code" x)))) 198 | 199 | (define (primitive-emitter x) 200 | (or (getprop x '*emitter*) (error 'primitive-emitter (format "primitive ~s has no emitter" x)))) 201 | 202 | (define aexpr-primitives '(constant-ref primitive-ref)) 203 | 204 | (define (aexpr-primcall? expr) 205 | (and (pair? expr) (primitive? (car expr)) (member (car expr) aexpr-primitives))) 206 | 207 | (define (primcall? expr) 208 | (and (pair? expr) (primitive? (car expr)))) 209 | 210 | (define (check-primcall-args prim args) 211 | ((if (getprop prim '*vararg*) <= =) (getprop prim '*arg-count*) (length args))) 212 | 213 | (define (emit-any-primcall si env prim args) 214 | (or (check-primcall-args prim args) 215 | (error 'emit-primcall (format "incorrect number of arguments to ~s -- ~a" prim args))) 216 | (apply (primitive-emitter prim) si env args)) 217 | 218 | (define (emit-aexpr-primcall si env expr) 219 | (let ([prim (car expr)] 220 | [args (cdr expr)]) 221 | (emit-any-primcall si env prim args))) 222 | 223 | (define (emit-primcall si env expr) 224 | (let ([prim (car expr)] 225 | [cont (cadr expr)] 226 | [args (cddr expr)]) 227 | (emit-any-primcall si env prim args) 228 | (emit-stack-save si) 229 | (emit-expr (next-stack-index si) env cont) 230 | (emit " mov %eax, %edi") 231 | (emit-stack-load si) 232 | (emit-stack-save (- wordsize)) 233 | (emit " mov %edi, %eax") 234 | (emit-load-closure-label) 235 | (emit " mov %eax, %edx") 236 | (emit " mov $1, %eax") 237 | (emit-jmp "*%edx"))) 238 | 239 | (define (emit-binop si env arg1 arg2) 240 | (emit-expr si env arg1) 241 | (emit-stack-save si) 242 | (emit-expr (next-stack-index si) env arg2)) 243 | 244 | (define (emit-stack-save si) 245 | (emit " mov %eax, ~s(%esp)" si)) 246 | 247 | (define (emit-stack-load si) 248 | (emit " mov ~s(%esp), %eax" si)) 249 | 250 | (define (next-stack-index si) 251 | (- si wordsize)) 252 | 253 | (define (emit-div si env arg1 arg2) 254 | (emit-expr si env arg2) 255 | (emit " shr $~s, %eax" fxshift) 256 | (emit-stack-save si) 257 | (emit-expr (next-stack-index si) env arg1) 258 | (emit " mov $0, %edx") 259 | (emit " shr $~s, %eax" fxshift) 260 | (emit " divl ~s(%esp)" si)) 261 | 262 | (define (emit-cmp-bool . args) 263 | (emit " ~s %al" (if (null? args) 'sete (car args))) 264 | (emit " movzb %al, %eax") 265 | (emit " sal $~s, %al" bool-bit) 266 | (emit " or $~s, %al" bool-f)) 267 | 268 | (define (emit-cmp-binop setx si env arg1 arg2) 269 | (emit-binop si env arg1 arg2) 270 | (emit " cmp %eax, ~s(%esp)" si) 271 | (emit-cmp-bool setx)) 272 | 273 | (define unique-label 274 | (let ([count 0]) 275 | (lambda () 276 | (let ([L (string->symbol (string-append "L_" (number->string count)))]) 277 | (set! count (add1 count)) 278 | L)))) 279 | 280 | (define (if? expr) 281 | (and (tagged-list 'if expr) 282 | (or (= 3 (length (cdr expr))) 283 | (error 'if? (format "malformed if ~s" expr))))) 284 | (define if-test cadr) 285 | (define if-conseq caddr) 286 | (define if-altern cadddr) 287 | 288 | (define (emit-if si env tail expr) 289 | (let ([alt-label (unique-label)] 290 | [end-label (unique-label)]) 291 | (emit-expr si env (if-test expr)) 292 | (emit " cmp $~s, %al" bool-f) 293 | (emit " je ~a" alt-label) 294 | (emit-any-expr si env tail (if-conseq expr)) 295 | (unless tail (emit " jmp ~a" end-label)) 296 | (emit-label alt-label) 297 | (emit-any-expr si env tail (if-altern expr)) 298 | (emit-label end-label))) 299 | (define (emit-begin si env tail expr) 300 | (emit-seq si env tail (begin-seq expr))) 301 | (define (emit-seq si env tail seq) 302 | (cond 303 | [(null? seq) (error 'emit-seq "empty seq")] 304 | [(null? (rest seq)) (emit-any-expr si env tail (first seq))] 305 | [else 306 | (emit-expr si env (first seq)) 307 | (emit-seq si env tail (rest seq))])) 308 | (define (emit-let si env tail expr) 309 | (define (process-let bindings si new-env) 310 | (cond 311 | [(empty? bindings) 312 | (emit-any-expr si new-env tail (let-body expr))] 313 | [else 314 | (let ([b (first bindings)]) 315 | (emit-expr si env (rhs b)) 316 | (emit-stack-save si) 317 | (process-let (rest bindings) 318 | (next-stack-index si) 319 | (extend-env (lhs b) si new-env)))])) 320 | (process-let (let-bindings expr) si env)) 321 | 322 | (define (extend-env-with si env lvars k) 323 | (if (null? lvars) 324 | (k si env) 325 | (extend-env-with 326 | (next-stack-index si) 327 | (extend-env (first lvars) si env) 328 | (rest lvars) 329 | k))) 330 | 331 | (define (free-var offset) 332 | (list 'free (- offset closuretag))) 333 | (define (free-var? fv) 334 | (tagged-list 'free fv)) 335 | (define free-var-offset cadr) 336 | 337 | (define (close-env-with offset env lvars k) 338 | (if (null? lvars) 339 | (k env) 340 | (close-env-with 341 | (+ offset wordsize) 342 | (extend-env (first lvars) (free-var offset) env) 343 | (rest lvars) 344 | k))) 345 | 346 | (define (emit-variable-ref si env var) 347 | (cond 348 | [(lookup var env) => 349 | (lambda (v) 350 | (cond 351 | [(free-var? v) 352 | (emit " mov ~s(%edi), %eax" (free-var-offset v))] 353 | [(number? v) 354 | (emit-stack-load v)] 355 | [else (error 'emit-variable-ref (format "looked up unknown value ~s for var ~s" v var))]))] 356 | [else (error 'emit-variable-ref (format "undefined variable ~s" var))])) 357 | 358 | (define (emit-ret-if tail) 359 | (when tail (emit " ret"))) 360 | 361 | (define (emit-expr si env expr) 362 | (emit-any-expr si env #f expr)) 363 | 364 | (define (emit-tail-expr si env expr) 365 | (emit-any-expr si env #t expr)) 366 | 367 | (define (emit-any-expr si env tail expr) 368 | (cond 369 | [(immediate? expr) (emit-immediate expr) (emit-ret-if tail)] 370 | [(variable? expr) (emit-variable-ref si env expr) (emit-ret-if tail)] 371 | [(closure? expr) (emit-closure si env expr) (emit-ret-if tail)] 372 | [(if? expr) (emit-if si env tail expr) (assert (or (not enable-cps) tail))] 373 | [(let? expr) (emit-let si env tail expr) (assert (or (not enable-cps) tail))] 374 | [(begin? expr) (emit-begin si env tail expr) (assert (not enable-cps))] 375 | [(or (aexpr-primcall? expr) 376 | (and (not enable-cps) 377 | (primcall? expr))) (emit-aexpr-primcall si env expr) (emit-ret-if tail)] 378 | [(and enable-cps 379 | (primcall? expr)) (emit-primcall si env expr) (assert tail)] 380 | [(app? expr) (emit-app si env tail expr) (assert (or (not enable-cps) tail))] 381 | [else (error 'emit-expr (format "~s is not an expression" expr))])) 382 | 383 | (define unique-name 384 | (let ([counts '()]) 385 | (lambda (name) 386 | (cond 387 | [(assv name counts) => 388 | (lambda (p) 389 | (let* ([count (cdr p)] 390 | [new-name (string->symbol (string-append (symbol->string name) "_" (number->string count)))]) 391 | (set-cdr! p (add1 count)) 392 | new-name))] 393 | [(lib-primitive? name) 394 | (set! counts (cons (cons name 1) counts)) 395 | (unique-name name)] 396 | [else 397 | (set! counts (cons (cons name 1) counts)) 398 | name])))) 399 | 400 | (define (define? expr) 401 | (tagged-list 'define expr)) 402 | (define (define-lhs expr) 403 | (let ((lhs (cadr expr))) 404 | (if (pair? lhs) (car lhs) lhs))) 405 | (define (define-rhs expr) 406 | (let ((lhs (cadr expr)) 407 | (body (make-body (cddr expr)))) 408 | (if (pair? lhs) (list 'lambda (cdr lhs) body) body))) 409 | 410 | (define (foreign-call? expr) 411 | (tagged-list 'foreign-call expr)) 412 | (define (make-foreign-call name args) 413 | (cons 'foreign-call (cons name args))) 414 | (define foreign-call-name cadr) 415 | (define foreign-call-args cddr) 416 | 417 | (define (length-vararg xs) 418 | (if (not (pair? xs)) 419 | 0 420 | (+ 1 (length-vararg (cdr xs))))) 421 | (define (is-vararg xs) 422 | (if (null? xs) 423 | #f 424 | (if (not (pair? xs)) 425 | #t 426 | (is-vararg (cdr xs))))) 427 | 428 | (define (macro-expand expr) 429 | (define (transform expr bound-vars) 430 | (cond 431 | [(and (begin? expr) (not (null? (filter define? (begin-seq expr))))) 432 | (let loop ([prev '()] [defs '()] [todo (begin-seq expr)]) 433 | (cond 434 | [(and (not (null? todo)) (define? (car todo))) 435 | (loop prev 436 | (append defs (list (bind (define-lhs (car todo)) (define-rhs (car todo))))) 437 | (cdr todo))] 438 | [(and (not (null? todo)) (null? defs)) 439 | (loop (append prev (list (car todo))) 440 | defs 441 | (cdr todo))] 442 | [else 443 | (let ([last (make-let 444 | 'letrec 445 | defs 446 | (make-body (if (null? todo) '(#f) todo)))]) 447 | (transform 448 | (if (null? prev) 449 | last 450 | (combine-exprs (make-begin prev) last)) 451 | bound-vars))]))] 452 | [(and (tagged-list 'let expr) (symbol? (cadr expr))) 453 | (transform 454 | (list 455 | 'let '() 456 | (list 'define (cadr expr) (cons 'lambda (cons (map car (caddr expr)) (cdddr expr)))) 457 | (cons (cadr expr) (map cadr (caddr expr)))) 458 | bound-vars)] 459 | [(set? expr) 460 | (make-set! (set-lhs expr) (transform (set-rhs expr) bound-vars))] 461 | [(lambda? expr) 462 | (let* ([formals (lambda-formals expr)] 463 | [optional-args (filter list? (if (list? formals) formals '()))]) 464 | (if (null? optional-args) 465 | (make-lambda 466 | formals 467 | (transform (lambda-body expr) 468 | (append (lambda-vars expr) bound-vars))) 469 | (let ([new-formals (map (lambda (x) 470 | (if (list? x) 471 | (list (car x)) 472 | x)) 473 | formals)] 474 | [bindings (map (lambda (var-val) 475 | (let ([var (car var-val)] 476 | [val (cadr var-val)]) 477 | (bind var 478 | (list 'if var var val)))) 479 | optional-args)]) 480 | (make-lambda 481 | new-formals 482 | (transform 483 | (make-let 484 | 'let* 485 | bindings 486 | (lambda-body expr)) 487 | (append (lambda-vars expr) bound-vars))))))] 488 | [(let? expr) 489 | (make-let 490 | (let-kind expr) 491 | (map (lambda (binding) 492 | (bind (lhs binding) (transform (rhs binding) bound-vars))) 493 | (let-bindings expr)) 494 | (transform (let-body expr) 495 | (append (map lhs (let-bindings expr)) bound-vars)))] 496 | [(let*? expr) 497 | (transform 498 | (if (null? (let-bindings expr)) 499 | (let-body expr) 500 | (make-let 501 | 'let 502 | (list (first (let-bindings expr))) 503 | (make-let 504 | 'let* 505 | (rest (let-bindings expr)) 506 | (let-body expr)))) 507 | bound-vars)] 508 | [(letrec? expr) 509 | (transform 510 | (make-let 511 | 'let 512 | (map (lambda (binding) (bind (lhs binding) '#f)) 513 | (letrec-bindings expr)) 514 | (make-body 515 | (append 516 | (map (lambda (binding) (make-set! (lhs binding) (rhs binding))) 517 | (letrec-bindings expr)) 518 | (let-body-seq expr)))) 519 | bound-vars)] 520 | [(tagged-list 'and expr) 521 | (cond 522 | [(null? (cdr expr)) #t] 523 | [(null? (cddr expr)) (transform (cadr expr) bound-vars)] 524 | [else 525 | (transform 526 | (list 'if 527 | (cadr expr) 528 | (cons 'and (cddr expr)) 529 | #f) 530 | bound-vars)])] 531 | [(tagged-list 'or expr) 532 | (cond 533 | [(null? (cdr expr)) #f] 534 | [(null? (cddr expr)) (transform (cadr expr) bound-vars)] 535 | [else 536 | (transform 537 | (list 'let 538 | (list (list 'one (cadr expr)) 539 | (list 'thunk (list 'lambda '() (cons 'or (cddr expr))))) 540 | '(if one 541 | one 542 | (thunk))) 543 | bound-vars)])] 544 | [(tagged-list 'when expr) 545 | (transform 546 | (list 'if (cadr expr) 547 | (make-begin (cddr expr)) 548 | #f) 549 | bound-vars)] 550 | [(tagged-list 'unless expr) 551 | (transform 552 | (cons 'when (cons (list 'not (cadr expr)) (cddr expr))) 553 | bound-vars)] 554 | [(tagged-list 'cond expr) 555 | (transform 556 | (let* ([conditions (cdr expr)] 557 | [first-condition (car conditions)] 558 | [first-test (car first-condition)] 559 | [first-body (cdr first-condition)] 560 | [rest (if (null? (cdr conditions)) #f (cons 'cond (cdr conditions)))]) 561 | (cond 562 | [(and (eq? first-test 'else) (not (member 'else bound-vars))) 563 | (make-begin first-body)] 564 | [(null? first-body) 565 | (list 'or first-test rest)] 566 | [(and (eq? '=> (car first-body)) (not (member '=> bound-vars))) 567 | (list 'let (list (list 'one first-test)) 568 | (list 'if 'one (list (cadr first-body) 'one) rest))] 569 | [else 570 | (list 'if first-test (make-begin first-body) rest)])) 571 | bound-vars)] 572 | [(tagged-list 'case expr) 573 | (transform 574 | (cons 575 | 'cond 576 | (map (lambda (l) 577 | (if (eq? (car l) 'else) 578 | (cons 'else (cdr l)) 579 | (cons 580 | (cons 'and (map (lambda (x) (list 'eq? (list 'quote x) (cadr expr))) (car l))) 581 | (cdr l)))) 582 | (cddr expr))) 583 | bound-vars)] 584 | [(tagged-list 'define-syntax expr) 585 | ;; not supported 586 | #f] 587 | [(tagged-list 'parameterize expr) 588 | (let ((saved 589 | (map (lambda (b) (string->symbol (string-append (symbol->string (lhs b)) "-saved"))) 590 | (let-bindings expr)))) 591 | (make-let 592 | 'let 593 | (map (lambda (b s) (bind s (list (lhs b)))) 594 | (let-bindings expr) 595 | saved) 596 | (make-begin 597 | (append 598 | (map (lambda (b) (list 'set! (lhs b) (list 'lambda '() (rhs b)))) 599 | (let-bindings expr)) 600 | (list (let-body expr)) 601 | (map (lambda (b s) (list 'set! (lhs b) (list 'lambda '() s))) 602 | (let-bindings expr) 603 | saved)))))] 604 | [(tagged-list 'add-tests-with-string-output-noboot expr) 605 | ;; ignore those 606 | #f] 607 | [(tagged-list 'add-tests-with-string-output expr) 608 | (let ((test-name (cadr expr))) 609 | (list 610 | 'set! 611 | 'all-tests 612 | (list 613 | 'cons 614 | (list 'quote 615 | (cons test-name 616 | (map (lambda (t) 617 | (let ((texpr (car t)) 618 | (output-string (caddr t))) 619 | (list texpr 'string output-string))) 620 | (cddr expr)))) 621 | 'all-tests)))] 622 | [(tagged-list 'define-primitive expr) 623 | (transform 624 | (let ((prim-name (car (cadr expr))) 625 | (si (cadr (cadr expr))) 626 | (env (caddr (cadr expr))) 627 | (args (cdddr (cadr expr))) 628 | (b (cddr expr))) 629 | (let ((k (list 'quote prim-name))) 630 | (list 'begin 631 | (list 'putprop k ''*is-prim* #t) 632 | (list 'putprop k ''*arg-count* (length-vararg args)) 633 | (list 'putprop k ''*vararg* (is-vararg args)) 634 | (list 'putprop k ''*emitter* 635 | (list 'lambda (cons si (cons env args)) (make-body b)))))) 636 | bound-vars)] 637 | [(tagged-list 'define-lib-primitive expr) 638 | (transform 639 | (let ((a (cadr expr)) 640 | (b (cddr expr))) 641 | (let ((prim-name (if (pair? a) (car a) a)) 642 | (args (if (pair? a) (cdr a) #f))) 643 | (let ((k (list 'quote prim-name))) 644 | (list 'begin 645 | (list 'set! 'lib-primitives (list 'cons k 'lib-primitives)) 646 | (list 'putprop k ''*is-lib-prim* #t) 647 | (if args 648 | (list 'putprop k ''*arg-count* (length-vararg args)) 649 | #f) 650 | (if args 651 | (list 'putprop k ''*vararg* (is-vararg args)) 652 | #f) 653 | (list 'putprop k ''*lib-code* 654 | (if args 655 | (list 'quote (list 'lambda args (make-body b))) 656 | (list 'quote (make-begin b)))))))) 657 | bound-vars)] 658 | [(and (list? expr) (not (quote? expr))) 659 | (map (lambda (e) (transform e bound-vars)) expr)] 660 | [else expr])) 661 | (transform expr '())) 662 | 663 | (define (alpha-conversion expr) 664 | (define (transform expr env) 665 | (cond 666 | [(variable? expr) 667 | (or (lookup expr env) 668 | (and (lib-primitive? expr) expr) 669 | (and (primitive? expr) 670 | (let ((n (getprop expr '*arg-count*)) 671 | (v (getprop expr '*vararg*))) 672 | (let ((args 673 | (let loop ((i 0) (names '(x y z a b c d e f))) 674 | (if (= i n) 675 | (if v 'extra '()) 676 | (cons (car names) (loop (add1 i) (cdr names))))))) 677 | (list 'lambda args (cons expr args))))) 678 | (error 'alpha-conversion (format "undefined variable ~s" expr)))] 679 | [(lambda? expr) 680 | (let ([new-env (bulk-extend-env 681 | (lambda-vars expr) 682 | (map unique-name (lambda-vars expr)) 683 | env)]) 684 | (make-lambda 685 | (map-formals (lambda (v) (lookup v new-env)) (lambda-formals expr)) 686 | (transform (lambda-body expr) new-env)))] 687 | [(let? expr) 688 | (let* ([lvars (map lhs (let-bindings expr))] 689 | [new-env (bulk-extend-env 690 | lvars 691 | (map unique-name lvars) 692 | env)]) 693 | (make-let 694 | 'let 695 | (map (lambda (binding) 696 | (bind (lookup (lhs binding) new-env) 697 | (transform (rhs binding) env))) 698 | (let-bindings expr)) 699 | (transform (let-body expr) new-env)))] 700 | [(quote? expr) expr] 701 | [(and (list? expr) (not (null? expr)) (special? (car expr))) 702 | (cons (car expr) (map (lambda (e) (transform e env)) (cdr expr)))] 703 | [(list? expr) (map (lambda (e) (transform e env)) expr)] 704 | [else expr])) 705 | (transform expr (make-initial-env '()))) 706 | 707 | (define (assignment-conversion expr) 708 | (let ([assigned '()]) 709 | (define (variable-assigned v) 710 | (member v assigned)) 711 | (define (set-variable-assigned! v) 712 | (unless (variable-assigned v) 713 | (set! assigned (cons v assigned)))) 714 | (define (mark expr) 715 | (when (set? expr) (set-variable-assigned! (set-lhs expr))) 716 | (when (list? expr) (for-each mark expr))) 717 | (define (transform expr) 718 | (cond 719 | [(set? expr) 720 | (list 'set-car! (set-lhs expr) (transform (set-rhs expr)))] 721 | [(lambda? expr) 722 | (let ([vars (filter variable-assigned (lambda-vars expr))]) 723 | (make-lambda 724 | (lambda-formals expr) 725 | (if (null? vars) 726 | (transform (lambda-body expr)) 727 | (make-let 728 | 'let 729 | (map (lambda (v) (bind v (list 'cons v #f))) vars) 730 | (transform (lambda-body expr))))))] 731 | [(let? expr) 732 | (make-let 733 | 'let 734 | (map (lambda (binding) 735 | (let ([var (lhs binding)] 736 | [val (transform (rhs binding))]) 737 | (bind var 738 | (if (variable-assigned var) 739 | (list 'cons val #f) 740 | val)))) 741 | (let-bindings expr)) 742 | (transform (let-body expr)))] 743 | [(quote? expr) 744 | expr] 745 | [(list? expr) 746 | (map transform expr)] 747 | [(and (variable? expr) (variable-assigned expr)) 748 | (list 'car expr)] 749 | [else expr])) 750 | (mark expr) 751 | (transform expr))) 752 | 753 | (define (quote? expr) 754 | (tagged-list 'quote expr)) 755 | (define quote-expr cadr) 756 | 757 | (define (translate-quote expr) 758 | (cond 759 | [(immediate? expr) expr] 760 | [(symbol? expr) (list 'string->symbol (translate-quote (symbol->string expr)))] 761 | [(pair? expr) 762 | (list 'cons (translate-quote (car expr)) (translate-quote (cdr expr)))] 763 | [(vector? expr) 764 | (cons 'vector (map translate-quote (vector->list expr)))] 765 | [(string? expr) 766 | (cons 'string (map translate-quote (string->list expr)))] 767 | [else (error 'translate-quote (format "don't know how to quote ~s" expr))])) 768 | 769 | (define (lift-constants expr) 770 | (let ([constants '()]) 771 | (define (transform expr) 772 | (cond 773 | [(and (quote? expr) (immediate? (quote-expr expr))) (quote-expr expr)] 774 | [(and (quote? expr) (assoc expr constants)) => cadr] 775 | [(quote? expr) 776 | (set! constants (cons (list expr (list 'constant-ref (unique-name 'c))) constants)) 777 | (cadr (assoc expr constants))] 778 | [(string? expr) (transform (list 'quote expr))] 779 | [(foreign-call? expr) (make-foreign-call (foreign-call-name expr) (map transform (foreign-call-args expr)))] 780 | [(list? expr) (map transform expr)] 781 | [else expr])) 782 | (let ([texpr (transform expr)]) 783 | (make-let 784 | 'labels 785 | (map (lambda (val-cst) 786 | (bind (cadadr val-cst) '(datum))) 787 | constants) 788 | (if (null? constants) 789 | texpr 790 | (combine-exprs 791 | (make-begin 792 | (map (lambda (val-cst) 793 | (list 'constant-init 794 | (cadadr val-cst) 795 | (all-expr-conversions (translate-quote (quote-expr (car val-cst)))))) 796 | constants)) 797 | texpr)))))) 798 | 799 | (define (combine-exprs a b) 800 | (cond 801 | [(and (begin? a) (begin? b)) (make-begin (append (begin-seq a) (begin-seq b)))] 802 | [(begin? a) (make-begin (append (begin-seq a) (list b)))] 803 | [(begin? b) (make-begin (cons a (begin-seq b)))] 804 | [else (make-begin (list a b))])) 805 | 806 | (define (annotate-lib-primitives expr) 807 | (define (transform expr) 808 | (cond 809 | [(and (variable? expr) (lib-primitive? expr)) (list 'primitive-ref expr)] 810 | [(quote? expr) expr] 811 | [(list? expr) (map transform expr)] 812 | [else expr])) 813 | (transform expr)) 814 | 815 | (define (emit-global-save) 816 | (emit " mov ~s(%ebp), %edx" global-offset) 817 | (emit " mov %eax, (%edx)") 818 | (emit " mov %edx, %eax") 819 | (emit " add $~s, %edx" wordsize) 820 | (emit " mov %edx, ~s(%ebp)" global-offset)) 821 | 822 | (define (emit-global-load) 823 | (emit " mov (%eax), %eax")) 824 | 825 | (define (primitive-label name) 826 | (let ([lst (map (lambda (c) 827 | (case c 828 | [(#\-) #\_] 829 | [(#\!) #\b] 830 | [(#\=) #\e] 831 | [(#\>) #\g] 832 | [(#\?) #\p] 833 | [else c])) 834 | (string->list (symbol->string name)))]) 835 | (string->symbol (string-append "P_" (list->string lst))))) 836 | (define (primitive-alloc name) 837 | (string->symbol (string-append (symbol->string (primitive-label name)) "_alloc"))) 838 | 839 | (define (app? expr) 840 | (and (list? expr) (not (null? expr)))) 841 | (define (call-apply? expr) 842 | (tagged-list 'apply expr)) 843 | (define (call-target expr) 844 | (if (call-apply? expr) 845 | (cadr expr) 846 | (car expr))) 847 | (define (call-args expr) 848 | (if (call-apply? expr) 849 | (cddr expr) 850 | (cdr expr))) 851 | (define (emit-app si env tail expr) 852 | (define (emit-arguments si args) 853 | (unless (empty? args) 854 | (emit-expr si env (first args)) 855 | (emit-stack-save si) 856 | (emit-arguments (- si wordsize) (rest args)))) 857 | (define (move-arguments si delta args) 858 | (unless (or (= delta 0) (empty? args)) 859 | (emit-stack-load si) 860 | (emit-stack-save (+ si delta)) 861 | (move-arguments (- si wordsize) delta (rest args)))) 862 | (define (splice-last-argument) 863 | (let ([si (- (* wordsize (length (call-args expr))))] 864 | [loop-label (unique-label)] 865 | [pair-label (unique-label)] 866 | [done-label (unique-label)]) 867 | (emit-stack-save (next-stack-index si)) 868 | (emit " mov $~s, %eax" (length (call-args expr))) 869 | (emit-stack-save (next-stack-index (next-stack-index si))) 870 | (emit " mov %eax, %edx") 871 | (emit-stack-load si) 872 | (emit-label loop-label) 873 | (emit " cmp $~s, %al" list-nil) 874 | (emit " jne ~a" pair-label) 875 | (emit " mov %edx, %eax") 876 | (emit " shl $2, %eax") 877 | (emit " neg %eax") 878 | (emit " add %esp, %eax") 879 | (emit " mov -4(%eax), %edx") 880 | (emit " mov -8(%eax), %eax") 881 | (emit " sub $1, %eax") 882 | (emit-jmp done-label) 883 | (emit-label pair-label) 884 | (emit " mov %edx, %eax") 885 | (emit " shl $2, %eax") 886 | (emit " neg %eax") 887 | (emit " add %esp, %eax") 888 | (emit " mov -8(%eax), %edx") 889 | (emit " add $1, %edx") 890 | (emit " mov %edx, -12(%eax)") 891 | (emit " mov -4(%eax), %edx") 892 | (emit " mov %edx, -8(%eax)") 893 | (emit " mov (%eax), %edx") 894 | (emit " mov ~s(%edx), %edx" (- paircdr pairtag)) 895 | (emit " mov %edx, -4(%eax)") 896 | (emit " mov (%eax), %edx") 897 | (emit " mov ~s(%edx), %edx" (- paircar pairtag)) 898 | (emit " mov %edx, (%eax)") 899 | (emit " mov %eax, %edx") 900 | (emit " mov -4(%eax), %eax") 901 | (emit " mov -12(%edx), %edx") 902 | (emit-jmp loop-label) 903 | (emit-label done-label))) 904 | (cond 905 | [(not tail) 906 | (emit " mov %edi, ~s(%esp)" si) 907 | (emit " movl $~s, ~s(%esp)" return-addr (next-stack-index si)) 908 | (emit-arguments (- si (* 3 wordsize)) (call-args expr)) 909 | (emit-expr (- si (* wordsize (+ 3 (length (call-args expr))))) env (call-target expr)) 910 | (emit " mov %eax, %edi") 911 | (emit-ensure-procedure si env expr) 912 | (emit-load-closure-label) 913 | (emit-adjust-base (next-stack-index si)) 914 | (emit " mov %eax, %edx") 915 | (if (call-apply? expr) 916 | (begin 917 | (emit " sub $4, %esp") 918 | (splice-last-argument) 919 | (emit " add $4, %esp")) 920 | (emit " mov $~s, %eax" (length (call-args expr)))) 921 | (emit-call "*%edx") 922 | (emit-adjust-base (- (next-stack-index si))) 923 | (emit " mov ~s(%esp), %edi" si)] 924 | [else ; tail 925 | (emit-arguments si (call-args expr)) 926 | (emit-expr (- si (* wordsize (length (call-args expr)))) env (call-target expr)) 927 | (emit " mov %eax, %edi") 928 | (emit-ensure-procedure si env expr) 929 | (move-arguments si (- (+ si wordsize)) (call-args expr)) 930 | (emit " mov %edi, %eax") 931 | (emit-load-closure-label) 932 | (emit " mov %eax, %edx") 933 | (if (call-apply? expr) 934 | (splice-last-argument) 935 | (emit " mov $~s, %eax" (length (call-args expr)))) 936 | (emit-jmp "*%edx")])) 937 | (define (emit-ensure-procedure si env expr) 938 | (unless (equal? (call-target expr) '(primitive-ref error)) 939 | (let ([ok (unique-label)]) 940 | (emit " and $~s, %al" objmask) 941 | (emit " cmp $~s, %al" closuretag) 942 | (emit " je ~a" ok) 943 | (emit-error si env) 944 | (emit-label ok) 945 | (emit " mov %edi, %eax")))) 946 | (define (emit-error si env) 947 | (emit-tail-expr si env (if enable-cps '((primitive-ref error) #f) '((primitive-ref error))))) 948 | 949 | (define heap-cell-size (ash 1 objshift)) 950 | (define (emit-heap-alloc-static si size) 951 | (let ([alloc-size (* (add1 (div (sub1 size) heap-cell-size)) heap-cell-size)]) 952 | (emit " mov $~s, %eax" alloc-size) 953 | (emit-heap-alloc si))) 954 | (define (emit-heap-alloc-dynamic si) 955 | (emit " add $~s, %eax" (sub1 heap-cell-size)) 956 | (emit " and $~s, %eax" (- heap-cell-size)) 957 | (emit-heap-alloc si)) 958 | (define (emit-heap-alloc si) 959 | (let ([new-si (- si (* 2 wordsize))]) 960 | (emit-adjust-base new-si) 961 | (emit " mov %eax, ~s(%esp)" (* 2 wordsize)) 962 | (emit " mov %esp, %eax") 963 | (emit " add $~s, %eax" (* 2 wordsize)) 964 | (emit " mov %eax, ~s(%esp)" (* 1 wordsize)) 965 | (emit " mov %ebp, ~s(%esp)" (* 0 wordsize)) 966 | (emit " mov %edi, ~s(%ebp)" edi-offset) 967 | (emit-call "heap_alloc") 968 | (emit-adjust-base (- new-si)) 969 | (emit " mov ~s(%ebp), %edi" edi-offset))) 970 | (define (emit-stack-to-heap si offset) 971 | (emit " mov ~s(%esp), %edx" si) 972 | (emit " mov %edx, ~s(%eax)" offset)) 973 | (define (emit-heap-load offset) 974 | (emit " mov ~s(%eax), %eax" offset)) 975 | (define (emit-object? tag si env arg) 976 | (emit-expr si env arg) 977 | (emit " and $~s, %al" objmask) 978 | (emit " cmp $~s, %al" tag) 979 | (emit-cmp-bool)) 980 | 981 | (define cps-conversion (lambda (x) x)) 982 | 983 | (define (closure-conversion expr) 984 | (let ([labels '()] 985 | [constants (map lhs (labels-bindings expr))]) 986 | (define (transform expr . label) 987 | (cond 988 | [(lambda? expr) 989 | (let ([label (or (and (not (null? label)) (car label)) (unique-label))] 990 | [fvs (filter (lambda (v) (not (member v constants))) (free-vars expr))] 991 | [body (transform (lambda-body expr))]) 992 | (set! labels 993 | (cons (bind label 994 | (make-code (lambda-formals expr) 995 | fvs 996 | body)) 997 | labels)) 998 | (make-closure label fvs))] 999 | [(any-let? expr) 1000 | (make-let (let-kind expr) 1001 | (map (lambda (binding) 1002 | (bind (lhs binding) (transform (rhs binding)))) 1003 | (let-bindings expr)) 1004 | (transform (let-body expr)))] 1005 | [(list? expr) 1006 | (map transform expr)] 1007 | [else 1008 | expr])) 1009 | (let* ([body (transform (labels-body expr))]) 1010 | (make-let 'labels labels body)))) 1011 | 1012 | (define (load-file fn) 1013 | (let ((f (open-input-file fn))) 1014 | (let loop ((r (read f)) (acc '())) 1015 | (if (eof-object? r) 1016 | (begin 1017 | (close-input-port f) 1018 | (reverse acc)) 1019 | (loop (read f) (append (load-files r) acc)))))) 1020 | (define (string-starts-with sub str) 1021 | (and (<= (string-length sub) (string-length str)) 1022 | (let loop ((i 0)) 1023 | (or (= i (string-length sub)) 1024 | (and (eq? (string-ref sub i) (string-ref str i)) 1025 | (loop (+ i 1))))))) 1026 | (define (load-files expr) 1027 | (if (list? expr) 1028 | (if (and (not (null? expr)) (eq? 'load (car expr))) 1029 | (if (not (string-starts-with "tests-6." (cadr expr))) 1030 | (load-file (cadr expr)) 1031 | '() ;; skip 1032 | ) 1033 | (if (and (not (null? expr)) (eq? 'define-syntax (car expr))) 1034 | (list expr) 1035 | (list (flatmap load-files expr)))) 1036 | (list expr))) 1037 | (define (all-expr-conversions expr) 1038 | (annotate-lib-primitives (assignment-conversion (alpha-conversion (macro-expand (cons 'let (cons '() (load-files expr)))))))) 1039 | (define (all-conversions expr) 1040 | (closure-conversion (cps-conversion (lift-constants (all-expr-conversions expr))))) 1041 | 1042 | (define (special? symbol) 1043 | (or (member symbol '(if begin let lambda closure set! quote apply)) 1044 | (and enable-cps (eq? symbol 'call/cc)) 1045 | (primitive? symbol))) 1046 | 1047 | (define (flatmap f . lst) 1048 | (apply append (apply map f lst))) 1049 | 1050 | (define (free-vars_ expr) 1051 | (cond 1052 | [(variable? expr) (list expr)] 1053 | [(lambda? expr) (filter (lambda (v) (not (member v (lambda-vars expr)))) 1054 | (free-vars_ (lambda-body expr)))] 1055 | [(let? expr) 1056 | (append 1057 | (flatmap free-vars_ (map rhs (let-bindings expr))) 1058 | (filter (lambda (v) (not (member v (map lhs (let-bindings expr))))) 1059 | (free-vars_ (let-body expr))))] 1060 | [(tagged-list 'primitive-ref expr) '()] 1061 | [(list? expr) (flatmap free-vars_ (if (and (not (null? expr)) (special? (car expr))) (cdr expr) expr))] 1062 | [else '()])) 1063 | 1064 | (define (remove-dups xs) 1065 | (if (null? xs) 1066 | xs 1067 | (cons (first xs) 1068 | (remove-dups (filter (lambda (el) (not (equal? (first xs) el))) xs))))) 1069 | 1070 | (define (free-vars expr) 1071 | (remove-dups (free-vars_ expr))) 1072 | 1073 | (define (emit-labels expr k) 1074 | (let* ([bindings (labels-bindings expr)] 1075 | [labels (map lhs bindings)] 1076 | [codes (map rhs bindings)] 1077 | [env (make-initial-env '())]) 1078 | (for-each (emit-code env #f) codes labels) 1079 | (k (labels-body expr) env))) 1080 | 1081 | (define (make-closure label fvs) 1082 | (cons 'closure (cons label fvs))) 1083 | (define (closure? expr) (tagged-list 'closure expr)) 1084 | (define closure-label cadr) 1085 | (define closure-free-vars cddr) 1086 | (define (emit-closure si env expr) 1087 | (let ([label (closure-label expr)] 1088 | [fvs (closure-free-vars expr)]) 1089 | (emit-heap-alloc-static si (* (+ 2 (length fvs)) wordsize)) 1090 | (emit " movl $~s, (%eax)" (immediate-rep (length fvs))) 1091 | (emit " movl $~s, ~s(%eax)" label wordsize) 1092 | (unless (null? fvs) 1093 | (emit " mov %eax, %edx") 1094 | (let loop ([fvs fvs] [count 2]) 1095 | (unless (null? fvs) 1096 | (emit-variable-ref si env (first fvs)) 1097 | (emit " mov %eax, ~s(%edx)" (* count wordsize)) 1098 | (loop (rest fvs) (add1 count)))) 1099 | (emit " mov %edx, %eax")) 1100 | (emit " or $~s, %eax" closuretag))) 1101 | (define (emit-load-closure-label) 1102 | (emit-heap-load (- wordsize closuretag))) 1103 | 1104 | (define (make-code formals free body) 1105 | (list 'code formals free body)) 1106 | (define code-formals cadr) 1107 | (define (code-bound-variables expr) (formals-to-vars (code-formals expr))) 1108 | (define (code-vararg? expr) 1109 | (not (list? (code-formals expr)))) 1110 | (define (code-optarg? expr) 1111 | (and (list? (code-formals expr)) (not (null? (filter list? (code-formals expr)))))) 1112 | (define (code-opt-start-index expr) 1113 | (let loop ([index 0] [formals (code-formals expr)]) 1114 | (if (list? (car formals)) 1115 | index 1116 | (loop (add1 index) (cdr formals))))) 1117 | (define code-free-variables caddr) 1118 | (define code-body cadddr) 1119 | (define (emit-code env global?) 1120 | (lambda (expr label) 1121 | ((if global? emit-function-header emit-label) label) 1122 | (let ([bvs (code-bound-variables expr)] 1123 | [fvs (code-free-variables expr)] 1124 | [body (code-body expr)]) 1125 | (when (and (not (code-vararg? expr)) (not (code-optarg? expr))) 1126 | (let ([start-label (unique-label)]) 1127 | (emit " cmp $~s, %eax" (length bvs)) 1128 | (emit " je ~a" start-label) 1129 | (emit-error (- wordsize) env) 1130 | (emit-label start-label) 1131 | (emit " mov $~s, %eax" (length bvs)))) 1132 | (when (code-optarg? expr) 1133 | (let ([start-index (code-opt-start-index expr)] 1134 | [len (length bvs)] 1135 | [check2-label (unique-label)] 1136 | [loop-label (unique-label)] 1137 | [start-label (unique-label)]) 1138 | (emit " mov %eax, %edx") 1139 | (emit " cmp $~s, %edx" start-index) 1140 | (emit " jge ~a" check2-label) 1141 | (emit-error (- wordsize) env) 1142 | (emit-label check2-label) 1143 | (emit " cmp $~s, %edx" len) 1144 | (emit " jle ~a" loop-label) 1145 | (emit-error (- wordsize) env) 1146 | (emit-label loop-label) 1147 | (emit " cmp $~s, %edx" len) 1148 | (emit " je ~a" start-label) 1149 | (emit " add $1, %edx") 1150 | (emit " mov %edx, %eax") 1151 | (emit " shl $~s, %eax" wordshift) 1152 | (emit " neg %eax") 1153 | (emit " add %esp, %eax") 1154 | (emit " movl $~s, (%eax)" bool-f) 1155 | (emit-jmp loop-label) 1156 | (emit-label start-label) 1157 | (emit " mov %edx, %eax"))) 1158 | (when (code-vararg? expr) 1159 | (let ([ok (unique-label)] 1160 | [start-label (unique-label)] 1161 | [fill-label (unique-label)] 1162 | [loop-label (unique-label)]) 1163 | (emit " mov %eax, %edx") 1164 | (when (> (- (length bvs) 1) 0) 1165 | (emit " cmp $~s, %edx" (- (length bvs) 1)) 1166 | (emit " jge ~a" ok) 1167 | (emit-error (- wordsize) env) 1168 | (emit-label ok)) 1169 | (emit-immediate '()) 1170 | (emit " cmp $~s, %edx" (- (length bvs) 1)) 1171 | (emit " je ~a" fill-label) 1172 | (emit-label loop-label) 1173 | (emit " cmp $~s, %edx" (length bvs)) 1174 | (emit " jl ~a" start-label) 1175 | (emit " shl $~s, %edx" wordshift) 1176 | (emit " sub %edx, %esp") 1177 | (emit-stack-save (next-stack-index 0)) 1178 | (emit " mov %edx, %eax") 1179 | (emit-stack-save (next-stack-index (next-stack-index 0))) 1180 | (emit-cons 0 (next-stack-index (next-stack-index (next-stack-index 0)))) 1181 | (emit-stack-save 0) 1182 | (emit-stack-load (next-stack-index (next-stack-index 0))) 1183 | (emit " mov %eax, %edx") 1184 | (emit-stack-load 0) 1185 | (emit " add %edx, %esp") 1186 | (emit " shr $~s, %edx" wordshift) 1187 | (emit " sub $1, %edx") 1188 | (emit-jmp loop-label) 1189 | (emit-label fill-label) 1190 | (emit " add $1, %edx") 1191 | (emit " shl $~s, %edx" wordshift) 1192 | (emit " sub %edx, %esp") 1193 | (emit-stack-save 0) 1194 | (emit " add %edx, %esp") 1195 | (emit-label start-label))) 1196 | (extend-env-with (- wordsize) env bvs (lambda (si env) 1197 | (close-env-with (* 2 wordsize) env fvs (lambda (env) 1198 | (emit-tail-expr si env body)))))))) 1199 | 1200 | (define (emit-expr-save si env arg) 1201 | (emit-expr si env arg) 1202 | (emit-stack-save si)) 1203 | 1204 | (define (emit-label label) 1205 | (emit "~a:" label)) 1206 | 1207 | (define (emit-function-header f) 1208 | (emit " .text") 1209 | (emit " .globl ~a" f) 1210 | (emit " .type ~a, @function" f) 1211 | (emit-label f)) 1212 | 1213 | (define (emit-scheme-entry expr env) 1214 | (emit-function-header "L_scheme_entry") 1215 | (emit-tail-expr (- wordsize) env expr)) 1216 | 1217 | (define (emit-adjust-base si) 1218 | (cond 1219 | [(> si 0) (emit " add $~s, %esp" si)] 1220 | [(< si 0) (emit " sub $~s, %esp" (- si))])) 1221 | 1222 | (define (emit-call label) 1223 | (emit " call ~a" label)) 1224 | 1225 | (define (emit-jmp label) 1226 | (emit " jmp ~a" label)) 1227 | 1228 | (define (emit-make-vector si) 1229 | (emit " add $~s, %eax" wordsize) 1230 | (emit-heap-alloc-dynamic (next-stack-index si)) 1231 | (emit-stack-to-heap si 0) 1232 | (emit " or $~s, %eax" vectortag)) 1233 | (define (emit-make-string si) 1234 | (emit " shr $~s, %eax" fxshift) 1235 | (emit " add $~s, %eax" wordsize) 1236 | (emit-heap-alloc-dynamic (next-stack-index si)) 1237 | (emit-stack-to-heap si 0) 1238 | (emit " or $~s, %eax" stringtag)) 1239 | 1240 | (define (emit-cons si free-si) 1241 | (emit-heap-alloc-static free-si pairsize) 1242 | (emit " or $~s, %eax" pairtag) 1243 | (emit-stack-to-heap si (- paircar pairtag)) 1244 | (emit-stack-to-heap (next-stack-index si) (- paircdr pairtag))) 1245 | 1246 | (define (preserve-registers cmd) 1247 | (let loop ([regs registers] [count 0]) 1248 | (unless (null? regs) 1249 | (let ([reg (first regs)]) 1250 | (when (reg-preserve? reg) 1251 | (cmd (reg-name reg) (* count wordsize))) 1252 | (loop (rest regs) (+ count 1)))))) 1253 | 1254 | (define (backup-registers) 1255 | (preserve-registers (lambda (name num) 1256 | (emit " mov %~a, ~s(%ecx)" name num)))) 1257 | 1258 | (define (restore-registers) 1259 | (preserve-registers (lambda (name num) 1260 | (emit " mov ~s(%ecx), %~a" num name)))) 1261 | 1262 | (set! 1263 | emit-library 1264 | (lambda () 1265 | (define (emit-library-primitive prim-name) 1266 | (let ([labels (all-conversions (lib-primitive-code prim-name))]) 1267 | (emit-labels labels (lambda (expr env) 1268 | ((emit-code env #t) (make-code '() '() expr) (primitive-alloc prim-name)))) 1269 | (let ([label (primitive-label prim-name)]) 1270 | (emit ".global ~s" label) 1271 | (emit ".comm ~s,4,4" label)))) 1272 | (for-each emit-library-primitive lib-primitives))) 1273 | 1274 | (set! 1275 | emit-program 1276 | (lambda (expr) 1277 | (emit-function-header "scheme_entry") 1278 | (emit " mov 4(%esp), %ecx") 1279 | (backup-registers) 1280 | (emit " mov %ecx, %esi") 1281 | (emit " mov 12(%esp), %ebp") 1282 | (emit " mov 8(%esp), %esp") 1283 | (emit " mov $0, %edi") 1284 | (emit-call "L_scheme_entry") 1285 | (emit " mov %esi, %ecx") 1286 | (restore-registers) 1287 | (emit " ret") 1288 | (emit-labels (all-conversions expr) emit-scheme-entry))) 1289 | 1290 | (when enable-cps 1291 | (load "cps.scm")) 1292 | 1293 | (define-primitive (constant-ref si env constant) 1294 | (emit " mov ~s, %eax" constant) 1295 | (emit-global-load)) 1296 | (define-primitive (constant-init si env constant value) 1297 | (emit ".local ~s" constant) 1298 | (emit ".comm ~s,4,4" constant) 1299 | (emit-expr si env value) 1300 | (emit-global-save) 1301 | (emit " mov %eax, ~s" constant) 1302 | (emit " mov $0, %eax")) 1303 | (define-primitive (primitive-ref si env prim-name) 1304 | (let ([label (primitive-label prim-name)] 1305 | [done-label (unique-label)]) 1306 | (emit " mov ~s, %eax" label) 1307 | (emit " testl %eax, %eax") 1308 | (emit " jne ~s" done-label) 1309 | (emit " movl $~s, ~s(%esp)" return-addr si) 1310 | (emit-adjust-base si) 1311 | (emit-call (primitive-alloc prim-name)) 1312 | (emit-adjust-base (- si)) 1313 | (emit-global-save) 1314 | (emit " mov %eax, ~s" label) 1315 | (emit-label done-label) 1316 | (emit-global-load))) 1317 | 1318 | (define-primitive (foreign-call si env name . args) 1319 | (let ([new-si (let loop ([si (+ si wordsize)] 1320 | [args (reverse args)]) 1321 | (cond 1322 | [(null? args) si] 1323 | [else 1324 | (emit-expr-save (next-stack-index si) env (car args)) 1325 | (loop (next-stack-index si) (cdr args))]))]) 1326 | (emit-adjust-base new-si) 1327 | (emit-call name) 1328 | (emit-adjust-base (- new-si)))) 1329 | 1330 | (define-primitive (fxadd1 si env arg) 1331 | (emit-expr si env arg) 1332 | (emit " add $~s, %eax" (immediate-rep 1))) 1333 | 1334 | (define-primitive (fxsub1 si env arg) 1335 | (emit-expr si env arg) 1336 | (emit " sub $~s, %eax" (immediate-rep 1))) 1337 | 1338 | (define-primitive (fixnum->char si env arg) 1339 | (emit-expr si env arg) 1340 | (emit " shl $~s, %eax" (- charshift fxshift)) 1341 | (emit " or $~s, %eax" chartag)) 1342 | 1343 | (define-primitive (char->fixnum si env arg) 1344 | (emit-expr si env arg) 1345 | (emit " shr $~s, %eax" (- charshift fxshift))) 1346 | 1347 | (define-primitive (fixnum? si env arg) 1348 | (emit-expr si env arg) 1349 | (emit " and $~s, %al" fxmask) 1350 | (emit " cmp $~s, %al" fxtag) 1351 | (emit-cmp-bool)) 1352 | 1353 | (define-primitive (fxzero? si env arg) 1354 | (emit-expr si env arg) 1355 | (emit " cmp $~s, %eax" fxtag) 1356 | (emit-cmp-bool)) 1357 | 1358 | (define-primitive (null? si env arg) 1359 | (emit-expr si env arg) 1360 | (emit " cmp $~s, %al" list-nil) 1361 | (emit-cmp-bool)) 1362 | 1363 | (define-primitive (eof-object? si env arg) 1364 | (emit-expr si env arg) 1365 | (emit " cmp $~s, %al" eof-obj) 1366 | (emit-cmp-bool)) 1367 | 1368 | (define-primitive (eof-object si env) 1369 | (emit " mov $~s, %eax" eof-obj)) 1370 | 1371 | (define-primitive (boolean? si env arg) 1372 | (emit-expr si env arg) 1373 | (emit " and $~s, %al" boolmask) 1374 | (emit " cmp $~s, %al" bool-f) 1375 | (emit-cmp-bool)) 1376 | 1377 | (define-primitive (char? si env arg) 1378 | (emit-expr si env arg) 1379 | (emit " and $~s, %al" charmask) 1380 | (emit " cmp $~s, %al" chartag) 1381 | (emit-cmp-bool)) 1382 | 1383 | (define-primitive (not si env arg) 1384 | (emit-expr si env arg) 1385 | (emit " cmp $~s, %al" bool-f) 1386 | (emit-cmp-bool)) 1387 | 1388 | (define-primitive (fxlognot si env arg) 1389 | (emit-expr si env arg) 1390 | (emit " shr $~s, %eax" fxshift) 1391 | (emit " not %eax") 1392 | (emit " shl $~s, %eax" fxshift)) 1393 | 1394 | (define-primitive (fx+ si env arg1 arg2) 1395 | (emit-binop si env arg1 arg2) 1396 | (emit " add ~s(%esp), %eax" si)) 1397 | 1398 | (define-primitive (fx- si env arg1 arg2) 1399 | (emit-binop si env arg1 arg2) 1400 | (emit " sub %eax, ~s(%esp)" si) 1401 | (emit-stack-load si)) 1402 | 1403 | (define-primitive (fx* si env arg1 arg2) 1404 | (emit-binop si env arg1 arg2) 1405 | (emit " shr $~s, %eax" fxshift) 1406 | (emit " mull ~s(%esp)" si)) 1407 | 1408 | (define-primitive ($fxquotient si env arg1 arg2) 1409 | (emit-div si env arg1 arg2) 1410 | (emit " shl $~s, %eax" fxshift)) 1411 | 1412 | (define-primitive ($fxremainder si env arg1 arg2) 1413 | (emit-div si env arg1 arg2) 1414 | (emit " mov %edx, %eax") 1415 | (emit " shl $~s, %eax" fxshift)) 1416 | 1417 | (define-primitive (fxlogor si env arg1 arg2) 1418 | (emit-binop si env arg1 arg2) 1419 | (emit " or ~s(%esp), %eax" si)) 1420 | 1421 | (define-primitive (fxlogand si env arg1 arg2) 1422 | (emit-binop si env arg1 arg2) 1423 | (emit " and ~s(%esp), %eax" si)) 1424 | 1425 | (define-primitive (fx= si env arg1 arg2) 1426 | (emit-cmp-binop 'sete si env arg1 arg2)) 1427 | 1428 | (define-primitive (fx< si env arg1 arg2) 1429 | (emit-cmp-binop 'setl si env arg1 arg2)) 1430 | 1431 | (define-primitive (fx<= si env arg1 arg2) 1432 | (emit-cmp-binop 'setle si env arg1 arg2)) 1433 | 1434 | (define-primitive (fx> si env arg1 arg2) 1435 | (emit-cmp-binop 'setg si env arg1 arg2)) 1436 | 1437 | (define-primitive (fx>= si env arg1 arg2) 1438 | (emit-cmp-binop 'setge si env arg1 arg2)) 1439 | 1440 | (define-primitive (make-symbol si env str) 1441 | (emit-expr si env str) 1442 | (emit " sub $~s, %eax" stringtag) 1443 | (emit " or $~s, %eax" symboltag)) 1444 | (define-primitive (string-symbol si env symbol) 1445 | (emit-expr si env symbol) 1446 | (emit " sub $~s, %eax" symboltag) 1447 | (emit " or $~s, %eax" stringtag)) 1448 | (define-primitive (symbol? si env arg) 1449 | (emit-object? symboltag si env arg)) 1450 | (define-primitive (make-string si env length) 1451 | (emit-expr-save si env length) 1452 | (emit-make-string si)) 1453 | (define-primitive (string? si env arg) 1454 | (emit-object? stringtag si env arg)) 1455 | (define-primitive ($string-set! si env string index value) 1456 | (emit-expr si env index) 1457 | (emit " shr $~s, %eax" fxshift) 1458 | (emit " add $~s, %eax" wordsize) 1459 | (emit-stack-save si) 1460 | (emit-expr (next-stack-index si) env value) 1461 | (emit " shr $~s, %eax" charshift) 1462 | (emit-stack-save (next-stack-index si)) 1463 | (emit-expr (next-stack-index (next-stack-index si)) env string) 1464 | (emit " add ~s(%esp), %eax" si) 1465 | (emit " mov ~s(%esp), %edx" (next-stack-index si)) 1466 | (emit " movb %dl, ~s(%eax)" (- stringtag)) 1467 | (emit " mov $0, %eax")) 1468 | (define-primitive ($string-ref si env string index) 1469 | (emit-expr si env index) 1470 | (emit " shr $~s, %eax" fxshift) 1471 | (emit " add $~s, %eax" wordsize) 1472 | (emit-stack-save si) 1473 | (emit-expr (next-stack-index si) env string) 1474 | (emit " add ~s(%esp), %eax" si) 1475 | (emit " movzb ~s(%eax), %eax" (- stringtag)) 1476 | (emit " shl $~s, %eax" charshift) 1477 | (emit " or $~s, %eax" chartag)) 1478 | (define-primitive (string-length si env arg) 1479 | (emit-expr si env arg) 1480 | (emit-heap-load (- stringtag))) 1481 | (define-primitive (char= si env arg1 arg2) 1482 | (emit-cmp-binop 'sete si env arg1 arg2)) 1483 | 1484 | (define-primitive (make-vector si env length) 1485 | (emit-expr-save si env length) 1486 | (emit-make-vector si)) 1487 | (define-primitive (vector? si env arg) 1488 | (emit-object? vectortag si env arg)) 1489 | (define-primitive (vector-length si env arg) 1490 | (emit-expr si env arg) 1491 | (emit-heap-load (- vectortag))) 1492 | (define-primitive ($vector-set! si env vector index value) 1493 | (emit-expr si env index) 1494 | (emit " add $~s, %eax" wordsize) 1495 | (emit-stack-save si) 1496 | (emit-expr-save (next-stack-index si) env value) 1497 | (emit-expr (next-stack-index (next-stack-index si)) env vector) 1498 | (emit " add ~s(%esp), %eax" si) 1499 | (emit-stack-to-heap (next-stack-index si) (- vectortag)) 1500 | (emit " mov $0, %eax")) 1501 | (define-primitive ($vector-ref si env vector index) 1502 | (emit-expr si env index) 1503 | (emit " add $~s, %eax" wordsize) 1504 | (emit-stack-save si) 1505 | (emit-expr (next-stack-index si) env vector) 1506 | (emit " add ~s(%esp), %eax" si) 1507 | (emit-heap-load (- vectortag))) 1508 | 1509 | (define-primitive (procedure? si env arg) 1510 | (emit-object? closuretag si env arg)) 1511 | 1512 | (define-primitive (cons si env arg1 arg2) 1513 | (emit-binop si env arg1 arg2) 1514 | (emit-stack-save (next-stack-index si)) 1515 | (emit-cons si (next-stack-index (next-stack-index si)))) 1516 | 1517 | (define-primitive (pair? si env arg) 1518 | (emit-object? pairtag si env arg)) 1519 | (define-primitive (car si env arg) 1520 | (emit-expr si env arg) 1521 | (emit-heap-load (- paircar pairtag))) 1522 | (define-primitive (cdr si env arg) 1523 | (emit-expr si env arg) 1524 | (emit-heap-load (- paircdr pairtag))) 1525 | (define-primitive (set-car! si env cell val) 1526 | (emit-binop si env val cell) 1527 | (emit-stack-to-heap si (- paircar pairtag)) 1528 | (emit " mov $0, %eax")) 1529 | (define-primitive (set-cdr! si env cell val) 1530 | (emit-binop si env val cell) 1531 | (emit-stack-to-heap si (- paircdr pairtag)) 1532 | (emit " mov $0, %eax")) 1533 | (define-primitive (eq? si env arg1 arg2) 1534 | (emit-binop si env arg1 arg2) 1535 | (emit " cmp ~s(%esp), %eax" si) 1536 | (emit-cmp-bool)) 1537 | -------------------------------------------------------------------------------- /src/cps.scm: -------------------------------------------------------------------------------- 1 | (define (cps-top expr) 2 | (T-k expr (lambda (x) x))) 3 | 4 | (define (aexpr? expr) 5 | (or (lambda? expr) 6 | (immediate? expr) 7 | (symbol? expr) 8 | (string? expr) 9 | (aexpr-primcall? expr))) 10 | 11 | (define (T-k expr k) 12 | (cond 13 | [(aexpr? expr) 14 | (k (M expr))] 15 | [(begin? expr) 16 | (let ([expr (first (begin-seq expr))] 17 | [exprs (rest (begin-seq expr))]) 18 | (if (null? exprs) 19 | (T-k expr k) 20 | (T-k expr (lambda (_) 21 | (T-k (cons 'begin exprs) k)))))] 22 | [(if? expr) 23 | (let* ([exprc (if-test expr)] 24 | [exprt (if-conseq expr)] 25 | [exprf (if-altern expr)] 26 | [$rv (unique-name '$rv)] 27 | [cont (list 'lambda (list $rv) (k $rv))]) 28 | (T-k exprc (lambda (aexp) 29 | (list 'if aexp 30 | (T-c exprt cont) 31 | (T-c exprf cont)))))] 32 | [(let? expr) 33 | (let ([vars (map lhs (let-bindings expr))] 34 | [vals (map rhs (let-bindings expr))]) 35 | (T*-k vals (lambda ($vals) 36 | (make-let 37 | 'let 38 | (map bind vars $vals) 39 | (T-k (let-body expr) k)))))] 40 | [(app? expr) 41 | (let* ([$rv (unique-name '$rv)] 42 | [cont (list 'lambda (list $rv) (k $rv))]) 43 | (T-c expr cont))] 44 | [else (error 'T-k (format "~s is not an expression" expr))])) 45 | 46 | 47 | (define (T-c expr c) 48 | (cond 49 | [(aexpr? expr) 50 | (list c (M expr))] 51 | [(begin? expr) 52 | (let ([expr (first (begin-seq expr))] 53 | [exprs (rest (begin-seq expr))]) 54 | (if (null? exprs) 55 | (T-c expr c) 56 | (T-k expr (lambda (_) 57 | (T-c (cons 'begin exprs) c)))))] 58 | [(if? expr) 59 | (let ([exprc (if-test expr)] 60 | [exprt (if-conseq expr)] 61 | [exprf (if-altern expr)] 62 | [$k (unique-name '$k)]) 63 | (list (list 'lambda (list $k) 64 | (T-k exprc (lambda (aexp) 65 | (list 'if aexp 66 | (T-c exprt $k) 67 | (T-c exprf $k))))) 68 | c))] 69 | [(let? expr) 70 | (let ([vars (map lhs (let-bindings expr))] 71 | [vals (map rhs (let-bindings expr))]) 72 | (T*-k vals (lambda ($vals) 73 | (make-let 74 | 'let 75 | (map bind vars $vals) 76 | (T-c (let-body expr) c)))))] 77 | [(app? expr) 78 | (let ([f (call-target expr)] 79 | [es (call-args expr)]) 80 | (T-k f (lambda ($f) 81 | (T*-k es (lambda ($es) 82 | (let ([app (cons $f (cons c $es))]) 83 | (if (call-apply? expr) 84 | (cons 'apply app) 85 | app)))))))] 86 | [else (error 'T-c (format "~s is not an expression" expr))])) 87 | 88 | (define (T*-k exprs k) 89 | (cond 90 | [(null? exprs) 91 | (k '())] 92 | [(pair? exprs) 93 | (T-k (car exprs) (lambda (hd) 94 | (T*-k (cdr exprs) (lambda (tl) 95 | (k (cons hd tl))))))])) 96 | 97 | (define (M aexpr) 98 | (cond 99 | [(lambda? aexpr) 100 | (let ([$k (unique-name '$k)]) 101 | (list 'lambda (cons $k (lambda-formals aexpr)) 102 | (T-c (lambda-body aexpr) $k)))] 103 | [(eq? 'call/cc aexpr) 104 | '(lambda (cc f) (f cc (lambda (_ x) (cc x))))] 105 | [else aexpr])) 106 | 107 | (set! cps-conversion 108 | (lambda (expr) 109 | (make-let 110 | 'labels 111 | (let-bindings expr) 112 | (cps-top (let-body expr))))) 113 | -------------------------------------------------------------------------------- /src/ctest.c: -------------------------------------------------------------------------------- 1 | #include "startup.h" 2 | 3 | static int global_foo = 1; 4 | 5 | char inc(char c) { 6 | return c+1; 7 | } 8 | 9 | static ptr global_fun = 1; 10 | 11 | char do_call(char c, char (*fun)(char)) { 12 | return fun(c); 13 | } 14 | 15 | char fancy(char c) { 16 | return do_call(c, &inc); 17 | } 18 | ptr scheme_entry(context* ctxt, char* stack_base, memory* mem) { 19 | char* heap = mem->heap_next; 20 | if (global_fun == 0) { 21 | global_fun = ((ptr) &inc) | closure_tag; 22 | } 23 | stack_base[-1] = 110 + global_foo; 24 | heap[0] = 'a'; 25 | heap[1] = fancy(heap[0]); 26 | heap[2] = global_fun; 27 | ptr p = 0 | (heap[0] << char_shift) | char_tag; 28 | return p; 29 | } 30 | -------------------------------------------------------------------------------- /src/ctest.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | gcc -m32 -Wall ctest.c startup.c -o test 4 | echo assembly 5 | gcc -m32 --omit-frame-pointer -S ctest.c 6 | cat -n ctest.s | expand -t 2 | sed 's/ *//' 7 | echo output 8 | ./test -------------------------------------------------------------------------------- /src/lib.scm: -------------------------------------------------------------------------------- 1 | (define-lib-primitive (length lst) 2 | (if (null? lst) 3 | 0 4 | (fxadd1 (length (cdr lst))))) 5 | 6 | (define-lib-primitive (fill args setop) 7 | (letrec ([rec (lambda (index args) 8 | (unless (null? args) 9 | (setop index (car args)) 10 | (rec (fxadd1 index) (cdr args))))]) 11 | (rec 0 args))) 12 | 13 | (define-lib-primitive (vector . args) 14 | (let ([v (make-vector (length args))]) 15 | (fill args (lambda (index arg) (vector-set! v index arg))) 16 | v)) 17 | 18 | (define-lib-primitive (string . args) 19 | (let ([s (make-string (length args))]) 20 | (fill args (lambda (index arg) (string-set! s index arg))) 21 | s)) 22 | 23 | (define-lib-primitive (list . args) 24 | args) 25 | 26 | (define-lib-primitive (make_cell value) 27 | (cons value '())) 28 | 29 | (define-lib-primitive (cell_get cell) 30 | (car cell)) 31 | 32 | (define-lib-primitive (cell_set cell value) 33 | (set-car! cell value)) 34 | 35 | (define-lib-primitive __symbols__ 36 | (make_cell '())) 37 | 38 | (define-lib-primitive (string=? s1 s2) 39 | (letrec ([rec (lambda (index) 40 | (or (fx= index (string-length s1)) 41 | (and (char= (string-ref s1 index) (string-ref s2 index)) 42 | (rec (fxadd1 index)))))]) 43 | (and (string? s1) (string? s2) (fx= (string-length s1) (string-length s2)) (rec 0)))) 44 | 45 | (define-lib-primitive (__find_symbol__ str) 46 | (letrec ([rec (lambda (symbols) 47 | (cond 48 | [(null? symbols) #f] 49 | [(string=? str (string-symbol (car symbols))) (car symbols)] 50 | [else (rec (cdr symbols))]))]) 51 | (rec (cell_get __symbols__)))) 52 | 53 | (define-lib-primitive (string->symbol str) 54 | (or (__find_symbol__ str) 55 | (let ([symbol (make-symbol str)]) 56 | (cell_set __symbols__ (cons symbol (cell_get __symbols__))) 57 | symbol))) 58 | 59 | (define-lib-primitive (error . args) 60 | (foreign-call "ik_error" args)) 61 | 62 | (define-lib-primitive (log msg) 63 | (foreign-call "ik_log" msg)) 64 | 65 | (define-lib-primitive (s_bitwise_ior x y) 66 | (foreign-call "s_bitwise_ior" x y)) 67 | 68 | (define-lib-primitive (s_ash x y) 69 | (foreign-call "s_ash" x y)) 70 | 71 | (define-lib-primitive (string-set! s i c) 72 | (cond 73 | [(not (string? s)) (error)] 74 | [(not (fixnum? i)) (error)] 75 | [(not (char? c)) (error)] 76 | [(not (and (fx<= 0 i) (fx< i (string-length s)))) (error)] 77 | [else ($string-set! s i c)])) 78 | 79 | (define-lib-primitive (string-ref s i) 80 | (cond 81 | [(not (string? s)) (error)] 82 | [(not (fixnum? i)) (error)] 83 | [(not (and (fx<= 0 i) (fx< i (string-length s)))) (error)] 84 | [else ($string-ref s i)])) 85 | 86 | (define-lib-primitive (vector-set! v i e) 87 | (cond 88 | [(not (vector? v)) (error)] 89 | [(not (fixnum? i)) (error)] 90 | [(not (and (fx<= 0 i) (fx< i (vector-length v)))) (error)] 91 | [else ($vector-set! v i e)])) 92 | 93 | (define-lib-primitive (vector-ref v i) 94 | (cond 95 | [(not (vector? v)) (error)] 96 | [(not (fixnum? i)) (error)] 97 | [(not (and (fx<= 0 i) (fx< i (vector-length v)))) (error)] 98 | [else ($vector-ref v i)])) 99 | 100 | (define-lib-primitive (liftneg f a b) 101 | (cond 102 | [(and (fx< a 0) (fx>= b 0)) 103 | (fx- 0 (f (fx- 0 a) b))] 104 | [(and (fx>= a 0) (fx< b 0)) 105 | (fx- 0 (f a (fx- 0 b)))] 106 | [(and (fx< a 0) (fx< b 0)) 107 | (f (fx- 0 a) (fx- 0 b))] 108 | [else 109 | (f a b)])) 110 | 111 | (define-lib-primitive (liftneg1 f a b) 112 | (cond 113 | [(and (fx< a 0) (fx>= b 0)) 114 | (fx- 0 (f (fx- 0 a) b))] 115 | [(and (fx>= a 0) (fx< b 0)) 116 | (f a (fx- 0 b))] 117 | [(and (fx< a 0) (fx< b 0)) 118 | (fx- 0 (f (fx- 0 a) (fx- 0 b)))] 119 | [else 120 | (f a b)])) 121 | 122 | (define-lib-primitive (fxquotient a b) 123 | (liftneg (lambda (a b) ($fxquotient a b)) a b)) 124 | 125 | (define-lib-primitive (fxremainder a b) 126 | (liftneg1 (lambda (a b) ($fxremainder a b)) a b)) 127 | 128 | (define-lib-primitive (exit . args) 129 | (let ([status (if (null? args) 0 (car args))]) 130 | (foreign-call "exit" status))) 131 | 132 | (define-lib-primitive (s_write fd str len) 133 | (foreign-call "s_write" fd str len)) 134 | 135 | (define-lib-primitive stdout 136 | (make-output-port "" 1)) 137 | 138 | (define-lib-primitive (current-output-port) 139 | stdout) 140 | 141 | (define-lib-primitive stdin 142 | (make-input-port "" 0)) 143 | 144 | (define-lib-primitive (current-input-port) 145 | stdin) 146 | 147 | (define-lib-primitive BUFFER_SIZE 4096) 148 | 149 | (define-lib-primitive (open-output-file fname . args) 150 | (let ([fd (foreign-call "s_open_write" fname)]) 151 | (make-output-port fname fd))) 152 | 153 | (define-lib-primitive (make-output-port fname fd) 154 | (vector 'output-port fname fd (make-string BUFFER_SIZE) 0 BUFFER_SIZE)) 155 | 156 | (define-lib-primitive (output-port-fname port) 157 | (vector-ref port 1)) 158 | 159 | (define-lib-primitive (output-port-fd port) 160 | (vector-ref port 2)) 161 | 162 | (define-lib-primitive (output-port-buffer port) 163 | (vector-ref port 3)) 164 | 165 | (define-lib-primitive (output-port-buffer-index port) 166 | (vector-ref port 4)) 167 | 168 | (define-lib-primitive (output-port-buffer-size port) 169 | (vector-ref port 5)) 170 | 171 | (define-lib-primitive (set-output-port-buffer-index! port index) 172 | (vector-set! port 4 index)) 173 | 174 | (define-lib-primitive (inc-output-port-buffer-index! port) 175 | (set-output-port-buffer-index! port (fxadd1 (output-port-buffer-index port)))) 176 | 177 | (define-lib-primitive (write-char c (port (current-output-port))) 178 | (string-set! (output-port-buffer port) (output-port-buffer-index port) c) 179 | (inc-output-port-buffer-index! port) 180 | (when (fx= (output-port-buffer-index port) (output-port-buffer-size port)) 181 | (output-port-write-buffer port))) 182 | 183 | (define-lib-primitive (output-port? x) 184 | (and (vector? x) (fx= (vector-length x) 6) (eq? 'output-port (vector-ref x 0)))) 185 | 186 | (define-lib-primitive (output-port-write-buffer port) 187 | (s_write (output-port-fd port) 188 | (output-port-buffer port) 189 | (output-port-buffer-index port)) 190 | (set-output-port-buffer-index! port 0)) 191 | 192 | (define-lib-primitive (flush-output-port (port (current-output-port))) 193 | (output-port-write-buffer port) 194 | (foreign-call "s_fflush" (output-port-fd port))) 195 | 196 | (define-lib-primitive (close-output-port port) 197 | (flush-output-port port) 198 | (unless (string=? "" (output-port-fname port)) 199 | (foreign-call "s_close" (output-port-fd port)))) 200 | 201 | (define-lib-primitive (system cmd) 202 | (foreign-call "s_system" cmd)) 203 | 204 | (define-lib-primitive (write x (port (current-output-port))) 205 | (flush-output-port port) 206 | ;; This is cheating... should write it in Scheme. 207 | (foreign-call "scheme_write" (output-port-fd port) x 0) 208 | (flush-output-port port)) 209 | 210 | (define-lib-primitive (display x (port (current-output-port))) 211 | (flush-output-port port) 212 | (foreign-call "scheme_write" (output-port-fd port) x 2) 213 | (flush-output-port port)) 214 | 215 | (define-lib-primitive (open-input-file fname . args) 216 | (let ([fd (foreign-call "s_open_read" fname)]) 217 | (make-input-port fname fd))) 218 | 219 | (define-lib-primitive (make-input-port fname fd) 220 | (vector 'input-port fname fd)) 221 | 222 | (define-lib-primitive (input-port-fname port) 223 | (vector-ref port 1)) 224 | 225 | (define-lib-primitive (input-port-fd port) 226 | (vector-ref port 2)) 227 | 228 | (define-lib-primitive (input-port? x) 229 | (and (vector? x) (fx= (vector-length x) 3) (eq? 'input-port (vector-ref x 0)))) 230 | 231 | (define-lib-primitive (read-char port) 232 | (foreign-call "s_read_char" (input-port-fd port))) 233 | 234 | (define-lib-primitive (close-input-port port) 235 | (foreign-call "s_close" (input-port-fd port))) 236 | -------------------------------------------------------------------------------- /src/reader.scm: -------------------------------------------------------------------------------- 1 | ;; from https://www.cs.rpi.edu/academics/courses/fall00/ai/scheme/reference/schintro-v14/schintro_115.html#SEC137 2 | 3 | (define peeks '()) 4 | 5 | (define (assq k m) 6 | (if (null? m) 7 | #f 8 | (if (eq? k (car (car m))) 9 | (car m) 10 | (assq k (cdr m))))) 11 | 12 | (define (del-assq k m) 13 | (if (null? m) 14 | m 15 | (if (eq? k (car (car m))) 16 | (cdr m) 17 | (cons (car m) (del-assq k (cdr m)))))) 18 | 19 | (define (read1-char port) 20 | (let ((pc (assq port peeks))) 21 | (if pc 22 | (begin 23 | (set! peeks (del-assq port peeks)) 24 | (cdr pc)) 25 | (read-char port)))) 26 | 27 | (define (peek-char port) 28 | (let ((c (read1-char port))) 29 | (set! peeks (cons (cons port c) peeks)) 30 | c)) 31 | 32 | (define (char-numeric? c) 33 | (and (<= (char->fixnum #\0) (char->fixnum c)) 34 | (<= (char->fixnum c) (char->fixnum #\9)))) 35 | 36 | (define (char-alphabetic? c) 37 | (or 38 | (and (<= (char->fixnum #\A) (char->fixnum c)) 39 | (<= (char->fixnum c) (char->fixnum #\z))) 40 | (eq? #\+ c) 41 | (eq? #\- c) 42 | (eq? #\* c) 43 | (eq? #\? c) 44 | (eq? #\! c) 45 | (eq? #\> c) 46 | (eq? #\< c) 47 | (eq? #\= c) 48 | (eq? #\. c))) 49 | 50 | (define (list->string xs) 51 | (apply string xs)) 52 | 53 | (define (list->vector xs) 54 | (apply vector xs)) 55 | 56 | (define (list->number xs (neg #f)) 57 | (define (iter xs r) 58 | (if (null? xs) 59 | r 60 | (iter (cdr xs) 61 | (+ ((if neg - +) 62 | 0 63 | (- (char->fixnum (car xs)) (char->fixnum #\0))) 64 | (* 10 r))))) 65 | (iter xs 0)) 66 | 67 | (define (read-token port) 68 | (let ((first-char (read1-char port))) 69 | (cond ((eof-object? first-char) 70 | first-char) 71 | ((char-whitespace? first-char) 72 | (read-token port)) 73 | ((or (eq? first-char #\( ) (eq? first-char #\[ )) 74 | left-paren-token) 75 | ((or (eq? first-char #\)) (eq? first-char #\] )) 76 | right-paren-token) 77 | ((and (eq? first-char #\.) (char-whitespace? (peek-char port))) 78 | dot-token) 79 | ((eq? first-char #\-) 80 | (let ((next-char (peek-char port))) 81 | (if (char-numeric? next-char) 82 | (read-number #t (read1-char port) port) 83 | (read-identifier first-char port)))) 84 | ((char-alphabetic? first-char) 85 | (read-identifier first-char port)) 86 | ((char-numeric? first-char) 87 | (read-number #f first-char port)) 88 | ((eq? #\" first-char) 89 | (read-string first-char port)) 90 | ((eq? #\' first-char) 91 | (list 'quote (read port))) 92 | ((eq? first-char #\#) 93 | (read-character first-char port)) 94 | ((eq? first-char #\;) 95 | (read-comment first-char port) 96 | (read-token port)) 97 | (else 98 | (error 'read-token (format "illegal lexical syntax: ~s" first-char)))))) 99 | 100 | (define (char-whitespace? char) 101 | (or (eq? char #\space) 102 | (eq? char #\newline) 103 | (eq? char #\tab) 104 | (eq? char #\return))) 105 | 106 | (define left-paren-token (list '*left-paren-token*)) 107 | (define right-paren-token (list '*right-paren-token*)) 108 | (define dot-token (list '*dot-token*)) 109 | (define (token-leftpar? thing) 110 | (eq? thing left-paren-token)) 111 | (define (token-rightpar? thing) 112 | (eq? thing right-paren-token)) 113 | (define (token-dot? thing) 114 | (eq? thing dot-token)) 115 | 116 | (define (read-string chr port) 117 | (define (helper list-so-far) 118 | (let ((next-char (read1-char port))) 119 | (if (eq? #\\ next-char) 120 | (helper (cons (read1-char port) list-so-far)) 121 | (if (eq? #\" next-char) 122 | (list->string (reverse list-so-far)) 123 | (helper (cons next-char list-so-far)))))) 124 | (helper '())) 125 | 126 | (define (read-character chr port) 127 | (let ((next-char (read1-char port))) 128 | (if (eq? next-char #\\) 129 | (let ((first-char (read1-char port))) 130 | (let ((s (read-identifier first-char port))) 131 | (cond ((eq? s 'space) #\space) 132 | ((eq? s 'newline) #\newline) 133 | ((eq? s 'tab) #\tab) 134 | ((eq? s 'return) #\return) 135 | (else first-char)))) 136 | (if (eq? next-char #\t) 137 | #t 138 | (if (eq? next-char #\f) 139 | #f 140 | (if (eq? next-char #\() 141 | (list->vector (read-list '() port)) 142 | (error 'read-character "expected bool, char or vector"))))))) 143 | 144 | (define (read-identifier chr port) 145 | (define (read-identifier-helper list-so-far) 146 | (let ((next-char (peek-char port))) 147 | (if (or (char-alphabetic? next-char) 148 | (char-numeric? next-char)) 149 | (read-identifier-helper (cons (read1-char port) list-so-far)) 150 | (reverse list-so-far)))) 151 | (string->symbol (list->string (read-identifier-helper (list chr))))) 152 | 153 | (define (read-number neg chr port) 154 | (define (read-number-helper list-so-far) 155 | (let ((next-char (peek-char port))) 156 | (if (char-numeric? next-char) 157 | (read-number-helper (cons (read1-char port) list-so-far)) 158 | (reverse list-so-far)))) 159 | (list->number (read-number-helper (list chr)) neg)) 160 | 161 | (define (read-comment chr port) 162 | (define (slurp-line port) 163 | (let ((next-char (read1-char port))) 164 | (if (eq? next-char #\newline) 165 | #t 166 | (slurp-line port)))) 167 | (let ((next-char (read1-char port))) 168 | (if (eq? next-char chr) 169 | (slurp-line port) 170 | (error 'read-comment "expected a comment")))) 171 | 172 | (define (read port) 173 | (let ((next-token (read-token port))) 174 | (cond ((token-leftpar? next-token) 175 | (read-list '() port)) 176 | (else 177 | next-token)))) 178 | (define (read-list list-so-far port) 179 | (let ((token (read-token port))) 180 | (cond ((token-rightpar? token) 181 | (reverse list-so-far)) 182 | ((token-leftpar? token) 183 | (read-list (cons (read-list '() port) list-so-far) port)) 184 | ((token-dot? token) 185 | (let* ((rest (read-token port)) 186 | (r (read-token port))) 187 | (if (token-rightpar? r) 188 | (append (reverse list-so-far) rest) 189 | (error (format "unexpected dotted list ~s ~s" rest r))))) 190 | (else 191 | (read-list (cons token list-so-far) port))))) 192 | -------------------------------------------------------------------------------- /src/repl.scm: -------------------------------------------------------------------------------- 1 | (load "compiler.scm") 2 | 3 | (compile-program 4 | '(let () 5 | (load "self.scm") 6 | (load "reader.scm") 7 | (load "compiler.scm") 8 | (let loop ((expr (read (current-input-port)))) 9 | (if (eof-object? expr) 10 | 'Ok 11 | (begin 12 | (display (run expr "boot.out")) 13 | (loop (read (current-input-port)))))))) 14 | -------------------------------------------------------------------------------- /src/runtime-rust/Cargo.toml: -------------------------------------------------------------------------------- 1 | [package] 2 | name = "runtime-rust" 3 | version = "0.1.0" 4 | authors = ["Nada Amin "] 5 | 6 | [dependencies] 7 | 8 | [build-dependencies] 9 | cc = "1.0" 10 | bindgen = "0.42.2" 11 | -------------------------------------------------------------------------------- /src/runtime-rust/README.md: -------------------------------------------------------------------------------- 1 | # runtime-rust 2 | 3 | A rewrite of `startup.c` in Rust, as an exercise in learning Rust. 4 | 5 | All the tests pass. 6 | 7 | In Scheme, from `..`: 8 | ``` 9 | (load "compiler.scm") 10 | (load "runtime-rust/tests-driver-modif.scm")` 11 | (test-al)``` 12 | 13 | See `runtime-rust/tests-driver-modif.scm` for how to build and run. 14 | -------------------------------------------------------------------------------- /src/runtime-rust/bindings.h: -------------------------------------------------------------------------------- 1 | #include "../startup.h" 2 | #include "../scheme_entry.h" 3 | -------------------------------------------------------------------------------- /src/runtime-rust/build.rs: -------------------------------------------------------------------------------- 1 | extern crate cc; 2 | extern crate bindgen; 3 | 4 | fn main() { 5 | cc::Build::new() 6 | .file("../lib.s") 7 | .file("../stst.s") 8 | .compile("scheme-entry-lib"); 9 | 10 | let bindings = bindgen::Builder::default() 11 | .header("bindings.h") 12 | .generate() 13 | .expect("Unable to generate bindings"); 14 | bindings 15 | .write_to_file("src/bindings.rs") 16 | .expect("Couldn't write bindings!"); 17 | } 18 | -------------------------------------------------------------------------------- /src/runtime-rust/src/main.rs: -------------------------------------------------------------------------------- 1 | #![allow(non_upper_case_globals)] 2 | #![allow(non_camel_case_types)] 3 | #![allow(non_snake_case)] 4 | 5 | #![allow(unused_must_use)] 6 | #![allow(unused_variables)] 7 | 8 | include!("bindings.rs"); 9 | 10 | use std::os::raw::c_char; 11 | use std::io::Write; 12 | use std::os::unix::io::FromRawFd; 13 | use std::os::unix::io::IntoRawFd; 14 | use std::io::Read; 15 | 16 | #[derive(PartialEq)] 17 | enum PrintState { 18 | OUT, 19 | IN, 20 | DISPLAY 21 | } 22 | 23 | fn print_ptr_rec(port: &mut W, p: ptr, state: PrintState) { 24 | let x = p as u32; 25 | if (x & fx_mask) == fx_tag { 26 | write!(port, "{}", (x as i32) >> fx_shift); 27 | } else if x == bool_f { 28 | write!(port, "#f"); 29 | } else if x == bool_t { 30 | write!(port, "#t"); 31 | } else if x == list_nil { 32 | write!(port, "()"); 33 | } else if x == eof_obj { 34 | write!(port, "#!eof"); 35 | } else if (x & char_mask) == char_tag { 36 | let c = std::char::from_u32(x >> char_shift). 37 | expect("a char"); 38 | if state == PrintState::DISPLAY { 39 | write!(port, "{}", c); 40 | } else { 41 | if c == '\t' { write!(port, "#\\tab"); } 42 | else if c == '\n' { write!(port, "#\\newline"); } 43 | else if c == '\r' { write!(port, "#\\return"); } 44 | else if c == ' ' { write!(port, "#\\space"); } 45 | else { write!(port, "#\\{}", c); } 46 | } 47 | } else if (x & obj_mask) == pair_tag { 48 | if state == PrintState::OUT { write!(port, "("); } 49 | let cell = unsafe { *((x-pair_tag) as *const cell) }; 50 | let car = cell.car; 51 | print_ptr_rec(port, car, PrintState::OUT); 52 | let cdr = cell.cdr; 53 | if cdr != list_nil { 54 | if (cdr & obj_mask) != pair_tag { 55 | write!(port, " . "); 56 | print_ptr_rec(port, cdr, PrintState::OUT); 57 | } else { 58 | write!(port, " "); 59 | print_ptr_rec(port, cdr, PrintState::IN); 60 | } 61 | } 62 | if state == PrintState::OUT { write!(port, ")"); } 63 | } else if (x & obj_mask) == vector_tag { 64 | write!(port, "#("); 65 | unsafe { 66 | let p = &*((x-vector_tag) as *const vector); 67 | let n = (p.length as i32) >> fx_shift; 68 | for i in 0..n { 69 | if i > 0 { write!(port, " "); } 70 | print_ptr_rec(port, 71 | *((p.buf.as_ptr()).add(i as usize)), 72 | PrintState::OUT) 73 | }} 74 | write!(port, ")"); 75 | } else if (x & obj_mask) == string_tag { 76 | if state == PrintState::OUT { write!(port, "\""); } 77 | unsafe { 78 | let p = &*((x-string_tag) as *const string); 79 | let n = (p.length as i32) >> fx_shift; 80 | for i in 0..n { 81 | let c = std::char::from_u32(*((p.buf.as_ptr()).add(i as usize)) as u32) 82 | .expect("char"); 83 | if c == '"' { write!(port, "\\\""); } 84 | else if c == '\\' { write!(port, "\\\\"); } 85 | else { write!(port, "{}", c); } 86 | }} 87 | if state == PrintState::OUT { write!(port, "\""); } 88 | } else if (x & obj_mask) == symbol_tag { 89 | print_ptr_rec(port, (x - symbol_tag) | string_tag, PrintState::IN); 90 | } else if (x & obj_mask) == closure_tag { 91 | write!(port, "#"); 92 | } else { 93 | write!(port, "#", x); 94 | } 95 | } 96 | fn print_ptr(x: ptr) { 97 | print_ptr_rec(&mut std::io::stdout(), x, PrintState::OUT); 98 | println!(); 99 | } 100 | 101 | fn eprint_ptr(msg: ptr, state: PrintState) { 102 | print_ptr_rec(&mut std::io::stderr(), msg, state); 103 | } 104 | 105 | #[no_mangle] 106 | pub extern "C" fn ik_log(msg: ptr) -> ptr { 107 | eprint!("log: "); 108 | eprint_ptr(msg, PrintState::IN); 109 | eprintln!(); 110 | 0 111 | } 112 | #[no_mangle] 113 | pub extern "C" fn ik_error(x: ptr) { 114 | eprint!("Exception"); 115 | if (x & obj_mask) == pair_tag { 116 | let cell = unsafe { *((x-pair_tag) as *const cell) }; 117 | let caller = cell.car; 118 | let msg = cell.cdr; 119 | if caller != bool_f { 120 | eprint!(" in "); 121 | eprint_ptr(caller, PrintState::OUT); 122 | } 123 | eprint!(": "); 124 | eprint_ptr(msg, PrintState::IN); 125 | } 126 | eprintln!(); 127 | std::process::exit(0); 128 | } 129 | 130 | fn unshift(x: ptr) -> i32 { 131 | (x as i32) >> fx_shift 132 | } 133 | fn shift(x: i32) -> ptr { 134 | (x << fx_shift) as u32 135 | } 136 | fn ptr_string_to_str(x: ptr) -> String { 137 | unsafe { 138 | let p = &*((x-string_tag) as *const string); 139 | let n = unshift(p.length) as usize; 140 | let mut v = Vec::with_capacity(n); 141 | for i in 0..n { 142 | v.push(*(p.buf.as_ptr().add(i as usize)) as u8); 143 | } 144 | std::ffi::CString::from_vec_unchecked(v).into_string().expect("string") 145 | } 146 | } 147 | #[no_mangle] 148 | pub extern "C" fn s_write(fd: ptr, str: ptr, len: ptr) -> ptr { 149 | let s = ptr_string_to_str(str); 150 | let len = unshift(len) as usize; 151 | let s: String = s.chars().take(len).collect(); 152 | let ufd = unshift(fd) as i32; 153 | let mut w = unsafe { std::fs::File::from_raw_fd(ufd) }; 154 | write!(w, "{}", s); 155 | w.flush(); 156 | w.into_raw_fd(); 157 | shift(s.len() as i32) 158 | } 159 | #[no_mangle] 160 | pub extern "C" fn s_open_write(fname: ptr) -> ptr { 161 | let s_fname = ptr_string_to_str(fname); 162 | let port = std::fs::File::create(s_fname).expect("created"); 163 | let fd = port.into_raw_fd(); 164 | shift(fd) 165 | } 166 | #[no_mangle] 167 | pub extern "C" fn s_fflush(fd: ptr) -> ptr { 168 | let ufd = unshift(fd) as i32; 169 | let mut w = unsafe { std::fs::File::from_raw_fd(ufd) }; 170 | w.flush(); 171 | w.into_raw_fd(); 172 | 0 173 | } 174 | #[no_mangle] 175 | pub extern "C" fn scheme_write(fd: ptr, x: ptr, opt: ptr) -> ptr { 176 | let ufd = unshift(fd) as i32; 177 | let state = unshift(opt); 178 | let state = 179 | if state == 0 { PrintState::OUT } 180 | else if state == 1 { PrintState::IN } 181 | else { PrintState :: DISPLAY }; 182 | let mut w = unsafe { std::fs::File::from_raw_fd(ufd) }; 183 | print_ptr_rec(&mut w, x, state); 184 | w.flush(); 185 | w.into_raw_fd(); 186 | 0 187 | } 188 | #[no_mangle] 189 | pub extern "C" fn s_open_read(fname: ptr) -> ptr { 190 | let s_fname = ptr_string_to_str(fname); 191 | let port = std::fs::File::open(s_fname).expect("opened"); 192 | let fd = port.into_raw_fd(); 193 | shift(fd) 194 | } 195 | #[no_mangle] 196 | pub extern "C" fn s_read_char(fd: ptr) -> ptr { 197 | let ufd = unshift(fd) as i32; 198 | let mut w = unsafe { std::fs::File::from_raw_fd(ufd) }; 199 | let mut b = [0; 1]; 200 | w.read_exact(&mut b); 201 | let v = if b[0] == 0 { eof_obj } 202 | else { ((b[0] as u32) << char_shift) | char_tag }; 203 | w.into_raw_fd(); 204 | v 205 | } 206 | #[no_mangle] 207 | pub extern "C" fn s_close(fd: ptr) -> ptr { 208 | let ufd = unshift(fd) as i32; 209 | let w = unsafe { std::fs::File::from_raw_fd(ufd) }; 210 | std::mem::drop(w); 211 | shift(0) 212 | } 213 | 214 | fn gc_align(n: usize) -> usize { 215 | let cell = 1 << obj_shift; 216 | (((n + cell - 1)/cell) * cell) as usize 217 | } 218 | 219 | fn gc_ptr_object(x: ptr) -> bool { 220 | let tag = x & obj_mask; 221 | match tag { 222 | pair_tag | 223 | vector_tag | 224 | symbol_tag | 225 | string_tag | 226 | closure_tag => true, 227 | _ => false 228 | } 229 | } 230 | fn gc_size(x: ptr) -> usize { 231 | let tag = x & obj_mask; 232 | let p = x-tag; 233 | match tag { 234 | pair_tag => 2 << word_shift, 235 | vector_tag => { 236 | let n = (unshift(unsafe{(&*(p as *const vector)).length}) as u32) + 1; 237 | (n as usize) << word_shift 238 | }, 239 | symbol_tag | string_tag => 240 | ((unshift(unsafe{(&*(p as *const string)).length}) as u32) + word_size) as usize, 241 | closure_tag => { 242 | let n = (unshift(unsafe{(&*(p as *const closure)).length}) as u32) + 2; 243 | (n as usize) << word_shift 244 | }, 245 | _ => 0 246 | } 247 | } 248 | 249 | 250 | static mut gc_new_heap_base: *mut c_char = 0 as *mut c_char; 251 | static mut gc_new_heap_top: *mut c_char = 0 as *mut c_char; 252 | static mut gc_next: *mut c_char = 0 as *mut c_char; 253 | static mut gc_queue: *mut ptr = 0 as *mut ptr; 254 | 255 | fn gc_get_forward_pointer(p: *mut c_char) -> *mut c_char { 256 | let x = unsafe{*p as ptr}; 257 | if x != gc_forward_mark { return 0 as *mut c_char; } 258 | let q = unsafe{*((p as *mut ptr).add(1)) as *mut c_char}; 259 | q 260 | } 261 | 262 | fn gc_set_forward_pointer(p: *mut c_char, q: *mut c_char) { 263 | unsafe { 264 | *p = gc_forward_mark as c_char; 265 | *((p as *mut ptr).add(1)) = q as ptr; 266 | } 267 | } 268 | 269 | fn gc_forward(x: ptr) -> ptr { 270 | if !gc_ptr_object(x) { 271 | return x; 272 | } 273 | 274 | let tag = x & obj_mask; 275 | let p = (x-tag) as *mut c_char; 276 | let mut q = gc_get_forward_pointer(p); 277 | if q != (0 as *mut c_char) { 278 | return (q as ptr) | tag; 279 | } 280 | 281 | unsafe { 282 | q = gc_next; 283 | let n = gc_size(x); 284 | for i in 0..n { 285 | *gc_next.add(i) = *p.add(i); 286 | } 287 | gc_next = gc_next.add(gc_align(n)); 288 | gc_set_forward_pointer(p, q); 289 | let f = ((q as ptr) | tag) as ptr; 290 | *gc_queue = f; 291 | gc_queue = gc_queue.add(1); 292 | f 293 | } 294 | } 295 | 296 | fn gc_clean_new() { 297 | let mut p = unsafe { gc_new_heap_base }; 298 | while unsafe { p < gc_new_heap_top } { 299 | unsafe { *p = 0 as c_char }; 300 | p = unsafe { p.add(1) }; 301 | } 302 | } 303 | 304 | fn gc(mem: *mut memory, stack: *mut c_char) { 305 | unsafe { 306 | gc_new_heap_base = (*mem).heap_base_alt as *mut c_char; 307 | gc_new_heap_top = (*mem).heap_top_alt as *mut c_char; 308 | gc_clean_new(); 309 | 310 | gc_next = (*mem).heap_base_alt as *mut c_char; 311 | gc_queue = (*mem).scratch_base as *mut ptr; 312 | } 313 | 314 | let mut scan = unsafe{gc_queue}; 315 | let mut root = unsafe{*mem}.global_base as *mut ptr; 316 | while unsafe { (root as *mut c_char) < (*mem).global_next } { 317 | unsafe { 318 | *root = gc_forward(*root); 319 | root = root.add(1); 320 | } 321 | } 322 | 323 | root = unsafe{*mem}.stack_base as *mut ptr; 324 | unsafe { 325 | root = root.offset(-1); 326 | root = root.offset(-1); 327 | while root >= (stack as *mut ptr) { 328 | if *root == return_addr { 329 | root = root.offset(-1); 330 | } else { 331 | *root = gc_forward(*root); 332 | } 333 | root = root.offset(-1); 334 | } 335 | } 336 | 337 | unsafe { 338 | (*mem).edi = gc_forward((*mem).edi); 339 | } 340 | 341 | while scan < unsafe{gc_queue} { 342 | let x = unsafe { *scan }; 343 | scan = unsafe { scan.add(1) }; 344 | let tag = x & obj_mask; 345 | 346 | if tag == pair_tag { 347 | unsafe { 348 | let p = (x-tag) as *mut cell; 349 | (*p).car = gc_forward((*p).car); 350 | (*p).cdr = gc_forward((*p).cdr); 351 | } 352 | } else if tag == vector_tag { 353 | unsafe { 354 | let p = (x-tag) as *mut vector; 355 | let len = unshift((*p).length) as usize; 356 | let b = (*p).buf.as_mut_ptr(); 357 | for i in 0..len { 358 | *(b.add(i)) = gc_forward(*(b.add(i))); 359 | } 360 | } 361 | } else if tag == closure_tag { 362 | unsafe { 363 | let p = (x-tag) as *mut closure; 364 | let len = unshift((*p).length) as usize; 365 | let b = (*p).fvs.as_mut_ptr(); 366 | for i in 0..len { 367 | *(b.add(i)) = gc_forward(*(b.add(i))); 368 | } 369 | } 370 | } 371 | 372 | } 373 | 374 | unsafe { 375 | (*mem).heap_next = gc_next; 376 | (*mem).heap_base_alt = (*mem).heap_base; 377 | (*mem).heap_top_alt = (*mem).heap_top; 378 | (*mem).heap_base = gc_new_heap_base; 379 | (*mem).heap_top = gc_new_heap_top; 380 | } 381 | } 382 | 383 | #[no_mangle] 384 | pub extern "C" fn heap_alloc(mem: *mut memory, stack: *mut c_char, size: usize) -> *mut c_char { 385 | let mut heap_next = unsafe {*mem}.heap_next; 386 | let mut heap_new = unsafe { heap_next.add(size) }; 387 | if unsafe { heap_new >= (*mem).heap_top } { 388 | gc(mem, stack); 389 | heap_next = unsafe{*mem}.heap_next; 390 | heap_new = unsafe { heap_next.add(size) }; 391 | if unsafe { heap_new >= (*mem).heap_top } { 392 | eprintln!("Exception: overflow"); 393 | std::process::exit(0); 394 | } 395 | } 396 | unsafe {(*mem).heap_next = heap_new}; 397 | return heap_next; 398 | } 399 | 400 | fn allocate_protected_space(size: usize) -> *mut c_char { 401 | let mut v = Vec::with_capacity(size); 402 | let ptr = v.as_mut_ptr(); 403 | std::mem::forget(v); 404 | ptr 405 | } 406 | 407 | fn deallocate_protected_space(p: *mut c_char, size: usize) { 408 | unsafe { std::mem::drop(Vec::from_raw_parts(p, 0, size)) }; 409 | } 410 | 411 | fn main() { 412 | let stack_size = 16 * 4096; 413 | let heap_size = 4 * 16 * 4096; 414 | let global_size = 16 * 4096; 415 | let scratch_size = 16 * 4096; 416 | 417 | let stack_top = allocate_protected_space(stack_size); 418 | let stack_base = unsafe { stack_top.add(stack_size) }; 419 | 420 | let heap = allocate_protected_space(heap_size); 421 | let global = allocate_protected_space(global_size); 422 | let scratch = allocate_protected_space(scratch_size); 423 | 424 | let uninit = 0 as (*mut std::os::raw::c_void); 425 | 426 | let mut ctxt = context { 427 | eax : uninit, 428 | ebx : uninit, 429 | ecx : uninit, 430 | edx : uninit, 431 | esi : uninit, 432 | edi : uninit, 433 | ebp : uninit, 434 | esp : uninit, 435 | }; 436 | 437 | let heap_top = unsafe { heap.add(heap_size/2) }; 438 | let mut mem = memory { 439 | heap_next : heap, 440 | global_next : global, 441 | heap_base : heap, 442 | heap_top : heap_top, 443 | heap_base_alt : heap_top, 444 | heap_top_alt : unsafe { heap.add(heap_size) }, 445 | global_base : global, 446 | stack_base : stack_base, 447 | scratch_base : scratch, 448 | edi : 0 449 | }; 450 | 451 | 452 | let r = unsafe { 453 | scheme_entry(&mut ctxt, stack_base, &mut mem) 454 | }; 455 | print_ptr(r); 456 | 457 | deallocate_protected_space(stack_top, stack_size); 458 | deallocate_protected_space(heap, stack_size); 459 | } 460 | -------------------------------------------------------------------------------- /src/runtime-rust/tests-driver-modif.scm: -------------------------------------------------------------------------------- 1 | (define (build) 2 | (unless (zero? (system "rm ./runtime-rust/target/i686-unknown-linux-gnu/debug/runtime-rust; cd runtime-rust; cargo build --target i686-unknown-linux-gnu --quiet; cd ..")) 3 | (error 'make "Could not build target."))) 4 | 5 | (define (execute) 6 | (unless (zero? (system "./runtime-rust/target/i686-unknown-linux-gnu/debug/runtime-rust >stst.out")) 7 | (error 'make "Produced program exited abnormally."))) 8 | -------------------------------------------------------------------------------- /src/scheme_entry.h: -------------------------------------------------------------------------------- 1 | extern ptr scheme_entry(context* ctxt, char* stack_base, memory* mem); 2 | -------------------------------------------------------------------------------- /src/self.scm: -------------------------------------------------------------------------------- 1 | (define (cadr x) (car (cdr x))) 2 | (define (caddr x) (car (cdr (cdr x)))) 3 | (define (cadddr x) (car (cdr (cdr (cdr x))))) 4 | (define (cddr x) (cdr (cdr x))) 5 | (define (cdddr x) (cdr (cdr (cdr x)))) 6 | (define (cadadr x) (car (cdr (car (cdr x))))) 7 | 8 | (define props '()) 9 | 10 | (define (putprop s k v) 11 | (set! props (cons (cons (cons s k) v) props))) 12 | 13 | (define (getprop s k) 14 | (let ((p (assoc (cons s k) props))) 15 | (and p (cdr p)))) 16 | 17 | (define (fprintf port format . args) 18 | (let loop ((i 0) (args args)) 19 | (if (fx>= i (string-length format)) 20 | 'done 21 | (let ((c (string-ref format i))) 22 | (if (eq? c #\~) 23 | (begin 24 | (display (car args) port) 25 | (loop (+ i 2) (cdr args))) 26 | (begin 27 | (display c port) 28 | (loop (+ i 1) args))))))) 29 | (define (printf format . args) 30 | (apply fprintf (current-output-port) format args)) 31 | 32 | (define (newline (port (current-output-port))) 33 | (display "\n" port)) 34 | 35 | (define (assert x) 36 | (unless x 37 | (error 'assert "assertion failed"))) 38 | 39 | (define (reverse xs) 40 | (define (iter xs acc) 41 | (if (null? xs) 42 | acc 43 | (iter (cdr xs) (cons (car xs) acc)))) 44 | (iter xs '())) 45 | 46 | (define (append1 xs ys) 47 | (if (not (pair? xs)) 48 | ys 49 | (cons (car xs) (append1 (cdr xs) ys)))) 50 | 51 | (define (append . zss) 52 | (if (null? zss) 53 | '() 54 | (if (null? (cdr zss)) 55 | (car zss) 56 | (append1 (car zss) (apply append (cdr zss)))))) 57 | 58 | (define (list? xs) 59 | (or (null? xs) (and (pair? xs) (list? (cdr xs))))) 60 | 61 | (define (map1 f xs) 62 | (if (null? xs) 63 | '() 64 | (cons (f (car xs)) (map1 f (cdr xs))))) 65 | 66 | (define (map f . xss) 67 | (if (null? (car xss)) 68 | '() 69 | (cons (apply f (map1 car xss)) (apply map f (map1 cdr xss))))) 70 | 71 | (define (filter p xs) 72 | (if (null? xs) 73 | '() 74 | (if (p (car xs)) 75 | (cons (car xs) (filter p (cdr xs))) 76 | (filter p (cdr xs))))) 77 | 78 | (define (for-each f . xss) 79 | (if (null? (car xss)) 80 | 'done 81 | (begin 82 | (apply f (map1 car xss)) 83 | (apply for-each f (map1 cdr xss))))) 84 | 85 | (define (equal? x y) 86 | (or (eq? x y) 87 | (cond 88 | ((pair? x) 89 | (and (pair? y) 90 | (equal? (car x) (car y)) 91 | (equal? (cdr x) (cdr y)))) 92 | ((string? x) 93 | (and (string? y) 94 | (string=? x y))) 95 | (else #f)))) 96 | 97 | (define (member x xs) 98 | (if (null? xs) 99 | #f 100 | (if (equal? x (car xs)) 101 | xs 102 | (member x (cdr xs))))) 103 | 104 | (define (assoc k m) 105 | (if (null? m) 106 | #f 107 | (if (equal? k (car (car m))) 108 | (car m) 109 | (assoc k (cdr m))))) 110 | 111 | (define (string->list s) 112 | (let loop ((i 0)) 113 | (if (fx>= i (string-length s)) 114 | '() 115 | (cons (string-ref s i) (loop (fxadd1 i)))))) 116 | 117 | (define (vector->list s) 118 | (let loop ((i 0)) 119 | (if (fx>= i (vector-length s)) 120 | '() 121 | (cons (vector-ref s i) (loop (fxadd1 i)))))) 122 | 123 | (define (string-append . args) 124 | (list->string (apply append (map string->list args)))) 125 | 126 | (define (substring s a b) 127 | (let ((r (make-string (- b a)))) 128 | (let loop ((i 0)) 129 | (if (= (fx+ a i) b) 130 | r 131 | (begin 132 | (string-set! r i (string-ref s (fx+ a i))) 133 | (loop (+ 1 i))))))) 134 | (define (to-string x) 135 | (cond 136 | ((symbol? x) 137 | (symbol->string x)) 138 | ((char? x) 139 | (string x)) 140 | ((string? x) 141 | x) 142 | ((number? x) 143 | (number->string x)) 144 | (else "TODO"))) 145 | 146 | (define (format x . args) 147 | (apply string-append (cons x (map to-string args)))) 148 | 149 | (define (ash x y) 150 | (s_ash x y)) 151 | (define (bitwise-ior x y) 152 | (s_bitwise_ior x y)) 153 | (define (expt b n) 154 | (if (fx= n 0) 155 | 1 156 | (* b (expt b (fxsub1 n))))) 157 | (define (make-parameter p f) 158 | (let ((r (f p))) 159 | (lambda () r))) 160 | (define (void) 161 | 0) 162 | 163 | (define (add1 x) (fxadd1 x)) 164 | (define (sub1 x) (fxsub1 x)) 165 | (define (+ x y) (fx+ x y)) 166 | (define (- . args) 167 | (if (null? (cdr args)) 168 | (fx- 0 (car args)) 169 | (if (null? (cdr (cdr args))) 170 | (fx- (car args) (cadr args)) 171 | (error 'fx- "one or two arguments expected")))) 172 | (define * fx*) 173 | (define div fxquotient) 174 | (define < fx<) 175 | (define <= fx<=) 176 | (define >= fx>=) 177 | (define > fx>) 178 | (define = fx=) 179 | (define number? fixnum?) 180 | (define integer? fixnum?) 181 | (define exact? fixnum?) 182 | (define zero? fxzero?) 183 | (define symbol->string string-symbol) 184 | (define char->integer char->fixnum) 185 | (define assv assoc) 186 | 187 | (define (number->string n) 188 | (define (iter n acc) 189 | (if (= n 0) 190 | (if (null? acc) 191 | "0" 192 | (list->string acc)) 193 | (iter (fxquotient n 10) (cons (fixnum->char (+ (char->fixnum #\0) (fxremainder n 10))) acc)))) 194 | (iter n '())) 195 | -------------------------------------------------------------------------------- /src/startup.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | #include "startup.h" 9 | #include "scheme_entry.h" 10 | 11 | #define DISPLAY 2 12 | #define IN 1 13 | #define OUT 0 14 | 15 | #define FILENAME_MAX_LENGTH 100 16 | #define CMD_MAX_LENGTH 100 17 | 18 | static void print_ptr_rec(FILE* port, ptr x, int state) { 19 | if ((x & fx_mask) == fx_tag) { 20 | fprintf(port, "%d", ((int) x) >> fx_shift); 21 | } else if (x == bool_f) { 22 | fprintf(port, "#f"); 23 | } else if (x == bool_t) { 24 | fprintf(port, "#t"); 25 | } else if (x == list_nil) { 26 | fprintf(port, "()"); 27 | } else if (x == eof_obj) { 28 | fprintf(port, "#!eof"); 29 | } else if ((x & char_mask) == char_tag) { 30 | char c = (char) (x >> char_shift); 31 | if (state == DISPLAY) { 32 | fputc(c, port); 33 | } else { 34 | if (c == '\t') fprintf(port, "#\\tab"); 35 | else if (c == '\n') fprintf(port, "#\\newline"); 36 | else if (c == '\r') fprintf(port, "#\\return"); 37 | else if (c == ' ') fprintf(port, "#\\space"); 38 | else fprintf(port, "#\\%c", c); 39 | } 40 | } else if ((x & obj_mask) == pair_tag) { 41 | if (state == OUT) fprintf(port, "("); 42 | ptr car = ((cell*)(x-pair_tag))->car; 43 | print_ptr_rec(port, car, OUT); 44 | ptr cdr = ((cell*)(x-pair_tag))->cdr; 45 | if (cdr != list_nil) { 46 | if ((cdr & obj_mask) != pair_tag) { 47 | fprintf(port, " . "); 48 | print_ptr_rec(port, cdr, OUT); 49 | } else { 50 | fprintf(port, " "); 51 | print_ptr_rec(port, cdr, IN); 52 | } 53 | } 54 | if (state == OUT) fprintf(port, ")"); 55 | } else if ((x & obj_mask) == vector_tag) { 56 | fprintf(port, "#("); 57 | 58 | vector* p = (vector*)(x-vector_tag); 59 | unsigned int n = p->length >> fx_shift; 60 | unsigned int i; 61 | for (i = 0; i < n; i++) { 62 | if (i > 0) fprintf(port, " "); 63 | print_ptr_rec(port, p->buf[i], OUT); 64 | } 65 | 66 | fprintf(port, ")"); 67 | } else if ((x & obj_mask) == string_tag) { 68 | int q = state != DISPLAY; 69 | if (q) fprintf(port, "\""); 70 | 71 | string* p = (string*)(x-string_tag); 72 | unsigned int n = p->length >> fx_shift; 73 | unsigned int i; 74 | for (i = 0; i < n; i++) { 75 | int c = p->buf[i]; 76 | if (q && c == '"' ) fprintf(port, "\\\""); 77 | else if (q && c == '\\') fprintf(port, "\\\\"); 78 | else fputc(c, port); 79 | } 80 | 81 | if (q) fprintf(port, "\""); 82 | } else if ((x & obj_mask) == symbol_tag) { 83 | print_ptr_rec(port, (x - symbol_tag) | string_tag, DISPLAY); 84 | } else if ((x & obj_mask) == closure_tag) { 85 | fprintf(port, "#"); 86 | } else { 87 | fprintf(port, "#", x); 88 | } 89 | } 90 | 91 | static void print_ptr(ptr x) { 92 | print_ptr_rec(stdout, x, OUT); 93 | printf("\n"); 94 | } 95 | 96 | ptr ik_log(ptr msg) { 97 | fprintf(stderr, "log: "); 98 | print_ptr_rec(stderr, msg, IN); 99 | fprintf(stderr, "\n"); 100 | return 0; 101 | } 102 | 103 | void ik_error(ptr msg) { 104 | fprintf(stderr, "Exception"); 105 | print_ptr_rec(stderr, msg, OUT); 106 | fprintf(stderr, "\n"); 107 | exit(0); 108 | } 109 | 110 | static int unshift(ptr x) { 111 | return ((int) x) >> fx_shift; 112 | } 113 | 114 | static ptr shift(int x) { 115 | return x << fx_shift; 116 | } 117 | 118 | ptr s_bitwise_ior(ptr x, ptr y) { 119 | return shift(unshift(x) | unshift(y)); 120 | } 121 | 122 | ptr s_ash(ptr x, ptr y) { 123 | return shift(unshift(x) << unshift(y)); 124 | } 125 | 126 | static char* string_data(ptr x) { 127 | string* p = (string*)(x-string_tag); 128 | return p->buf; 129 | } 130 | 131 | static void cp_str_data(ptr x, char* buf, int buf_length) { 132 | string* p = (string*)(x-string_tag); 133 | unsigned int n = p->length >> fx_shift; 134 | unsigned int i; 135 | for (i = 0; i < n || i < buf_length-1; i++) { 136 | buf[i] = p->buf[i]; 137 | } 138 | buf[i] = '\0'; 139 | } 140 | 141 | ptr s_write(ptr fd, ptr str, ptr len) { 142 | int bytes = write(unshift(fd), 143 | string_data(str), 144 | unshift(len)); 145 | return shift(bytes); 146 | } 147 | 148 | ptr s_fflush(ptr fd) { 149 | fflush(fdopen(unshift(fd), "w")); 150 | return 0; 151 | } 152 | 153 | ptr scheme_write(ptr fd, ptr x, ptr opt) { 154 | FILE* port = fdopen(unshift(fd), "w"); 155 | print_ptr_rec(port, x, unshift(opt)); 156 | fflush(port); 157 | return 0; 158 | } 159 | 160 | ptr s_open_write(ptr fname) { 161 | char c_fname[FILENAME_MAX_LENGTH]; 162 | cp_str_data(fname, c_fname, FILENAME_MAX_LENGTH); 163 | int fd = open(c_fname, O_WRONLY | O_CREAT | O_TRUNC, 0640); 164 | return shift(fd); 165 | } 166 | 167 | ptr s_open_read(ptr fname) { 168 | char c_fname[FILENAME_MAX_LENGTH]; 169 | cp_str_data(fname, c_fname, FILENAME_MAX_LENGTH); 170 | int fd = open(c_fname, O_RDONLY); 171 | return shift(fd); 172 | } 173 | 174 | ptr s_read_char(ptr fd) { 175 | char ca[1]; 176 | if ((read(unshift(fd), ca, 1)) < 1) 177 | return eof_obj; 178 | return (ca[0] << char_shift) | char_tag; 179 | } 180 | 181 | ptr s_close(ptr fd) { 182 | return shift(close(unshift(fd))); 183 | } 184 | 185 | int s_system(ptr cmd) { 186 | char c_cmd[CMD_MAX_LENGTH]; 187 | cp_str_data(cmd, c_cmd, CMD_MAX_LENGTH); 188 | int r = system(c_cmd); 189 | return shift(r); 190 | } 191 | 192 | static char* gc_next; 193 | static ptr* gc_queue; 194 | static char* gc_new_heap_base; 195 | static char* gc_new_heap_top; 196 | 197 | static char* gc_get_forward_pointer(char* p) { 198 | ptr x = (ptr)*p; 199 | if (x != gc_forward_mark) 200 | return NULL; 201 | 202 | char* q = (char*) *(((ptr*)p)+1); 203 | assert(gc_new_heap_base <= q && q < gc_new_heap_top); 204 | return q; 205 | } 206 | 207 | static void gc_set_forward_pointer(char* p, char* q) { 208 | assert(gc_new_heap_base <= q && q < gc_new_heap_top); 209 | *p = gc_forward_mark; 210 | *(((ptr*)p)+1) = (ptr)q; 211 | } 212 | 213 | static unsigned int gc_align(unsigned int n) { 214 | unsigned int cell = 1 << obj_shift; 215 | return ((n + cell - 1)/cell) * cell; 216 | } 217 | 218 | static int gc_ptr_object(ptr x) { 219 | ptr tag = x & obj_mask; 220 | switch (tag) { 221 | case pair_tag: 222 | case vector_tag: 223 | case symbol_tag: 224 | case string_tag: 225 | case closure_tag: 226 | return 1; 227 | default: 228 | return 0; 229 | } 230 | } 231 | 232 | static unsigned int gc_size(ptr x) { 233 | unsigned int n = 0; 234 | ptr tag = x & obj_mask; 235 | char* p = (char*)(x-tag); 236 | switch (tag) { 237 | case pair_tag: 238 | n = 2 << word_shift; 239 | break; 240 | case vector_tag: 241 | n = (((vector*)p)->length >> fx_shift) + 1; 242 | n = n << word_shift; 243 | break; 244 | case symbol_tag: 245 | case string_tag: 246 | n = (((string*)p)->length >> fx_shift) + word_size; 247 | break; 248 | case closure_tag: 249 | n = (((closure*)p)->length >> fx_shift) + 2; 250 | n = n << word_shift; 251 | break; 252 | } 253 | return n; 254 | } 255 | 256 | static ptr gc_forward(ptr x) { 257 | if (!gc_ptr_object(x)) 258 | return x; 259 | 260 | ptr tag = x & obj_mask; 261 | char* p = (char*)(x-tag); 262 | char* q = gc_get_forward_pointer(p); 263 | if (q != NULL) { 264 | assert((((ptr)q) & obj_mask) == 0); 265 | return ((ptr)q) | tag; 266 | } 267 | 268 | q = gc_next; 269 | unsigned int n = gc_size(x); 270 | unsigned int i = 0; 271 | for (i=0; iheap_base_alt; 291 | gc_new_heap_top = mem->heap_top_alt; 292 | gc_clean_new(); 293 | 294 | gc_next = mem->heap_base_alt; 295 | gc_queue = (ptr*)(mem->scratch_base); 296 | 297 | ptr* scan = gc_queue; 298 | ptr* root = (ptr*)mem->global_base; 299 | while (root < (ptr*)mem->global_next) { 300 | *root = gc_forward(*root); 301 | root++; 302 | } 303 | 304 | root = (ptr*)mem->stack_base; 305 | root--; // skip top-level return address 306 | root--; 307 | while (root >= (ptr*) stack) { 308 | if (*root == return_addr) { 309 | root--; // skip return address 310 | } else { 311 | *root = gc_forward(*root); 312 | } 313 | root--; 314 | } 315 | 316 | mem->edi = gc_forward(mem->edi); 317 | 318 | while (scan < gc_queue) { 319 | ptr x = *(scan++); 320 | 321 | ptr tag = x & obj_mask; 322 | char* q = (char*)(x-tag); 323 | assert(gc_new_heap_base <= q && q < gc_new_heap_top); 324 | 325 | if (tag == pair_tag) { 326 | cell* p = (cell*)(x-tag); 327 | p->car = gc_forward(p->car); 328 | p->cdr = gc_forward(p->cdr); 329 | } else if (tag == vector_tag) { 330 | vector* p = (vector*)(x-tag); 331 | unsigned int len = p->length >> fx_shift; 332 | unsigned int i; 333 | for (i=0; ibuf[i] = gc_forward(p->buf[i]); 335 | } else if (tag == closure_tag) { 336 | closure* p = (closure*)(x-tag); 337 | unsigned int len = p->length >> fx_shift; 338 | unsigned int i; 339 | for (i=0; ifvs[i] = gc_forward(p->fvs[i]); 341 | } 342 | } 343 | 344 | mem->heap_next = gc_next; 345 | mem->heap_base_alt = mem->heap_base; 346 | mem->heap_top_alt = mem->heap_top; 347 | mem->heap_base = gc_new_heap_base; 348 | mem->heap_top = gc_new_heap_top; 349 | } 350 | 351 | char* heap_alloc(memory* mem, char* stack, int size) { 352 | char* heap_next = mem->heap_next; 353 | char* heap_new = heap_next + size; 354 | if (heap_new >= mem->heap_top) { 355 | gc(mem, stack); 356 | heap_next = mem->heap_next; 357 | heap_new = heap_next + size; 358 | if (heap_new >= mem->heap_top) { 359 | fprintf(stderr, "Exception: overflow\n"); 360 | exit(0); 361 | } 362 | } 363 | mem->heap_next = heap_new; 364 | return heap_next; 365 | } 366 | 367 | static char* allocate_protected_space(int size) { 368 | int page = getpagesize(); 369 | int status; 370 | int aligned_size = ((size + page - 1) / page) * page; 371 | char* p = mmap(0, aligned_size + 2 * page, 372 | PROT_READ | PROT_WRITE, 373 | MAP_ANONYMOUS | MAP_PRIVATE, 374 | 0, 0); 375 | if (p == MAP_FAILED) { perror("map"); exit(1); } 376 | status = mprotect(p, page, PROT_NONE); 377 | if (status != 0) { perror("mprotect"); exit(status); } 378 | status = mprotect(p + page + aligned_size, page, PROT_NONE); 379 | if (status != 0) { perror("mprotect"); exit(status); } 380 | return (p + page); 381 | } 382 | 383 | static void deallocate_protected_space(char* p, int size) { 384 | int page = getpagesize(); 385 | int status; 386 | int aligned_size = ((size + page - 1) / page) * page; 387 | status = munmap(p - page, aligned_size + 2 * page); 388 | if (status != 0) { perror("munmap"); exit(status); } 389 | } 390 | 391 | int main(int argc, char** argv) { 392 | int stack_size = (16 * 4096); 393 | int heap_size = (4 * 16 * 4096); 394 | int global_size = (16 * 4096); 395 | int scratch_size = (16 * 4096); 396 | 397 | char* stack_top = allocate_protected_space(stack_size); 398 | char* stack_base = stack_top + stack_size; 399 | 400 | char* heap = allocate_protected_space(heap_size); 401 | char* global = allocate_protected_space(global_size); 402 | char* scratch = allocate_protected_space(scratch_size); 403 | 404 | context ctxt; 405 | 406 | memory mem; 407 | mem.heap_next = heap; 408 | mem.global_next = global; 409 | mem.heap_base = heap; 410 | mem.heap_top = heap + heap_size/2; 411 | mem.heap_base_alt = mem.heap_top; 412 | mem.heap_top_alt = heap + heap_size; 413 | mem.global_base = global; 414 | mem.stack_base = stack_base; 415 | mem.scratch_base = scratch; 416 | 417 | print_ptr(scheme_entry(&ctxt, stack_base, &mem)); 418 | 419 | deallocate_protected_space(stack_top, stack_size); 420 | deallocate_protected_space(heap, stack_size); 421 | return 0; 422 | } 423 | -------------------------------------------------------------------------------- /src/startup.h: -------------------------------------------------------------------------------- 1 | /* define all scheme constants */ 2 | #define fx_mask 0x03 3 | #define fx_tag 0x00 4 | #define fx_shift 2 5 | #define bool_f 0x2F 6 | #define bool_t 0x6F 7 | #define bool_bit 6 8 | #define list_nil 0x3F 9 | #define eof_obj 0x7F 10 | #define char_mask 0x3F 11 | #define char_tag 0x0F 12 | #define char_shift 8 13 | #define obj_mask 0x07 14 | #define obj_shift 3 15 | #define pair_tag 0x01 16 | #define pair_size 8 17 | #define pair_car 0 18 | #define pair_cdr 4 19 | #define vector_tag 0x05 20 | #define string_tag 0x06 21 | #define closure_tag 0x02 22 | #define symbol_tag 0x03 23 | #define return_addr 0x17 24 | #define gc_forward_mark 0x27 25 | #define word_size 4 26 | #define word_shift 2 27 | 28 | /* all scheme values are of type ptrs */ 29 | typedef unsigned int ptr; 30 | 31 | typedef struct { 32 | void* eax; /* 0 scratch */ 33 | void* ebx; /* 4 preserve */ 34 | void* ecx; /* 8 scratch */ 35 | void* edx; /* 12 scratch */ 36 | void* esi; /* 16 preserve */ 37 | void* edi; /* 20 preserve */ 38 | void* ebp; /* 24 preserve */ 39 | void* esp; /* 28 preserve */ 40 | } context; 41 | 42 | typedef struct { 43 | ptr car; 44 | ptr cdr; 45 | } cell; 46 | 47 | typedef struct { 48 | ptr length; 49 | ptr buf[]; 50 | } vector; 51 | 52 | typedef struct { 53 | ptr length; 54 | char buf[]; 55 | } string; 56 | 57 | typedef struct { 58 | ptr length; 59 | ptr label; 60 | ptr fvs[]; 61 | } closure; 62 | 63 | typedef struct { 64 | char* heap_next; 65 | char* global_next; 66 | ptr edi; 67 | char* heap_base; 68 | char* heap_top; 69 | char* heap_base_alt; 70 | char* heap_top_alt; 71 | char* global_base; 72 | char* stack_base; 73 | char* scratch_base; 74 | } memory; 75 | -------------------------------------------------------------------------------- /src/tests-1.1-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output-noboot "integers" 2 | [0 => "0\n"] 3 | [1 => "1\n"] 4 | [-1 => "-1\n"] 5 | [10 => "10\n"] 6 | [-10 => "-10\n"] 7 | [2736 => "2736\n"] 8 | [-2736 => "-2736\n"] 9 | [536870911 => "536870911\n"] 10 | [-536870912 => "-536870912\n"] 11 | ) 12 | 13 | -------------------------------------------------------------------------------- /src/tests-1.2-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output "immediate constants" 2 | [#f => "#f\n"] 3 | [#t => "#t\n"] 4 | [() => "()\n"] 5 | ; [#\nul => "#\\nul\n"] 6 | ; [#\001 => "#\\soh\n"] 7 | ; [#\002 => "#\\stx\n"] 8 | ; [#\003 => "#\\etx\n"] 9 | ; [#\004 => "#\\eot\n"] 10 | ; [#\005 => "#\\enq\n"] 11 | ; [#\006 => "#\\ack\n"] 12 | ; [#\bel => "#\\bel\n"] 13 | ; [#\backspace => "#\\bs\n"] 14 | [#\tab => "#\\tab\n"] 15 | [#\newline => "#\\newline\n"] 16 | ; [#\vt => "#\\vt\n"] 17 | ; [#\page => "#\\ff\n"] 18 | [#\return => "#\\return\n"] 19 | ; [#\016 => "#\\so\n"] 20 | ; [#\017 => "#\\si\n"] 21 | ; [#\020 => "#\\dle\n"] 22 | ; [#\021 => "#\\dc1\n"] 23 | ; [#\022 => "#\\dc2\n"] 24 | ; [#\023 => "#\\dc3\n"] 25 | ; [#\024 => "#\\dc4\n"] 26 | ; [#\025 => "#\\nak\n"] 27 | ; [#\026 => "#\\syn\n"] 28 | ; [#\027 => "#\\etb\n"] 29 | ; [#\030 => "#\\can\n"] 30 | ; [#\031 => "#\\em\n"] 31 | ; [#\032 => "#\\sub\n"] 32 | ; [#\033 => "#\\esc\n"] 33 | ; [#\034 => "#\\fs\n"] 34 | ; [#\035 => "#\\gs\n"] 35 | ; [#\036 => "#\\rs\n"] 36 | ; [#\037 => "#\\us\n"] 37 | [#\space => "#\\space\n"] 38 | [#\! => "#\\!\n"] 39 | [#\" => "#\\\"\n"] 40 | [#\# => "#\\#\n"] 41 | [#\$ => "#\\$\n"] 42 | [#\% => "#\\%\n"] 43 | [#\& => "#\\&\n"] 44 | [#\' => "#\\'\n"] 45 | [#\( => "#\\(\n"] 46 | [#\) => "#\\)\n"] 47 | [#\* => "#\\*\n"] 48 | [#\+ => "#\\+\n"] 49 | [#\, => "#\\,\n"] 50 | [#\- => "#\\-\n"] 51 | [#\. => "#\\.\n"] 52 | [#\/ => "#\\/\n"] 53 | [#\0 => "#\\0\n"] 54 | [#\1 => "#\\1\n"] 55 | [#\2 => "#\\2\n"] 56 | [#\3 => "#\\3\n"] 57 | [#\4 => "#\\4\n"] 58 | [#\5 => "#\\5\n"] 59 | [#\6 => "#\\6\n"] 60 | [#\7 => "#\\7\n"] 61 | [#\8 => "#\\8\n"] 62 | [#\9 => "#\\9\n"] 63 | [#\: => "#\\:\n"] 64 | [#\; => "#\\;\n"] 65 | [#\< => "#\\<\n"] 66 | [#\= => "#\\=\n"] 67 | [#\> => "#\\>\n"] 68 | [#\? => "#\\?\n"] 69 | [#\@ => "#\\@\n"] 70 | [#\A => "#\\A\n"] 71 | [#\B => "#\\B\n"] 72 | [#\C => "#\\C\n"] 73 | [#\D => "#\\D\n"] 74 | [#\E => "#\\E\n"] 75 | [#\F => "#\\F\n"] 76 | [#\G => "#\\G\n"] 77 | [#\H => "#\\H\n"] 78 | [#\I => "#\\I\n"] 79 | [#\J => "#\\J\n"] 80 | [#\K => "#\\K\n"] 81 | [#\L => "#\\L\n"] 82 | [#\M => "#\\M\n"] 83 | [#\N => "#\\N\n"] 84 | [#\O => "#\\O\n"] 85 | [#\P => "#\\P\n"] 86 | [#\Q => "#\\Q\n"] 87 | [#\R => "#\\R\n"] 88 | [#\S => "#\\S\n"] 89 | [#\T => "#\\T\n"] 90 | [#\U => "#\\U\n"] 91 | [#\V => "#\\V\n"] 92 | [#\W => "#\\W\n"] 93 | [#\X => "#\\X\n"] 94 | [#\Y => "#\\Y\n"] 95 | [#\Z => "#\\Z\n"] 96 | [#\[ => "#\\[\n"] 97 | [#\\ => "#\\\\\n"] 98 | [#\] => "#\\]\n"] 99 | [#\^ => "#\\^\n"] 100 | [#\_ => "#\\_\n"] 101 | [#\` => "#\\`\n"] 102 | [#\a => "#\\a\n"] 103 | [#\b => "#\\b\n"] 104 | [#\c => "#\\c\n"] 105 | [#\d => "#\\d\n"] 106 | [#\e => "#\\e\n"] 107 | [#\f => "#\\f\n"] 108 | [#\g => "#\\g\n"] 109 | [#\h => "#\\h\n"] 110 | [#\i => "#\\i\n"] 111 | [#\j => "#\\j\n"] 112 | [#\k => "#\\k\n"] 113 | [#\l => "#\\l\n"] 114 | [#\m => "#\\m\n"] 115 | [#\n => "#\\n\n"] 116 | [#\o => "#\\o\n"] 117 | [#\p => "#\\p\n"] 118 | [#\q => "#\\q\n"] 119 | [#\r => "#\\r\n"] 120 | [#\s => "#\\s\n"] 121 | [#\t => "#\\t\n"] 122 | [#\u => "#\\u\n"] 123 | [#\v => "#\\v\n"] 124 | [#\w => "#\\w\n"] 125 | [#\x => "#\\x\n"] 126 | [#\y => "#\\y\n"] 127 | [#\z => "#\\z\n"] 128 | [#\{ => "#\\{\n"] 129 | [#\| => "#\\|\n"] 130 | [#\} => "#\\}\n"] 131 | [#\~ => "#\\~\n"] 132 | ; [#\rubout => "#\\del\n"] 133 | ) 134 | -------------------------------------------------------------------------------- /src/tests-1.3-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output-noboot "fxadd1" 2 | [(fxadd1 0) => "1\n"] 3 | [(fxadd1 -1) => "0\n"] 4 | [(fxadd1 1) => "2\n"] 5 | [(fxadd1 -100) => "-99\n"] 6 | [(fxadd1 1000) => "1001\n"] 7 | [(fxadd1 536870910) => "536870911\n"] 8 | [(fxadd1 -536870912) => "-536870911\n"] 9 | [(fxadd1 (fxadd1 0)) => "2\n"] 10 | [(fxadd1 (fxadd1 (fxadd1 (fxadd1 (fxadd1 (fxadd1 12)))))) => "18\n"] 11 | ) 12 | 13 | (add-tests-with-string-output-noboot "fxsub1" 14 | [(fxsub1 0) => "-1\n"] 15 | [(fxsub1 -1) => "-2\n"] 16 | [(fxsub1 1) => "0\n"] 17 | [(fxsub1 -100) => "-101\n"] 18 | [(fxsub1 1000) => "999\n"] 19 | [(fxsub1 536870911) => "536870910\n"] 20 | [(fxsub1 -536870911) => "-536870912\n"] 21 | [(fxsub1 (fxsub1 0)) => "-2\n"] 22 | [(fxsub1 (fxsub1 (fxsub1 (fxsub1 (fxsub1 (fxsub1 12)))))) => "6\n"] 23 | [(fxsub1 (fxadd1 0)) => "0\n"] 24 | ) 25 | 26 | 27 | (add-tests-with-string-output "fixnum->char and char->fixnum" 28 | [(fixnum->char 65) => "#\\A\n"] 29 | [(fixnum->char 97) => "#\\a\n"] 30 | [(fixnum->char 122) => "#\\z\n"] 31 | [(fixnum->char 90) => "#\\Z\n"] 32 | [(fixnum->char 48) => "#\\0\n"] 33 | [(fixnum->char 57) => "#\\9\n"] 34 | [(char->fixnum #\A) => "65\n"] 35 | [(char->fixnum #\a) => "97\n"] 36 | [(char->fixnum #\z) => "122\n"] 37 | [(char->fixnum #\Z) => "90\n"] 38 | [(char->fixnum #\0) => "48\n"] 39 | [(char->fixnum #\9) => "57\n"] 40 | [(char->fixnum (fixnum->char 12)) => "12\n"] 41 | [(fixnum->char (char->fixnum #\x)) => "#\\x\n"] 42 | ) 43 | 44 | (add-tests-with-string-output-noboot "fixnum?" 45 | [(fixnum? 0) => "#t\n"] 46 | [(fixnum? 1) => "#t\n"] 47 | [(fixnum? -1) => "#t\n"] 48 | [(fixnum? 37287) => "#t\n"] 49 | [(fixnum? -23873) => "#t\n"] 50 | [(fixnum? 536870911) => "#t\n"] 51 | [(fixnum? -536870912) => "#t\n"] 52 | [(fixnum? #t) => "#f\n"] 53 | [(fixnum? #f) => "#f\n"] 54 | [(fixnum? ()) => "#f\n"] 55 | [(fixnum? #\Q) => "#f\n"] 56 | [(fixnum? (fixnum? 12)) => "#f\n"] 57 | [(fixnum? (fixnum? #f)) => "#f\n"] 58 | [(fixnum? (fixnum? #\A)) => "#f\n"] 59 | [(fixnum? (char->fixnum #\r)) => "#t\n"] 60 | [(fixnum? (fixnum->char 12)) => "#f\n"] 61 | ) 62 | 63 | 64 | (add-tests-with-string-output "fxzero?" 65 | [(fxzero? 0) => "#t\n"] 66 | [(fxzero? 1) => "#f\n"] 67 | [(fxzero? -1) => "#f\n"] 68 | [(fxzero? 64) => "#f\n"] 69 | [(fxzero? 960) => "#f\n"] 70 | ) 71 | 72 | (add-tests-with-string-output "null?" 73 | [(null? ()) => "#t\n"] 74 | [(null? #f) => "#f\n"] 75 | [(null? #t) => "#f\n"] 76 | [(null? (null? ())) => "#f\n"] 77 | [(null? #\a) => "#f\n"] 78 | [(null? 0) => "#f\n"] 79 | [(null? -10) => "#f\n"] 80 | [(null? 10) => "#f\n"] 81 | ) 82 | 83 | (add-tests-with-string-output "boolean?" 84 | [(boolean? #t) => "#t\n"] 85 | [(boolean? #f) => "#t\n"] 86 | [(boolean? 0) => "#f\n"] 87 | [(boolean? 1) => "#f\n"] 88 | [(boolean? -1) => "#f\n"] 89 | [(boolean? ()) => "#f\n"] 90 | [(boolean? #\a) => "#f\n"] 91 | [(boolean? (boolean? 0)) => "#t\n"] 92 | [(boolean? (fixnum? (boolean? 0))) => "#t\n"] 93 | ) 94 | 95 | (add-tests-with-string-output "char?" 96 | [(char? #\a) => "#t\n"] 97 | [(char? #\Z) => "#t\n"] 98 | [(char? #\newline) => "#t\n"] 99 | [(char? #t) => "#f\n"] 100 | [(char? #f) => "#f\n"] 101 | [(char? ()) => "#f\n"] 102 | [(char? (char? #t)) => "#f\n"] 103 | [(char? 0) => "#f\n"] 104 | [(char? 23870) => "#f\n"] 105 | [(char? -23789) => "#f\n"] 106 | ) 107 | 108 | (add-tests-with-string-output "not" 109 | [(not #t) => "#f\n"] 110 | [(not #f) => "#t\n"] 111 | [(not 15) => "#f\n"] 112 | [(not ()) => "#f\n"] 113 | [(not #\A) => "#f\n"] 114 | [(not (not #t)) => "#t\n"] 115 | [(not (not #f)) => "#f\n"] 116 | [(not (not 15)) => "#t\n"] 117 | [(not (fixnum? 15)) => "#f\n"] 118 | [(not (fixnum? #f)) => "#t\n"] 119 | ) 120 | 121 | (add-tests-with-string-output-noboot "fxlognot" 122 | [(fxlognot 0) => "-1\n"] 123 | [(fxlognot -1) => "0\n"] 124 | [(fxlognot 1) => "-2\n"] 125 | [(fxlognot -2) => "1\n"] 126 | [(fxlognot 536870911) => "-536870912\n"] 127 | [(fxlognot -536870912) => "536870911\n"] 128 | [(fxlognot (fxlognot 237463)) => "237463\n"] 129 | ) 130 | 131 | -------------------------------------------------------------------------------- /src/tests-1.4-req.scm: -------------------------------------------------------------------------------- 1 | 2 | (add-tests-with-string-output "if" 3 | [(if #t 12 13) => "12\n"] 4 | [(if #f 12 13) => "13\n"] 5 | [(if 0 12 13) => "12\n"] 6 | [(if () 43 ()) => "43\n"] 7 | [(if #t (if 12 13 4) 17) => "13\n"] 8 | [(if #f 12 (if #f 13 4)) => "4\n"] 9 | [(if #\X (if 1 2 3) (if 4 5 6)) => "2\n"] 10 | [(if (not (boolean? #t)) 15 (boolean? #f)) => "#t\n"] 11 | [(if (if (char? #\a) (boolean? #\b) (fixnum? #\c)) 119 -23) => "-23\n"] 12 | [(if (if (if (not 1) (not 2) (not 3)) 4 5) 6 7) => "6\n"] 13 | [(if (not (if (if (not 1) (not 2) (not 3)) 4 5)) 6 7) => "7\n"] 14 | [(not (if (not (if (if (not 1) (not 2) (not 3)) 4 5)) 6 7)) => "#f\n"] 15 | [(if (char? 12) 13 14) => "14\n"] 16 | [(if (char? #\a) 13 14) => "13\n"] 17 | [(fxadd1 (if (fxsub1 1) (fxsub1 13) 14)) => "13\n"] 18 | ) 19 | -------------------------------------------------------------------------------- /src/tests-1.5-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output-noboot "fx+" 2 | [(fx+ 1 2) => "3\n"] 3 | [(fx+ 1 -2) => "-1\n"] 4 | [(fx+ -1 2) => "1\n"] 5 | [(fx+ -1 -2) => "-3\n"] 6 | [(fx+ 536870911 -1) => "536870910\n"] 7 | [(fx+ 536870910 1) => "536870911\n"] 8 | [(fx+ -536870912 1) => "-536870911\n"] 9 | [(fx+ -536870911 -1) => "-536870912\n"] 10 | [(fx+ 536870911 -536870912) => "-1\n"] 11 | [(fx+ 1 (fx+ 2 3)) => "6\n"] 12 | [(fx+ 1 (fx+ 2 -3)) => "0\n"] 13 | [(fx+ 1 (fx+ -2 3)) => "2\n"] 14 | [(fx+ 1 (fx+ -2 -3)) => "-4\n"] 15 | [(fx+ -1 (fx+ 2 3)) => "4\n"] 16 | [(fx+ -1 (fx+ 2 -3)) => "-2\n"] 17 | [(fx+ -1 (fx+ -2 3)) => "0\n"] 18 | [(fx+ -1 (fx+ -2 -3)) => "-6\n"] 19 | [(fx+ (fx+ 1 2) 3) => "6\n"] 20 | [(fx+ (fx+ 1 2) -3) => "0\n"] 21 | [(fx+ (fx+ 1 -2) 3) => "2\n"] 22 | [(fx+ (fx+ 1 -2) -3) => "-4\n"] 23 | [(fx+ (fx+ -1 2) 3) => "4\n"] 24 | [(fx+ (fx+ -1 2) -3) => "-2\n"] 25 | [(fx+ (fx+ -1 -2) 3) => "0\n"] 26 | [(fx+ (fx+ -1 -2) -3) => "-6\n"] 27 | [(fx+ (fx+ (fx+ (fx+ (fx+ (fx+ (fx+ (fx+ 1 2) 3) 4) 5) 6) 7) 8) 9) => "45\n"] 28 | [(fx+ 1 (fx+ 2 (fx+ 3 (fx+ 4 (fx+ 5 (fx+ 6 (fx+ 7 (fx+ 8 9)))))))) => "45\n"] 29 | ) 30 | 31 | (add-tests-with-string-output-noboot "fx-" 32 | [(fx- 1 2) => "-1\n"] 33 | [(fx- 1 -2) => "3\n"] 34 | [(fx- -1 2) => "-3\n"] 35 | [(fx- -1 -2) => "1\n"] 36 | [(fx- 536870910 -1) => "536870911\n"] 37 | [(fx- 536870911 1) => "536870910\n"] 38 | [(fx- -536870911 1) => "-536870912\n"] 39 | [(fx- -536870912 -1) => "-536870911\n"] 40 | [(fx- 1 536870911) => "-536870910\n"] 41 | [(fx- -1 536870911) => "-536870912\n"] 42 | [(fx- 1 -536870910) => "536870911\n"] 43 | [(fx- -1 -536870912) => "536870911\n"] 44 | [(fx- 536870911 536870911) => "0\n"] 45 | ;[(fx- 536870911 -536870912) => "-1\n"] 46 | [(fx- -536870911 -536870912) => "1\n"] 47 | [(fx- 1 (fx- 2 3)) => "2\n"] 48 | [(fx- 1 (fx- 2 -3)) => "-4\n"] 49 | [(fx- 1 (fx- -2 3)) => "6\n"] 50 | [(fx- 1 (fx- -2 -3)) => "0\n"] 51 | [(fx- -1 (fx- 2 3)) => "0\n"] 52 | [(fx- -1 (fx- 2 -3)) => "-6\n"] 53 | [(fx- -1 (fx- -2 3)) => "4\n"] 54 | [(fx- -1 (fx- -2 -3)) => "-2\n"] 55 | [(fx- 0 (fx- -2 -3)) => "-1\n"] 56 | [(fx- (fx- 1 2) 3) => "-4\n"] 57 | [(fx- (fx- 1 2) -3) => "2\n"] 58 | [(fx- (fx- 1 -2) 3) => "0\n"] 59 | [(fx- (fx- 1 -2) -3) => "6\n"] 60 | [(fx- (fx- -1 2) 3) => "-6\n"] 61 | [(fx- (fx- -1 2) -3) => "0\n"] 62 | [(fx- (fx- -1 -2) 3) => "-2\n"] 63 | [(fx- (fx- -1 -2) -3) => "4\n"] 64 | [(fx- (fx- (fx- (fx- (fx- (fx- (fx- (fx- 1 2) 3) 4) 5) 6) 7) 8) 9) => "-43\n"] 65 | [(fx- 1 (fx- 2 (fx- 3 (fx- 4 (fx- 5 (fx- 6 (fx- 7 (fx- 8 9)))))))) => "5\n"] 66 | ) 67 | 68 | (add-tests-with-string-output-noboot "fx*" 69 | [(fx* 2 3) => "6\n"] 70 | [(fx* 2 -3) => "-6\n"] 71 | [(fx* -2 3) => "-6\n"] 72 | [(fx* -2 -3) => "6\n"] 73 | [(fx* 536870911 1) => "536870911\n"] 74 | [(fx* 536870911 -1) => "-536870911\n"] 75 | [(fx* -536870912 1) => "-536870912\n"] 76 | [(fx* -536870911 -1) => "536870911\n"] 77 | [(fx* 2 (fx* 3 4)) => "24\n"] 78 | [(fx* (fx* 2 3) 4) => "24\n"] 79 | [(fx* (fx* (fx* (fx* (fx* 2 3) 4) 5) 6) 7) => "5040\n"] 80 | [(fx* 2 (fx* 3 (fx* 4 (fx* 5 (fx* 6 7))))) => "5040\n"] 81 | ) 82 | 83 | (add-tests-with-string-output "fxlogand and fxlogor" 84 | [(fxlogor 3 16) => "19\n"] 85 | [(fxlogor 3 5) => "7\n"] 86 | [(fxlogor 3 7) => "7\n"] 87 | [(fxlognot (fxlogor (fxlognot 7) 1)) => "6\n"] 88 | [(fxlognot (fxlogor 1 (fxlognot 7))) => "6\n"] 89 | [(fxlogand 3 7) => "3\n"] 90 | [(fxlogand 3 5) => "1\n"] 91 | [(fxlogand 2346 (fxlognot 2346)) => "0\n"] 92 | [(fxlogand (fxlognot 2346) 2346) => "0\n"] 93 | [(fxlogand 2376 2376) => "2376\n"] 94 | ) 95 | 96 | (add-tests-with-string-output "fx=" 97 | [(fx= 12 13) => "#f\n"] 98 | [(fx= 12 12) => "#t\n"] 99 | [(fx= 16 (fx+ 13 3)) => "#t\n"] 100 | [(fx= 16 (fx+ 13 13)) => "#f\n"] 101 | [(fx= (fx+ 13 3) 16) => "#t\n"] 102 | [(fx= (fx+ 13 13) 16) => "#f\n"] 103 | ) 104 | 105 | (add-tests-with-string-output "fx<" 106 | [(fx< 12 13) => "#t\n"] 107 | [(fx< 12 12) => "#f\n"] 108 | [(fx< 13 12) => "#f\n"] 109 | [(fx< 16 (fx+ 13 1)) => "#f\n"] 110 | [(fx< 16 (fx+ 13 3)) => "#f\n"] 111 | [(fx< 16 (fx+ 13 13)) => "#t\n"] 112 | [(fx< (fx+ 13 1) 16) => "#t\n"] 113 | [(fx< (fx+ 13 3) 16) => "#f\n"] 114 | [(fx< (fx+ 13 13) 16) => "#f\n"] 115 | ) 116 | 117 | (add-tests-with-string-output "fx<=" 118 | [(fx<= 12 13) => "#t\n"] 119 | [(fx<= 12 12) => "#t\n"] 120 | [(fx<= 13 12) => "#f\n"] 121 | [(fx<= 16 (fx+ 13 1)) => "#f\n"] 122 | [(fx<= 16 (fx+ 13 3)) => "#t\n"] 123 | [(fx<= 16 (fx+ 13 13)) => "#t\n"] 124 | [(fx<= (fx+ 13 1) 16) => "#t\n"] 125 | [(fx<= (fx+ 13 3) 16) => "#t\n"] 126 | [(fx<= (fx+ 13 13) 16) => "#f\n"] 127 | ) 128 | 129 | (add-tests-with-string-output "fx>" 130 | [(fx> 12 13) => "#f\n"] 131 | [(fx> 12 12) => "#f\n"] 132 | [(fx> 13 12) => "#t\n"] 133 | [(fx> 16 (fx+ 13 1)) => "#t\n"] 134 | [(fx> 16 (fx+ 13 3)) => "#f\n"] 135 | [(fx> 16 (fx+ 13 13)) => "#f\n"] 136 | [(fx> (fx+ 13 1) 16) => "#f\n"] 137 | [(fx> (fx+ 13 3) 16) => "#f\n"] 138 | [(fx> (fx+ 13 13) 16) => "#t\n"] 139 | ) 140 | 141 | (add-tests-with-string-output "fx>=" 142 | [(fx>= 12 13) => "#f\n"] 143 | [(fx>= 12 12) => "#t\n"] 144 | [(fx>= 13 12) => "#t\n"] 145 | [(fx>= 16 (fx+ 13 1)) => "#t\n"] 146 | [(fx>= 16 (fx+ 13 3)) => "#t\n"] 147 | [(fx>= 16 (fx+ 13 13)) => "#f\n"] 148 | [(fx>= (fx+ 13 1) 16) => "#f\n"] 149 | [(fx>= (fx+ 13 3) 16) => "#t\n"] 150 | [(fx>= (fx+ 13 13) 16) => "#t\n"] 151 | ) 152 | 153 | 154 | (add-tests-with-string-output "if" 155 | [(if (fx= 12 13) 12 13) => "13\n"] 156 | [(if (fx= 12 12) 13 14) => "13\n"] 157 | [(if (fx< 12 13) 12 13) => "12\n"] 158 | [(if (fx< 12 12) 13 14) => "14\n"] 159 | [(if (fx< 13 12) 13 14) => "14\n"] 160 | [(if (fx<= 12 13) 12 13) => "12\n"] 161 | [(if (fx<= 12 12) 12 13) => "12\n"] 162 | [(if (fx<= 13 12) 13 14) => "14\n"] 163 | [(if (fx> 12 13) 12 13) => "13\n"] 164 | [(if (fx> 12 12) 12 13) => "13\n"] 165 | [(if (fx> 13 12) 13 14) => "13\n"] 166 | [(if (fx>= 12 13) 12 13) => "13\n"] 167 | [(if (fx>= 12 12) 12 13) => "12\n"] 168 | [(if (fx>= 13 12) 13 14) => "13\n"] 169 | ) 170 | 171 | (add-tests-with-string-output "binary primitives" 172 | 173 | [(fxlognot -7) => "6\n"] 174 | [(fxlognot (fxlogor (fxlognot 7) 1)) => "6\n"] 175 | [(fxlognot (fxlogor (fxlognot 7) (fxlognot 2))) => "2\n"] 176 | [(fxlogand (fxlognot (fxlognot 12)) (fxlognot (fxlognot 12))) => "12\n"] 177 | [(fx+ (fx+ 1 2) (fx+ 3 4)) => "10\n"] 178 | [(fx+ (fx+ 1 2) (fx+ 3 -4)) => "2\n"] 179 | [(fx+ (fx+ 1 2) (fx+ -3 4)) => "4\n"] 180 | [(fx+ (fx+ 1 2) (fx+ -3 -4)) => "-4\n"] 181 | [(fx+ (fx+ 1 -2) (fx+ 3 4)) => "6\n"] 182 | [(fx+ (fx+ 1 -2) (fx+ 3 -4)) => "-2\n"] 183 | [(fx+ (fx+ 1 -2) (fx+ -3 4)) => "0\n"] 184 | [(fx+ (fx+ 1 -2) (fx+ -3 -4)) => "-8\n"] 185 | [(fx+ (fx+ -1 2) (fx+ 3 4)) => "8\n"] 186 | [(fx+ (fx+ -1 2) (fx+ 3 -4)) => "0\n"] 187 | [(fx+ (fx+ -1 2) (fx+ -3 4)) => "2\n"] 188 | [(fx+ (fx+ -1 2) (fx+ -3 -4)) => "-6\n"] 189 | [(fx+ (fx+ -1 -2) (fx+ 3 4)) => "4\n"] 190 | [(fx+ (fx+ -1 -2) (fx+ 3 -4)) => "-4\n"] 191 | [(fx+ (fx+ -1 -2) (fx+ -3 4)) => "-2\n"] 192 | [(fx+ (fx+ -1 -2) (fx+ -3 -4)) => "-10\n"] 193 | [(fx+ (fx+ (fx+ (fx+ (fx+ (fx+ (fx+ (fx+ 1 2) 3) 4) 5) 6) 7) 8) 9) => "45\n"] 194 | [(fx+ 1 (fx+ 2 (fx+ 3 (fx+ 4 (fx+ 5 (fx+ 6 (fx+ 7 (fx+ 8 9)))))))) => "45\n"] 195 | [(fx+ (fx+ (fx+ (fx+ 1 2) (fx+ 3 4)) (fx+ (fx+ 5 6) (fx+ 7 8))) 196 | (fx+ (fx+ (fx+ 9 10) (fx+ 11 12)) (fx+ (fx+ 13 14) (fx+ 15 16)))) 197 | => "136\n"] 198 | [(fx- (fx- 1 2) (fx- 3 4)) => "0\n"] 199 | [(fx- (fx- 1 2) (fx- 3 -4)) => "-8\n"] 200 | [(fx- (fx- 1 2) (fx- -3 4)) => "6\n"] 201 | [(fx- (fx- 1 2) (fx- -3 -4)) => "-2\n"] 202 | [(fx- (fx- 1 -2) (fx- 3 4)) => "4\n"] 203 | [(fx- (fx- 1 -2) (fx- 3 -4)) => "-4\n"] 204 | [(fx- (fx- 1 -2) (fx- -3 4)) => "10\n"] 205 | [(fx- (fx- 1 -2) (fx- -3 -4)) => "2\n"] 206 | [(fx- (fx- -1 2) (fx- 3 4)) => "-2\n"] 207 | [(fx- (fx- -1 2) (fx- 3 -4)) => "-10\n"] 208 | [(fx- (fx- -1 2) (fx- -3 4)) => "4\n"] 209 | [(fx- (fx- -1 2) (fx- -3 -4)) => "-4\n"] 210 | [(fx- (fx- -1 -2) (fx- 3 4)) => "2\n"] 211 | [(fx- (fx- -1 -2) (fx- 3 -4)) => "-6\n"] 212 | [(fx- (fx- -1 -2) (fx- -3 4)) => "8\n"] 213 | [(fx- (fx- -1 -2) (fx- -3 -4)) => "0\n"] 214 | [(fx- (fx- (fx- (fx- (fx- (fx- (fx- (fx- 1 2) 3) 4) 5) 6) 7) 8) 9) => "-43\n"] 215 | [(fx- 1 (fx- 2 (fx- 3 (fx- 4 (fx- 5 (fx- 6 (fx- 7 (fx- 8 9)))))))) => "5\n"] 216 | [(fx- (fx- (fx- (fx- 1 2) (fx- 3 4)) (fx- (fx- 5 6) (fx- 7 8))) 217 | (fx- (fx- (fx- 9 10) (fx- 11 12)) (fx- (fx- 13 14) (fx- 15 16)))) 218 | => "0\n"] 219 | [(fx* (fx* (fx* (fx* 2 3) (fx* 4 5)) (fx* (fx* 6 7) (fx* 8 9))) 220 | (fx* (fx* (fx* 2 3) (fx* 2 3)) (fx* (fx* 2 3) (fx* 2 3)))) 221 | => "470292480\n"] 222 | [(fxlognot (fxlogor (fxlognot 7) 1)) => "6\n"] 223 | [(fxlognot (fxlogor (fxlognot 7) (fxlognot 2))) => "2\n"] 224 | [(fxlogand (fxlognot (fxlognot 12)) (fxlognot (fxlognot 12))) => "12\n"] 225 | [(fx= (fx+ 13 3) (fx+ 10 6)) => "#t\n"] 226 | [(fx= (fx+ 13 0) (fx+ 10 6)) => "#f\n"] 227 | [(fx= (fx+ 12 1) (fx+ -12 -1)) => "#f\n"] 228 | [(fx< (fx+ 10 6) (fx+ 13 1)) => "#f\n"] 229 | [(fx< (fx+ 10 6) (fx+ 13 3)) => "#f\n"] 230 | [(fx< (fx+ 10 6) (fx+ 13 31)) => "#t\n"] 231 | [(fx< (fx+ 12 1) (fx+ -12 -1)) => "#f\n"] 232 | [(fx< (fx+ -12 -1) (fx+ 12 1)) => "#t\n"] 233 | [(fx<= (fx+ 10 6) (fx+ 13 1)) => "#f\n"] 234 | [(fx<= (fx+ 10 6) (fx+ 13 3)) => "#t\n"] 235 | [(fx<= (fx+ 10 6) (fx+ 13 31)) => "#t\n"] 236 | [(fx<= (fx+ 12 1) (fx+ -12 -1)) => "#f\n"] 237 | [(fx<= (fx+ -12 -1) (fx+ 12 1)) => "#t\n"] 238 | [(fx> (fx+ 10 6) (fx+ 13 1)) => "#t\n"] 239 | [(fx> (fx+ 10 6) (fx+ 13 3)) => "#f\n"] 240 | [(fx> (fx+ 10 6) (fx+ 13 31)) => "#f\n"] 241 | [(fx> (fx+ 12 1) (fx+ -12 -1)) => "#t\n"] 242 | [(fx> (fx+ -12 -1) (fx+ 12 1)) => "#f\n"] 243 | [(fx>= (fx+ 10 6) (fx+ 13 1)) => "#t\n"] 244 | [(fx>= (fx+ 10 6) (fx+ 13 3)) => "#t\n"] 245 | [(fx>= (fx+ 10 6) (fx+ 13 31)) => "#f\n"] 246 | [(fx>= (fx+ 12 1) (fx+ -12 -1)) => "#t\n"] 247 | [(fx>= (fx+ -12 -1) (fx+ 12 1)) => "#f\n"] 248 | ) 249 | -------------------------------------------------------------------------------- /src/tests-1.6-opt.scm: -------------------------------------------------------------------------------- 1 | 2 | (add-tests-with-string-output "let*" 3 | [(let* ([x 5]) x) => "5\n"] 4 | [(let* ([x (fx+ 1 2)]) x) => "3\n"] 5 | [(let* ([x (fx+ 1 2)] 6 | [y (fx+ 3 4)]) 7 | (fx+ x y)) 8 | => "10\n"] 9 | [(let* ([x (fx+ 1 2)] 10 | [y (fx+ 3 4)]) 11 | (fx- y x)) 12 | => "4\n"] 13 | [(let* ([x (let* ([y (fx+ 1 2)]) (fx* y y))]) 14 | (fx+ x x)) 15 | => "18\n"] 16 | [(let* ([x (fx+ 1 2)] 17 | [x (fx+ 3 4)]) 18 | x) 19 | => "7\n"] 20 | [(let* ([x (fx+ 1 2)] 21 | [x (fx+ x 4)]) 22 | x) 23 | => "7\n"] 24 | [(let* ([t (let* ([t (let* ([t (let* ([t (fx+ 1 2)]) t)]) t)]) t)]) t) 25 | => "3\n"] 26 | [(let* ([x 12] 27 | [x (fx+ x x)] 28 | [x (fx+ x x)] 29 | [x (fx+ x x)]) 30 | (fx+ x x)) 31 | => "192\n"] 32 | ) 33 | 34 | (add-tests-with-string-output "let vs let*" 35 | [(let ([x 1]) 36 | (let ([x (fx+ x 1)] 37 | [y (fx+ x 1)]) 38 | y)) 39 | => "2\n"] 40 | [(let* ([x 1]) 41 | (let* ([x (fx+ x 1)] 42 | [y (fx+ x 1)]) 43 | y)) 44 | => "3\n"] 45 | ) -------------------------------------------------------------------------------- /src/tests-1.6-req.scm: -------------------------------------------------------------------------------- 1 | 2 | (add-tests-with-string-output "let" 3 | [(let ([x 5]) x) => "5\n"] 4 | [(let ([x (fx+ 1 2)]) x) => "3\n"] 5 | [(let ([x (fx+ 1 2)]) 6 | (let ([y (fx+ 3 4)]) 7 | (fx+ x y))) 8 | => "10\n"] 9 | [(let ([x (fx+ 1 2)]) 10 | (let ([y (fx+ 3 4)]) 11 | (fx- y x))) 12 | => "4\n"] 13 | [(let ([x (fx+ 1 2)] 14 | [y (fx+ 3 4)]) 15 | (fx- y x)) 16 | => "4\n"] 17 | [(let ([x (let ([y (fx+ 1 2)]) (fx* y y))]) 18 | (fx+ x x)) 19 | => "18\n"] 20 | [(let ([x (fx+ 1 2)]) 21 | (let ([x (fx+ 3 4)]) 22 | x)) 23 | => "7\n"] 24 | [(let ([x (fx+ 1 2)]) 25 | (let ([x (fx+ x 4)]) 26 | x)) 27 | => "7\n"] 28 | [(let ([t (let ([t (let ([t (let ([t (fx+ 1 2)]) t)]) t)]) t)]) t) 29 | => "3\n"] 30 | [(let ([x 12]) 31 | (let ([x (fx+ x x)]) 32 | (let ([x (fx+ x x)]) 33 | (let ([x (fx+ x x)]) 34 | (fx+ x x))))) 35 | => "192\n"] 36 | ) 37 | 38 | 39 | 40 | 41 | 42 | -------------------------------------------------------------------------------- /src/tests-1.7-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output "procedures" 2 | [(letrec () 12) => "12\n"] 3 | [(letrec () (let ([x 5]) (fx+ x x))) => "10\n"] 4 | [(letrec ([f (lambda () 5)]) 7) => "7\n"] 5 | [(letrec ([f (lambda () 5)]) (let ([x 12]) x)) => "12\n"] 6 | [(letrec ([f (lambda () 5)]) (f)) => "5\n"] 7 | [(letrec ([f (lambda () 5)]) (let ([x (f)]) x)) => "5\n"] 8 | [(letrec ([f (lambda () 5)]) (fx+ (f) 6)) => "11\n"] 9 | [(letrec ([f (lambda () 5)]) (fx+ 6 (f))) => "11\n"] 10 | [(letrec ([f (lambda () 5)]) (fx- 20 (f))) => "15\n"] 11 | [(letrec ([f (lambda () 5)]) (fx+ (f) (f))) => "10\n"] 12 | [(letrec ([f (lambda () (fx+ 5 7))] 13 | [g (lambda () 13)]) 14 | (fx+ (f) (g))) => "25\n"] 15 | [(letrec ([f (lambda (x) (fx+ x 12))]) (f 13)) => "25\n"] 16 | [(letrec ([f (lambda (x) (fx+ x 12))]) (f (f 10))) => "34\n"] 17 | [(letrec ([f (lambda (x) (fx+ x 12))]) (f (f (f 0)))) => "36\n"] 18 | [(letrec ([f (lambda (x y) (fx+ x y))] 19 | [g (lambda (x) (fx+ x 12))]) 20 | (f 16 (f (g 0) (fx+ 1 (g 0))))) => "41\n"] 21 | [(letrec ([f (lambda (x) (g x x))] 22 | [g (lambda (x y) (fx+ x y))]) 23 | (f 12)) => "24\n"] 24 | [(letrec ([f (lambda (x) 25 | (if (fxzero? x) 26 | 1 27 | (fx* x (f (fxsub1 x)))))]) 28 | (f 5)) => "120\n"] 29 | [(letrec ([f (lambda (x acc) 30 | (if (fxzero? x) 31 | acc 32 | (f (fxsub1 x) (fx* acc x))))]) 33 | (f 5 1)) => "120\n"] 34 | [(letrec ([f (lambda (x) 35 | (if (fxzero? x) 36 | 0 37 | (fx+ 1 (f (fxsub1 x)))))]) 38 | (f 200)) => "200\n"] 39 | ) 40 | 41 | (add-tests-with-string-output "more stack" 42 | [(letrec ([f (lambda (n) 43 | (if (fxzero? n) 44 | 0 45 | (fx+ 1 (f (fxsub1 n)))))]) 46 | (f 500)) => "500\n"]) 47 | -------------------------------------------------------------------------------- /src/tests-1.8-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output "deeply nested procedures" 2 | [(letrec ([e (lambda (x) (if (fxzero? x) #t (o (fxsub1 x))))] 3 | [o (lambda (x) (if (fxzero? x) #f (e (fxsub1 x))))]) 4 | (e 25)) => "#f\n"] 5 | [(letrec ([countdown (lambda (n) 6 | (if (fxzero? n) 7 | n 8 | (countdown (fxsub1 n))))]) 9 | (countdown 50005000)) => "0\n"] 10 | [(letrec ([sum (lambda (n ac) 11 | (if (fxzero? n) 12 | ac 13 | (sum (fxsub1 n) (fx+ n ac))))]) 14 | (sum 10000 0)) => "50005000\n"] 15 | [(letrec ([e (lambda (x) (if (fxzero? x) #t (o (fxsub1 x))))] 16 | [o (lambda (x) (if (fxzero? x) #f (e (fxsub1 x))))]) 17 | (e 5000000)) => "#t\n"] 18 | ) 19 | -------------------------------------------------------------------------------- /src/tests-1.9-req.scm: -------------------------------------------------------------------------------- 1 | (load "tests-1.9.3-req.scm") 2 | (load "tests-1.9.2-req.scm") 3 | (load "tests-1.9.1-req.scm") 4 | -------------------------------------------------------------------------------- /src/tests-1.9.1-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output "cons" 2 | [(fxadd1 0) => "1\n"] 3 | [(pair? (cons 1 2)) => "#t\n"] 4 | [(pair? 12) => "#f\n"] 5 | [(pair? #t) => "#f\n"] 6 | [(pair? #f) => "#f\n"] 7 | [(pair? ()) => "#f\n"] 8 | [(fixnum? (cons 12 43)) => "#f\n"] 9 | [(boolean? (cons 12 43)) => "#f\n"] 10 | [(null? (cons 12 43)) => "#f\n"] 11 | [(not (cons 12 43)) => "#f\n"] 12 | [(if (cons 12 43) 32 43) => "32\n"] 13 | [(car (cons 1 23)) => "1\n"] 14 | [(cdr (cons 43 123)) => "123\n"] 15 | [(let ((x (cons 1 2)) (y (cons 3 4))) (pair? x)) => "#t\n"] 16 | [(pair? (cons (cons 12 3) #f)) => "#t\n"] 17 | [(pair? (cons (cons 12 3) (cons #t #f))) => "#t\n"] 18 | [(car (car (cons (cons 12 3) (cons #t #f)))) => "12\n"] 19 | [(cdr (car (cons (cons 12 3) (cons #t #f)))) => "3\n"] 20 | [(car (cdr (cons (cons 12 3) (cons #t #f)))) => "#t\n"] 21 | [(cdr (cdr (cons (cons 12 3) (cons #t #f)))) => "#f\n"] 22 | [(pair? (cons (fx* 1 1) 1)) => "#t\n"] 23 | [(let ([x (let ([y (fx+ 1 2)]) (fx* y y))]) 24 | (cons x (fx+ x x))) 25 | => "(9 . 18)\n"] 26 | [(let ([t0 (cons 1 2)] [t1 (cons 3 4)]) 27 | (let ([a0 (car t0)] [a1 (car t1)] [d0 (cdr t0)] [d1 (cdr t1)]) 28 | (let ([t0 (cons a0 d1)] [t1 (cons a1 d0)]) 29 | (cons t0 t1)))) 30 | => "((1 . 4) 3 . 2)\n"] 31 | [(let ([t (cons 1 2)]) 32 | (let ([t t]) 33 | (let ([t t]) 34 | (let ([t t]) 35 | t)))) 36 | => "(1 . 2)\n"] 37 | [(let ([t (let ([t (let ([t (let ([t (cons 1 2)]) t)]) t)]) t)]) t) 38 | => "(1 . 2)\n"] 39 | [(let ([x ()]) 40 | (let ([x (cons x x)]) 41 | (let ([x (cons x x)]) 42 | (let ([x (cons x x)]) 43 | (cons x x))))) 44 | => "((((()) ()) (()) ()) ((()) ()) (()) ())\n"] 45 | [(cons (let ([x #t]) (let ([y (cons x x)]) (cons x y))) 46 | (cons (let ([x #f]) (let ([y (cons x x)]) (cons y x))) 47 | ())) 48 | => "((#t #t . #t) ((#f . #f) . #f))\n"] 49 | ) 50 | 51 | (add-tests-with-string-output "begin/implicit-begin" 52 | [(begin 12) => "12\n"] 53 | [(begin 13 122) => "122\n"] 54 | [(begin 123 2343 #t) => "#t\n"] 55 | [(let ([t (begin 12 (cons 1 2))]) (begin t t)) => "(1 . 2)\n"] 56 | [(let ([t (begin 13 (cons 1 2))]) 57 | (cons 1 t) 58 | t) => "(1 . 2)\n"] 59 | [(let ([t (cons 1 2)]) 60 | (if (pair? t) 61 | (begin t) 62 | 12)) => "(1 . 2)\n"] 63 | ) 64 | 65 | (add-tests-with-string-output "set-car! set-cdr!" 66 | [(let ([x (cons 1 2)]) 67 | (begin (set-cdr! x ()) 68 | x)) => "(1)\n"] 69 | [(let ([x (cons 1 2)]) 70 | (set-cdr! x ()) 71 | x) => "(1)\n"] 72 | [(let ([x (cons 12 13)] [y (cons 14 15)]) 73 | (set-cdr! x y) 74 | x) => "(12 14 . 15)\n"] 75 | [(let ([x (cons 12 13)] [y (cons 14 15)]) 76 | (set-cdr! y x) 77 | y) => "(14 12 . 13)\n"] 78 | [(let ([x (cons 12 13)] [y (cons 14 15)]) 79 | (set-cdr! y x) 80 | x) => "(12 . 13)\n"] 81 | [(let ([x (cons 12 13)] [y (cons 14 15)]) 82 | (set-cdr! x y) 83 | y) => "(14 . 15)\n"] 84 | [(let ([x (let ([x (cons 1 2)]) (set-car! x #t) (set-cdr! x #f) x)]) 85 | (cons x x) 86 | x) => "(#t . #f)\n"] 87 | [(let ([x (cons 1 2)]) 88 | (set-cdr! x x) 89 | (set-car! (cdr x) x) 90 | (cons (eq? x (car x)) (eq? x (cdr x)))) => "(#t . #t)\n"] 91 | [(let ([x #f]) 92 | (if (pair? x) 93 | (set-car! x 12) 94 | #f) 95 | x) => "#f\n"] 96 | ) 97 | 98 | (add-tests-with-string-output "more cons" 99 | [(letrec ([f (lambda (i lst) (if (fx= i 0) lst (f (fxsub1 i) (cons i lst))))]) 100 | (f 10 ())) => "(1 2 3 4 5 6 7 8 9 10)\n"]) 101 | 102 | -------------------------------------------------------------------------------- /src/tests-1.9.2-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output "vectors" 2 | [(vector? (make-vector 0)) => "#t\n"] 3 | [(vector-length (make-vector 12)) => "12\n"] 4 | [(vector? (cons 1 2)) => "#f\n"] 5 | [(vector? 1287) => "#f\n"] 6 | [(vector? ()) => "#f\n"] 7 | [(vector? #t) => "#f\n"] 8 | [(vector? #f) => "#f\n"] 9 | [(pair? (make-vector 12)) => "#f\n"] 10 | [(null? (make-vector 12)) => "#f\n"] 11 | [(boolean? (make-vector 12)) => "#f\n"] 12 | [(make-vector 0) => "#()\n"] 13 | [(let ([v (make-vector 2)]) 14 | (vector-set! v 0 #t) 15 | (vector-set! v 1 #f) 16 | v) => "#(#t #f)\n"] 17 | [(let ([v (make-vector 2)]) 18 | (vector-set! v 0 v) 19 | (vector-set! v 1 v) 20 | (eq? (vector-ref v 0) (vector-ref v 1))) => "#t\n"] 21 | [(let ([v (make-vector 1)] [y (cons 1 2)]) 22 | (vector-set! v 0 y) 23 | (cons y (eq? y (vector-ref v 0)))) => "((1 . 2) . #t)\n"] 24 | [(let ([v0 (make-vector 2)]) 25 | (let ([v1 (make-vector 2)]) 26 | (vector-set! v0 0 100) 27 | (vector-set! v0 1 200) 28 | (vector-set! v1 0 300) 29 | (vector-set! v1 1 400) 30 | (cons v0 v1))) => "(#(100 200) . #(300 400))\n"] 31 | [(let ([v0 (make-vector 3)]) 32 | (let ([v1 (make-vector 3)]) 33 | (vector-set! v0 0 100) 34 | (vector-set! v0 1 200) 35 | (vector-set! v0 2 150) 36 | (vector-set! v1 0 300) 37 | (vector-set! v1 1 400) 38 | (vector-set! v1 2 350) 39 | (cons v0 v1))) => "(#(100 200 150) . #(300 400 350))\n"] 40 | [(let ([n 2]) 41 | (let ([v0 (make-vector n)]) 42 | (let ([v1 (make-vector n)]) 43 | (vector-set! v0 0 100) 44 | (vector-set! v0 1 200) 45 | (vector-set! v1 0 300) 46 | (vector-set! v1 1 400) 47 | (cons v0 v1)))) => "(#(100 200) . #(300 400))\n"] 48 | [(let ([n 3]) 49 | (let ([v0 (make-vector n)]) 50 | (let ([v1 (make-vector (vector-length v0))]) 51 | (vector-set! v0 (fx- (vector-length v0) 3) 100) 52 | (vector-set! v0 (fx- (vector-length v1) 2) 200) 53 | (vector-set! v0 (fx- (vector-length v0) 1) 150) 54 | (vector-set! v1 (fx- (vector-length v1) 3) 300) 55 | (vector-set! v1 (fx- (vector-length v0) 2) 400) 56 | (vector-set! v1 (fx- (vector-length v1) 1) 350) 57 | (cons v0 v1)))) => "(#(100 200 150) . #(300 400 350))\n"] 58 | [(let ([n 1]) 59 | (vector-set! (make-vector n) (fxsub1 n) (fx* n n)) 60 | n) => "1\n"] 61 | [(let ([n 1]) 62 | (let ([v (make-vector 1)]) 63 | (vector-set! v (fxsub1 n) n) 64 | (vector-ref v (fxsub1 n)))) => "1\n"] 65 | [(let ([v0 (make-vector 1)]) 66 | (vector-set! v0 0 1) 67 | (let ([v1 (make-vector 1)]) 68 | (vector-set! v1 0 13) 69 | (vector-set! (if (vector? v0) v0 v1) 70 | (fxsub1 (vector-length (if (vector? v0) v0 v1))) 71 | (fxadd1 (vector-ref 72 | (if (vector? v0) v0 v1) 73 | (fxsub1 (vector-length (if (vector? v0) v0 v1)))))) 74 | (cons v0 v1))) => "(#(2) . #(13))\n"] 75 | ) 76 | 77 | (add-tests-with-string-output "more vectors" 78 | [(letrec ([f (lambda (v i) 79 | (if (fx>= i 0) 80 | (begin (vector-set! v i i) (f v (fxsub1 i))) 81 | v))]) 82 | (let ((v (make-vector 100))) 83 | (vector-length (f v (fxsub1 100))))) => "100\n"]) 84 | 85 | -------------------------------------------------------------------------------- /src/tests-1.9.3-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output "strings" 2 | [(string? (make-string 0)) => "#t\n"] 3 | [(make-string 0) => "\"\"\n"] 4 | [(let ([s (make-string 1)]) 5 | (string-set! s 0 #\a) 6 | (string-ref s 0)) => "#\\a\n"] 7 | [(let ([s (make-string 2)]) 8 | (string-set! s 0 #\a) 9 | (string-set! s 1 #\b) 10 | (cons (string-ref s 0) (string-ref s 1))) => "(#\\a . #\\b)\n"] 11 | [(let ([i 0]) 12 | (let ([s (make-string 1)]) 13 | (string-set! s i #\a) 14 | (string-ref s i))) => "#\\a\n"] 15 | [(let ([i 0] [j 1]) 16 | (let ([s (make-string 2)]) 17 | (string-set! s i #\a) 18 | (string-set! s j #\b) 19 | (cons (string-ref s i) (string-ref s j)))) => "(#\\a . #\\b)\n"] 20 | [(let ([i 0] [c #\a]) 21 | (let ([s (make-string 1)]) 22 | (string-set! s i c) 23 | (string-ref s i))) => "#\\a\n"] 24 | [(string-length (make-string 12)) => "12\n"] 25 | [(string? (make-vector 12)) => "#f\n"] 26 | [(string? (cons 1 2)) => "#f\n"] 27 | [(string? 1287) => "#f\n"] 28 | [(string? ()) => "#f\n"] 29 | [(string? #t) => "#f\n"] 30 | [(string? #f) => "#f\n"] 31 | [(pair? (make-string 12)) => "#f\n"] 32 | [(null? (make-string 12)) => "#f\n"] 33 | [(boolean? (make-string 12)) => "#f\n"] 34 | [(vector? (make-string 12)) => "#f\n"] 35 | [(make-string 0) => "\"\"\n"] 36 | [(let ([v (make-string 2)]) 37 | (string-set! v 0 #\t) 38 | (string-set! v 1 #\f) 39 | v) => "\"tf\"\n"] 40 | [(let ([v (make-string 2)]) 41 | (string-set! v 0 #\x) 42 | (string-set! v 1 #\x) 43 | (char= (string-ref v 0) (string-ref v 1))) => "#t\n"] 44 | [(let ([v0 (make-string 3)]) 45 | (let ([v1 (make-string 3)]) 46 | (string-set! v0 0 #\a) 47 | (string-set! v0 1 #\b) 48 | (string-set! v0 2 #\c) 49 | (string-set! v1 0 #\d) 50 | (string-set! v1 1 #\e) 51 | (string-set! v1 2 #\f) 52 | (cons v0 v1))) => "(\"abc\" . \"def\")\n"] 53 | [(let ([n 2]) 54 | (let ([v0 (make-string n)]) 55 | (let ([v1 (make-string n)]) 56 | (string-set! v0 0 #\a) 57 | (string-set! v0 1 #\b) 58 | (string-set! v1 0 #\c) 59 | (string-set! v1 1 #\d) 60 | (cons v0 v1)))) => "(\"ab\" . \"cd\")\n"] 61 | [(let ([n 3]) 62 | (let ([v0 (make-string n)]) 63 | (let ([v1 (make-string (string-length v0))]) 64 | (string-set! v0 (fx- (string-length v0) 3) #\a) 65 | (string-set! v0 (fx- (string-length v1) 2) #\b) 66 | (string-set! v0 (fx- (string-length v0) 1) #\c) 67 | (string-set! v1 (fx- (string-length v1) 3) #\Z) 68 | (string-set! v1 (fx- (string-length v0) 2) #\Y) 69 | (string-set! v1 (fx- (string-length v1) 1) #\X) 70 | (cons v0 v1)))) => "(\"abc\" . \"ZYX\")\n"] 71 | [(let ([n 1]) 72 | (string-set! (make-string n) (fxsub1 n) (fixnum->char 34)) 73 | n) => "1\n"] 74 | [(let ([n 1]) 75 | (let ([v (make-string 1)]) 76 | (string-set! v (fxsub1 n) (fixnum->char n)) 77 | (char->fixnum (string-ref v (fxsub1 n))))) => "1\n"] 78 | [(let ([v0 (make-string 1)]) 79 | (string-set! v0 0 #\a) 80 | (let ([v1 (make-string 1)]) 81 | (string-set! v1 0 #\A) 82 | (string-set! (if (string? v0) v0 v1) 83 | (fxsub1 (string-length (if (string? v0) v0 v1))) 84 | (fixnum->char 85 | (fxadd1 86 | (char->fixnum 87 | (string-ref 88 | (if (string? v0) v0 v1) 89 | (fxsub1 (string-length (if (string? v0) v0 v1)))))))) 90 | (cons v0 v1))) => "(\"b\" . \"A\")\n"] 91 | [(let ([s (make-string 1)]) 92 | (string-set! s 0 #\") 93 | s) => "\"\\\"\"\n"] 94 | [(let ([s (make-string 1)]) 95 | (string-set! s 0 #\\) 96 | s) => "\"\\\\\"\n"] 97 | ) 98 | -------------------------------------------------------------------------------- /src/tests-2.1-req.scm: -------------------------------------------------------------------------------- 1 | ;;; one possible implementation strategy for procedures is via closure 2 | ;;; conversion. 3 | 4 | ;;; Lambda does many things at the same time: 5 | ;;; 1) It creates a procedure object (ie. one that passes procedure?) 6 | ;;; 2) It contains both code (what to do when applied) and data (what 7 | ;;; variables it references. 8 | ;;; 3) The procedure object, in addition to passing procedure?, can be 9 | ;;; applied to arguments. 10 | 11 | ;;; First step: separate code from data: 12 | ;;; convert every program containing lambda to a program containing 13 | ;;; codes and closures: 14 | ;;; (let ([f (lambda () 12)]) (procedure? f)) 15 | ;;; => 16 | ;;; (codes ([f-code (code () () 12)]) 17 | ;;; (let ([f (closure f-code)]) 18 | ;;; (procedure? f))) 19 | ;;; 20 | ;;; The codes binds code names to code points. Every code 21 | ;;; is of the form (code (formals ...) (free-vars ...) body) 22 | ;;; 23 | ;;; sexpr 24 | ;;; => recordize 25 | ;;; recognize lambda forms and applications 26 | ;;; => 27 | ;;; (let ([y 12]) 28 | ;;; (let ([f (lambda (x) (fx+ y x))]) 29 | ;;; (fx+ (f 10) (f 0)))) 30 | ;;; => convert closures 31 | ;;; (let ([y 12]) 32 | ;;; (let ([f (closure (code (x) (y) (fx+ x y)) y)]) 33 | ;;; (fx+ (call f 10) (call f 0)) 34 | ;;; => lift codes 35 | ;;; (codes ([code0 (code (x) (y) (fx+ x y))]) 36 | ;;; (let ([y 12]) 37 | ;;; (let ([f (closure code0 y)]) 38 | ;;; (fx+ (call f 10) (call f 0))))) 39 | ;;; => code generation 40 | ;;; 1) codes form generates unique-labels for every code and 41 | ;;; binds the names of the code to these labels. 42 | ;;; 2) Every code object has a list of formals and a list of free vars. 43 | ;;; The formals are at stack locations -4(%esp), -8(%esp), -12(%esp), ... 44 | ;;; The free vars are at -2(%edi), 2(%edi), 6(%edi), 10(%edi) ... 45 | ;;; These are inserted in the environment and then the body of the code 46 | ;;; is generated. 47 | ;;; 3) A (closure code-name free-vars ...) is generated the same way a 48 | ;;; (vector val* ...) is generated: First, the code-label and the free 49 | ;;; variables are placed at 0(%ebp), 4(%ebp), 8(%ebp), etc.. 50 | ;;; A closure pointer is placed in %eax, and %ebp is incremented to the 51 | ;;; next boundary. 52 | ;;; 4) A (call f arg* ...) does the following: 53 | ;;; a) evaluates the args and places them at contiguous stack locations 54 | ;;; si-8(%esp), si-12(%esp), ... (leaving room for two values). 55 | ;;; b) The value of the current closure pointer, %edi, is saved on the 56 | ;;; stack at si(%esp). 57 | ;;; c) The closure pointer of the callee is loaded in %edi. 58 | ;;; d) The value of %esp is adjusted by si 59 | ;;; e) An indirect call to -6(%edi) is issued. 60 | ;;; f) After return, the value of %esp is adjusted back by -si 61 | ;;; g) The value of the closure pointer is restored. 62 | ;;; The returned value is still in %eax. 63 | 64 | (add-tests-with-string-output "procedure?" 65 | [(procedure? (lambda (x) x)) => "#t\n"] 66 | [(let ([f (lambda (x) x)]) (procedure? f)) => "#t\n"] 67 | [(procedure? (make-vector 0)) => "#f\n"] 68 | [(procedure? (make-string 0)) => "#f\n"] 69 | [(procedure? (cons 1 2)) => "#f\n"] 70 | [(procedure? #\S) => "#f\n"] 71 | [(procedure? ()) => "#f\n"] 72 | [(procedure? #t) => "#f\n"] 73 | [(procedure? #f) => "#f\n"] 74 | [(string? (lambda (x) x)) => "#f\n"] 75 | [(vector? (lambda (x) x)) => "#f\n"] 76 | [(boolean? (lambda (x) x)) => "#f\n"] 77 | [(null? (lambda (x) x)) => "#f\n"] 78 | [(not (lambda (x) x)) => "#f\n"] 79 | ) 80 | 81 | 82 | (add-tests-with-string-output "applying thunks" 83 | [(let ([f (lambda () 12)]) (f)) => "12\n"] 84 | [(let ([f (lambda () (fx+ 12 13))]) (f)) => "25\n"] 85 | [(let ([f (lambda () 13)]) (fx+ (f) (f))) => "26\n"] 86 | [(let ([f (lambda () 87 | (let ([g (lambda () (fx+ 2 3))]) 88 | (fx* (g) (g))))]) 89 | (fx+ (f) (f))) => "50\n"] 90 | [(let ([f (lambda () 91 | (let ([f (lambda () (fx+ 2 3))]) 92 | (fx* (f) (f))))]) 93 | (fx+ (f) (f))) => "50\n"] 94 | [(let ([f (if (boolean? (lambda () 12)) 95 | (lambda () 13) 96 | (lambda () 14))]) 97 | (f)) => "14\n"] 98 | ) 99 | 100 | 101 | (add-tests-with-string-output "parameter passing" 102 | [(let ([f (lambda (x) x)]) (f 12)) => "12\n"] 103 | [(let ([f (lambda (x y) (fx+ x y))]) (f 12 13)) => "25\n"] 104 | [(let ([f (lambda (x) 105 | (let ([g (lambda (x y) (fx+ x y))]) 106 | (g x 100)))]) 107 | (f 1000)) => "1100\n"] 108 | [(let ([f (lambda (g) (g 2 13))]) 109 | (f (lambda (n m) (fx* n m)))) => "26\n"] 110 | [(let ([f (lambda (g) (fx+ (g 10) (g 100)))]) 111 | (f (lambda (x) (fx* x x)))) => "10100\n"] 112 | [(let ([f (lambda (f n m) 113 | (if (fxzero? n) 114 | m 115 | (f f (fxsub1 n) (fx* n m))))]) 116 | (f f 5 1)) => "120\n"] 117 | [(let ([f (lambda (f n) 118 | (if (fxzero? n) 119 | 1 120 | (fx* n (f f (fxsub1 n)))))]) 121 | (f f 5)) => "120\n"] 122 | ) 123 | 124 | 125 | (add-tests-with-string-output "closures" 126 | [(let ([n 12]) 127 | (let ([f (lambda () n)]) 128 | (f))) => "12\n"] 129 | [(let ([n 12]) 130 | (let ([f (lambda (m) (fx+ n m))]) 131 | (f 100))) => "112\n"] 132 | [(let ([f (lambda (f n m) 133 | (if (fxzero? n) 134 | m 135 | (f (fxsub1 n) (fx* n m))))]) 136 | (let ([g (lambda (g n m) (f (lambda (n m) (g g n m)) n m))]) 137 | (g g 5 1))) => "120\n"] 138 | [(let ([f (lambda (f n) 139 | (if (fxzero? n) 140 | 1 141 | (fx* n (f (fxsub1 n)))))]) 142 | (let ([g (lambda (g n) (f (lambda (n) (g g n)) n))]) 143 | (g g 5))) => "120\n"] 144 | ) 145 | -------------------------------------------------------------------------------- /src/tests-2.2-req.scm: -------------------------------------------------------------------------------- 1 | 2 | (add-tests-with-string-output "set!" 3 | [(let ([x 12]) 4 | (set! x 13) 5 | x) => "13\n"] 6 | [(let ([x 12]) 7 | (set! x (fxadd1 x)) 8 | x) => "13\n"] 9 | [(let ([x 12]) 10 | (let ([x #f]) (set! x 14)) 11 | x) => "12\n"] 12 | [(let ([x 12]) 13 | (let ([y (let ([x #f]) (set! x 14))]) 14 | x)) => "12\n"] 15 | [(let ([f #f]) 16 | (let ([g (lambda () f)]) 17 | (set! f 10) 18 | (g))) => "10\n"] 19 | [(let ([f (lambda (x) 20 | (set! x (fxadd1 x)) 21 | x)]) 22 | (f 12)) => "13\n"] 23 | [(let ([x 10]) 24 | (let ([f (lambda (x) 25 | (set! x (fxadd1 x)) 26 | x)]) 27 | (cons x (f x)))) => "(10 . 11)\n"] 28 | [(let ([t #f]) 29 | (let ([locative 30 | (cons 31 | (lambda () t) 32 | (lambda (n) (set! t n)))]) 33 | ((cdr locative) 17) 34 | ((car locative)))) => "17\n"] 35 | [(let ([locative 36 | (let ([t #f]) 37 | (cons 38 | (lambda () t) 39 | (lambda (n) (set! t n))))]) 40 | ((cdr locative) 17) 41 | ((car locative))) => "17\n"] 42 | [(let ([make-counter 43 | (lambda () 44 | (let ([counter -1]) 45 | (lambda () 46 | (set! counter (fxadd1 counter)) 47 | counter)))]) 48 | (let ([c0 (make-counter)] 49 | [c1 (make-counter)]) 50 | (c0) 51 | (cons (c0) (c1)))) => "(1 . 0)\n"] 52 | [(let ([fact #f]) 53 | (set! fact (lambda (n) 54 | (if (fxzero? n) 55 | 1 56 | (fx* n (fact (fxsub1 n)))))) 57 | (fact 5)) => "120\n"] 58 | [(let ([fact #f]) 59 | ((begin 60 | (set! fact (lambda (n) 61 | (if (fxzero? n) 62 | 1 63 | (fx* n (fact (fxsub1 n)))))) 64 | fact) 65 | 5)) => "120\n"] 66 | 67 | ) 68 | 69 | -------------------------------------------------------------------------------- /src/tests-2.3-req.scm: -------------------------------------------------------------------------------- 1 | 2 | (add-tests-with-string-output "complex constants" 3 | ['42 => "42\n"] 4 | ['(1 . 2) => "(1 . 2)\n"] 5 | ['(1 2 3) => "(1 2 3)\n"] 6 | [(let ([x '(1 2 3)]) x) => "(1 2 3)\n"] 7 | [(let ([f (lambda () '(1 2 3))]) 8 | (f)) => "(1 2 3)\n"] 9 | [(let ([f (lambda () '(1 2 3))]) 10 | (eq? (f) (f))) => "#t\n"] 11 | [(let ([f (lambda () 12 | (lambda () 13 | '(1 2 3)))]) 14 | ((f))) => "(1 2 3)\n"] 15 | [(let ([x '#(1 2 3)]) 16 | (cons x (vector-ref x 0))) => "(#(1 2 3) . 1)\n"] 17 | ["Hello World" => "\"Hello World\"\n"] 18 | ['("Hello" "World") => "(\"Hello\" \"World\")\n"] 19 | ) 20 | -------------------------------------------------------------------------------- /src/tests-2.4-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output "cond" 2 | [(cond [1 2] [else 3]) => "2\n"] 3 | [(cond [1] [else 13]) => "1\n"] 4 | [(cond [#f #t] [#t #f]) => "#f\n"] 5 | [(cond [else 17]) => "17\n"] 6 | [(cond [#f] [#f 12] [12 13]) => "13\n"] 7 | [(cond [(cons 1 2) => (lambda (x) (cdr x))]) => "2\n"] 8 | [(let ([else #t]) 9 | (cond 10 | [else 1287])) => "1287\n"] 11 | [(let ([else 17]) 12 | (cond 13 | [else])) => "17\n"] 14 | [(let ([else 17]) 15 | (cond 16 | [else => (lambda (x) x)])) => "17\n"] 17 | [(let ([else #f]) 18 | (cond 19 | [else ((lambda (x) (x x)) (lambda (x) (x x)))]) 20 | else) => "#f\n"] 21 | [(let ([=> 12]) 22 | (cond 23 | [12 => 14] 24 | [else 17])) => "14\n"] 25 | [(let ([=> 12]) 26 | (cond 27 | [=>])) => "12\n"] 28 | [(let ([=> 12]) 29 | (cond 30 | [=> =>])) => "12\n"] 31 | [(let ([=> 12]) 32 | (cond 33 | [=> => =>])) => "12\n"] 34 | [(let ([let 12]) 35 | (cond 36 | [let => (lambda (x) (fx+ let x))] 37 | [else 14])) => "24\n"] 38 | ) 39 | 40 | (load "tests-2.4.2-req.scm") 41 | (load "tests-2.4.1-req.scm") -------------------------------------------------------------------------------- /src/tests-2.4.1-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output "letrec" 2 | [(letrec () 12) => "12\n"] 3 | [(letrec ([f 12]) f) => "12\n"] 4 | [(letrec ([f 12] [g 13]) (fx+ f g)) => "25\n"] 5 | [(letrec ([fact 6 | (lambda (n) 7 | (if (fxzero? n) 8 | 1 9 | (fx* n (fact (fxsub1 n)))))]) 10 | (fact 5)) => "120\n"] 11 | [(letrec ([f 12] [g (lambda () f)]) 12 | (g)) => "12\n"] 13 | [(letrec ([f 12] [g (lambda (n) (set! f n))]) 14 | (g 130) 15 | f) => "130\n"] 16 | [(letrec ([f (lambda (g) (set! f g) (f))]) 17 | (f (lambda () 12))) => "12\n"] 18 | [(letrec ([f (cons (lambda () f) 19 | (lambda (x) (set! f x)))]) 20 | (let ([g (car f)]) 21 | ((cdr f) 100) 22 | (g))) => "100\n"] 23 | [(letrec ([f (letrec ([g (lambda (x) (fx* x 2))]) 24 | (lambda (n) (g (fx* n 2))))]) 25 | (f 12)) => "48\n"] 26 | [(letrec ([f (lambda (f n) 27 | (if (fxzero? n) 28 | 1 29 | (fx* n (f f (fxsub1 n)))))]) 30 | (f f 5)) => "120\n"] 31 | [(let ([f (lambda (f) 32 | (lambda (n) 33 | (if (fxzero? n) 34 | 1 35 | (fx* n (f (fxsub1 n))))))]) 36 | (letrec ([fix 37 | (lambda (f) 38 | (f (lambda (n) ((fix f) n))))]) 39 | ((fix f) 5))) => "120\n"] 40 | ) 41 | 42 | (add-tests-with-string-output "letrec*" 43 | [(letrec* () 12) => "12\n"] 44 | [(letrec* ([f 12]) f) => "12\n"] 45 | [(letrec* ([f 12] [g 13]) (fx+ f g)) => "25\n"] 46 | [(letrec* ([fact 47 | (lambda (n) 48 | (if (fxzero? n) 49 | 1 50 | (fx* n (fact (fxsub1 n)))))]) 51 | (fact 5)) => "120\n"] 52 | [(letrec* ([f 12] [g (lambda () f)]) 53 | (g)) => "12\n"] 54 | [(letrec* ([f 12] [g (lambda (n) (set! f n))]) 55 | (g 130) 56 | f) => "130\n"] 57 | [(letrec* ([f (lambda (g) (set! f g) (f))]) 58 | (f (lambda () 12))) => "12\n"] 59 | [(letrec* ([f (cons (lambda () f) 60 | (lambda (x) (set! f x)))]) 61 | (let ([g (car f)]) 62 | ((cdr f) 100) 63 | (g))) => "100\n"] 64 | [(letrec* ([f (letrec* ([g (lambda (x) (fx* x 2))]) 65 | (lambda (n) (g (fx* n 2))))]) 66 | (f 12)) => "48\n"] 67 | [(letrec* ([f (lambda (f n) 68 | (if (fxzero? n) 69 | 1 70 | (fx* n (f f (fxsub1 n)))))]) 71 | (f f 5)) => "120\n"] 72 | [(let ([f (lambda (f) 73 | (lambda (n) 74 | (if (fxzero? n) 75 | 1 76 | (fx* n (f (fxsub1 n))))))]) 77 | (letrec* ([fix 78 | (lambda (f) 79 | (f (lambda (n) ((fix f) n))))]) 80 | ((fix f) 5))) => "120\n"] 81 | [(letrec* ([a 12] [b (fx+ a 5)] [c (fx+ b a)]) 82 | c) => "29\n"] 83 | ) 84 | -------------------------------------------------------------------------------- /src/tests-2.4.2-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output "and/or" 2 | [(and) => "#t\n"] 3 | [(and 5) => "5\n"] 4 | [(and #f) => "#f\n"] 5 | [(and 5 6) => "6\n"] 6 | [(and #f ((lambda (x) (x x)) (lambda (x) (x x)))) => "#f\n"] 7 | [(or) => "#f\n"] 8 | [(or #t) => "#t\n"] 9 | [(or 5) => "5\n"] 10 | [(or 1 2 3) => "1\n"] 11 | [(or (cons 1 2) ((lambda (x) (x x)) (lambda (x) (x x)))) => "(1 . 2)\n"] 12 | [(let ([if 12]) (or if 17)) => "12\n"] 13 | [(let ([if 12]) (and if 17)) => "17\n"] 14 | [(let ([let 8]) (or let 18)) => "8\n"] 15 | [(let ([let 8]) (and let 18)) => "18\n"] 16 | [(let ([t 1]) 17 | (and (begin (set! t (fxadd1 t)) t) t)) => "2\n"] 18 | [(let ([t 1]) 19 | (or (begin (set! t (fxadd1 t)) t) t)) => "2\n"] 20 | ) 21 | 22 | 23 | (add-tests-with-string-output "when/unless" 24 | [(let ([x (cons 1 2)]) 25 | (when (pair? x) 26 | (set-car! x (fx+ (car x) (cdr x)))) 27 | x) => "(3 . 2)\n"] 28 | [(let ([x (cons 1 2)]) 29 | (when (pair? x) 30 | (set-car! x (fx+ (car x) (cdr x))) 31 | (set-car! x (fx+ (car x) (cdr x)))) 32 | x) => "(5 . 2)\n"] 33 | [(let ([x (cons 1 2)]) 34 | (unless (fixnum? x) 35 | (set-car! x (fx+ (car x) (cdr x)))) 36 | x) => "(3 . 2)\n"] 37 | [(let ([x (cons 1 2)]) 38 | (unless (fixnum? x) 39 | (set-car! x (fx+ (car x) (cdr x))) 40 | (set-car! x (fx+ (car x) (cdr x)))) 41 | x) => "(5 . 2)\n"] 42 | [(let ([let 12]) 43 | (when let let let let let)) => "12\n"] 44 | [(let ([let #f]) 45 | (unless let let let let let)) => "#f\n"] 46 | ) -------------------------------------------------------------------------------- /src/tests-2.6-req.scm: -------------------------------------------------------------------------------- 1 | ; vararg tests 2 | 3 | 4 | (add-tests-with-string-output "vararg not using rest argument" 5 | [(let ([f (lambda args 12)]) 6 | (f)) => "12\n"] 7 | [(let ([f (lambda args 12)]) 8 | (f 10)) => "12\n"] 9 | [(let ([f (lambda args 12)]) 10 | (f 10 20)) => "12\n"] 11 | [(let ([f (lambda args 12)]) 12 | (f 10 20 30)) => "12\n"] 13 | [(let ([f (lambda args 12)]) 14 | (f 10 20 30 40)) => "12\n"] 15 | [(let ([f (lambda args 12)]) 16 | (f 10 20 30 40 50)) => "12\n"] 17 | [(let ([f (lambda args 12)]) 18 | (f 10 20 30 40 50 60 70 80 90)) => "12\n"] 19 | [(let ([f (lambda (a0 . args) 12)]) 20 | (f 10)) => "12\n"] 21 | [(let ([f (lambda (a0 . args) a0)]) 22 | (f 10)) => "10\n"] 23 | [(let ([f (lambda (a0 . args) 12)]) 24 | (f 10 20)) => "12\n"] 25 | [(let ([f (lambda (a0 . args) a0)]) 26 | (f 10 20)) => "10\n"] 27 | [(let ([f (lambda (a0 . args) 12)]) 28 | (f 10 20 30)) => "12\n"] 29 | [(let ([f (lambda (a0 . args) a0)]) 30 | (f 10 20 30)) => "10\n"] 31 | [(let ([f (lambda (a0 . args) 12)]) 32 | (f 10 20 30 40)) => "12\n"] 33 | [(let ([f (lambda (a0 . args) a0)]) 34 | (f 10 20 30 40)) => "10\n"] 35 | [(let ([f (lambda (a0 a1 . args) (vector a0 a1))]) 36 | (f 10 20 30 40 50 60 70 80 90 100)) => "#(10 20)\n"] 37 | [(let ([f (lambda (a0 a1 a2 . args) (vector a0 a1 a2))]) 38 | (f 10 20 30 40 50 60 70 80 90 100)) => "#(10 20 30)\n"] 39 | [(let ([f (lambda (a0 a1 a2 a3 . args) (vector a0 a1 a2 a3))]) 40 | (f 10 20 30 40 50 60 70 80 90 100)) => "#(10 20 30 40)\n"] 41 | [(let ([f (lambda (a0 a1 a2 a3 a4 . args) (vector a0 a1 a2 a3 a4))]) 42 | (f 10 20 30 40 50 60 70 80 90 100)) => "#(10 20 30 40 50)\n"] 43 | [(let ([f (lambda (a0 a1 a2 a3 a4 a5 . args) (vector a0 a1 a2 a3 a4 a5))]) 44 | (f 10 20 30 40 50 60 70 80 90 100)) => "#(10 20 30 40 50 60)\n"] 45 | ) 46 | 47 | 48 | (add-tests-with-string-output "vararg using rest argument" 49 | [(let ([f (lambda args args)]) 50 | (f)) => "()\n"] 51 | [(let ([f (lambda args args)]) 52 | (f 10)) => "(10)\n"] 53 | [(let ([f (lambda args args)]) 54 | (f 10 20)) => "(10 20)\n"] 55 | [(let ([f (lambda args args)]) 56 | (f 10 20 30)) => "(10 20 30)\n"] 57 | [(let ([f (lambda args args)]) 58 | (f 10 20 30 40)) => "(10 20 30 40)\n"] 59 | [(let ([f (lambda (a0 . args) (vector a0 args))]) 60 | (f 10)) => "#(10 ())\n"] 61 | [(let ([f (lambda (a0 . args) (vector a0 args))]) 62 | (f 10 20)) => "#(10 (20))\n"] 63 | [(let ([f (lambda (a0 . args) (vector a0 args))]) 64 | (f 10 20 30)) => "#(10 (20 30))\n"] 65 | [(let ([f (lambda (a0 . args) (vector a0 args))]) 66 | (f 10 20 30 40)) => "#(10 (20 30 40))\n"] 67 | [(let ([f (lambda (a0 a1 . args) (vector a0 a1 args))]) 68 | (f 10 20 30 40 50 60 70 80 90)) => "#(10 20 (30 40 50 60 70 80 90))\n"] 69 | [(let ([f (lambda (a0 a1 a2 . args) (vector a0 a1 a2 args))]) 70 | (f 10 20 30 40 50 60 70 80 90)) => "#(10 20 30 (40 50 60 70 80 90))\n"] 71 | [(let ([f (lambda (a0 a1 a2 a3 . args) (vector a0 a1 a2 a3 args))]) 72 | (f 10 20 30 40 50 60 70 80 90)) => "#(10 20 30 40 (50 60 70 80 90))\n"] 73 | [(let ([f (lambda (a0 a1 a2 a3 a4 . args) (vector a0 a1 a2 a3 a4 args))]) 74 | (f 10 20 30 40 50 60 70 80 90)) => "#(10 20 30 40 50 (60 70 80 90))\n"] 75 | [(let ([f (lambda (a0 a1 a2 a3 a4 a5 . args)(vector a0 a1 a2 a3 a4 a5 args))]) 76 | (f 10 20 30 40 50 60 70 80 90)) => "#(10 20 30 40 50 60 (70 80 90))\n"] 77 | ) 78 | -------------------------------------------------------------------------------- /src/tests-2.8-req.scm: -------------------------------------------------------------------------------- 1 | 2 | (add-tests-with-string-output "symbols" 3 | [(symbol? 'foo) => "#t\n"] 4 | [(symbol? '()) => "#f\n"] 5 | [(symbol? "") => "#f\n"] 6 | [(symbol? '(1 2)) => "#f\n"] 7 | [(symbol? '#()) => "#f\n"] 8 | [(symbol? (lambda (x) x)) => "#f\n"] 9 | [(symbol? 'foo) => "#t\n"] 10 | [(string? 'foo) => "#f\n"] 11 | [(pair? 'foo) => "#f\n"] 12 | [(vector? 'foo) => "#f\n"] 13 | [(null? 'foo) => "#f\n"] 14 | [(boolean? 'foo) => "#f\n"] 15 | [(procedure? 'foo) => "#f\n"] 16 | [(eq? 'foo 'bar) => "#f\n"] 17 | [(eq? 'foo 'foo) => "#t\n"] 18 | ['foo => "foo\n"] 19 | ['(foo bar baz) => "(foo bar baz)\n"] 20 | ['(foo foo foo foo foo foo foo foo foo foo foo) 21 | => "(foo foo foo foo foo foo foo foo foo foo foo)\n"] 22 | 23 | ) 24 | -------------------------------------------------------------------------------- /src/tests-2.9-req.scm: -------------------------------------------------------------------------------- 1 | 2 | (add-tests-with-string-output "exit" 3 | [(foreign-call "exit" 0) => ""] 4 | ) 5 | 6 | (add-tests-with-string-output "S_error" 7 | [(let ([error (lambda args 8 | (foreign-call "ik_error" args))]) 9 | (error #f "died") 10 | 12) => ""] 11 | 12 | [(let ([error (lambda args 13 | (foreign-call "ik_error" args))]) 14 | (error 'car "died") 15 | 12) => ""] 16 | ) 17 | 18 | (add-tests-with-string-output "S_log" 19 | [(begin (log "hello") 1) => "1\n"] 20 | ) 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /src/tests-3.1-req.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | (add-tests-with-string-output "vector" 4 | [(fx= 1 2) => "#f\n"] 5 | [(vector 1 2 3 4 5) => "#(1 2 3 4 5)\n"] 6 | [(let ([f (lambda (f) (f 1 2 3 4 5 6))]) 7 | (f vector)) => "#(1 2 3 4 5 6)\n"] 8 | ) 9 | -------------------------------------------------------------------------------- /src/tests-3.2-req.scm: -------------------------------------------------------------------------------- 1 | 2 | (add-tests-with-string-output "error" 3 | [(error 'foo "here") => ""]) 4 | 5 | 6 | (add-tests-with-string-output "apply error" 7 | [(let ([f 6]) 8 | (f f)) => ""] 9 | [(let ([f 6]) 10 | (f (f))) => ""] 11 | [(1 2 3) => ""] 12 | [(1 (3 4)) => ""] 13 | [(let ([f (lambda () (1 2 3))]) 14 | 12) => "12\n"] 15 | ) 16 | 17 | (add-tests-with-string-output "arg-check for fixed-arg procedures" 18 | [(let ([f (lambda () 12)]) 19 | (f)) => "12\n"] 20 | [(let ([f (lambda () 12)]) 21 | (f 1)) => ""] 22 | [(let ([f (lambda () 12)]) 23 | (f 1 2)) => ""] 24 | [(let ([f (lambda (x) (fx+ x x))]) 25 | (f)) => ""] 26 | [(let ([f (lambda (x) (fx+ x x))]) 27 | (f 1)) => "2\n"] 28 | [(let ([f (lambda (x) (fx+ x x))]) 29 | (f 1 2)) => ""] 30 | [(let ([f (lambda (x y) (fx* x (fx+ y y)))]) 31 | (f)) => ""] 32 | [(let ([f (lambda (x y) (fx* x (fx+ y y)))]) 33 | (f 2)) => ""] 34 | [(let ([f (lambda (x y) (fx* x (fx+ y y)))]) 35 | (f 2 3)) => "12\n"] 36 | [(let ([f (lambda (x y) (fx* x (fx+ y y)))]) 37 | (f 2 3 4)) => ""] 38 | ) 39 | 40 | (add-tests-with-string-output "arg-check for var-arg procedures" 41 | [(let ([f (lambda x x)]) 42 | (f)) => "()\n"] 43 | [(let ([f (lambda x x)]) 44 | (f 'a)) => "(a)\n"] 45 | [(let ([f (lambda x x)]) 46 | (f 'a 'b)) => "(a b)\n"] 47 | [(let ([f (lambda x x)]) 48 | (f 'a 'b 'c)) => "(a b c)\n"] 49 | [(let ([f (lambda x x)]) 50 | (f 'a 'b 'c 'd)) => "(a b c d)\n"] 51 | 52 | [(let ([f (lambda (x . rest) (vector x rest))]) 53 | (f)) => ""] 54 | [(let ([f (lambda (x . rest) (vector x rest))]) 55 | (f 'a)) => "#(a ())\n"] 56 | [(let ([f (lambda (x . rest) (vector x rest))]) 57 | (f 'a 'b)) => "#(a (b))\n"] 58 | [(let ([f (lambda (x . rest) (vector x rest))]) 59 | (f 'a 'b 'c)) => "#(a (b c))\n"] 60 | [(let ([f (lambda (x . rest) (vector x rest))]) 61 | (f 'a 'b 'c 'd)) => "#(a (b c d))\n"] 62 | 63 | [(let ([f (lambda (x y . rest) (vector x y rest))]) 64 | (f)) => ""] 65 | [(let ([f (lambda (x y . rest) (vector x y rest))]) 66 | (f 'a)) => ""] 67 | [(let ([f (lambda (x y . rest) (vector x y rest))]) 68 | (f 'a 'b)) => "#(a b ())\n"] 69 | [(let ([f (lambda (x y . rest) (vector x y rest))]) 70 | (f 'a 'b 'c)) => "#(a b (c))\n"] 71 | [(let ([f (lambda (x y . rest) (vector x y rest))]) 72 | (f 'a 'b 'c 'd)) => "#(a b (c d))\n"] 73 | ) 74 | 75 | 76 | ;;; (add-tests-with-string-output "arg-check for primitives" 77 | ;;; [(cons 1 2 3) => ""] 78 | ;;; [(cons 1) => ""] 79 | ;;; [(vector-ref '#() 1 2 3 4) => ""] 80 | ;;; [(vector-ref) => ""] 81 | ;;; [(vector) => "#()\n"] 82 | ;;; [(string) => "\"\"\n"] 83 | ;;; ) 84 | -------------------------------------------------------------------------------- /src/tests-3.3-req.scm: -------------------------------------------------------------------------------- 1 | 2 | (add-tests-with-string-output "string-set! errors" 3 | ; first with a fixed index 4 | ; 5 | [(let ((t 1)) 6 | (and (begin (set! t (fxadd1 t)) t) 7 | t)) => "2\n"] 8 | 9 | [(let ((f (if (boolean? (lambda () 12)) 10 | (lambda () 13) 11 | (lambda () 14)))) 12 | (f)) => "14\n"] 13 | 14 | [(let ([f 12]) 15 | (let ([g (lambda () f)]) 16 | (g))) => "12\n"] 17 | [(fx< 1 2) => "#t\n"] 18 | [(let ([f (lambda (x y) (fx< x y))]) 19 | (f 10 10)) => "#f\n"] 20 | [(fx< 10 10) => "#f\n"] 21 | [(fx< 10 2) => "#f\n"] 22 | [(fx<= 1 2) => "#t\n"] 23 | [(fx<= 10 10) => "#t\n"] 24 | [(fx<= 10 2) => "#f\n"] 25 | #;[(let ([f 26 | (lambda (s i c) 27 | (unless (string? s) 28 | (error 'string-set!1 "not a string ~s" s)) 29 | (unless (fixnum? i) 30 | (error 'string-set!2 "invalid index ~s" i)) 31 | (if (fx< i ($string-length s)) 32 | #f 33 | (error 's1 "")) 34 | (unless (fx>= i 0) 35 | (error 'string-set!3 "index ~s is out of range for ~s" i s)) 36 | (unless (and (fx< i (string-length s)) 37 | (fx>= i 0)) 38 | (error 'string-set!3 "index ~s is out of range for ~s" i s)) 39 | (unless (char? c) 40 | (error 'string-set!4 "not a char ~s" c)) 41 | ($string-set! s i c) 12)]) 42 | (let ([x ($string #\a #\b #\c)] 43 | [y #\a]) 44 | (f x 8 y))) => ""] 45 | 46 | [(let ([x 12]) 47 | (string-set! x 0 #\a)) => ""] 48 | [(let ([x (string #\a #\b #\c)] 49 | [y 12]) 50 | (string-set! x 0 y)) => ""] 51 | [(let ([x (string #\a #\b #\c)] 52 | [y 12]) 53 | (string-set! x 8 y)) => ""] 54 | [(let ([x (string #\a #\b #\c)] 55 | [y #\a]) 56 | (string-set! x 8 y)) => ""] 57 | [(let ([x (string #\a #\b #\c)]) 58 | (string-set! x 8 #\a)) => ""] 59 | [(let ([x (string #\a #\b #\c)] 60 | [y #\a]) 61 | (string-set! x -1 y)) => ""] 62 | ; next the general case 63 | ;;; 6 kinds of errors: 64 | ;;; string is either: 65 | ;;; lex-non-string, run-non-string, lex-string, valid 66 | ;;; index is either: 67 | ;;; lex-invalid, runtime-non-fixnum, runtime-above, runtime-below, valid 68 | ;;; char is either: 69 | ;;; lex-invalid, runtime-non-char, valid. 70 | ;;; that's 4x5x3 = 60 tests! 71 | ;;; If we skip over the lexical string check, (since I don't do it), 72 | ;;; we have: 2x5x3 = 30 tests. 73 | 74 | [(let ([s (string #\a #\b #\c)] [i 1] [c #\X]) (string-set! s i c) s) 75 | => "\"aXc\"\n"] 76 | [(let ([s (string #\a #\b #\c)] [i 1]) (string-set! s i #\X) s) 77 | => "\"aXc\"\n"] 78 | [(let ([s (string #\a #\b #\c)] [i 1] [c 'X]) (string-set! s i c) s) 79 | => ""] 80 | 81 | [(let ([s (string #\a #\b #\c)] [i 1] [c #\X]) (string-set! s 1 c) s) 82 | => "\"aXc\"\n"] 83 | [(let ([s (string #\a #\b #\c)] [i 1]) (string-set! s 1 #\X) s) 84 | => "\"aXc\"\n"] 85 | [(let ([s (string #\a #\b #\c)] [i 1] [c 'X]) (string-set! s 1 c) s) 86 | => ""] 87 | 88 | [(let ([s (string #\a #\b #\c)] [i 3] [c #\X]) (string-set! s i c) s) 89 | => ""] 90 | [(let ([s (string #\a #\b #\c)] [i 3]) (string-set! s i #\X) s) 91 | => ""] 92 | [(let ([s (string #\a #\b #\c)] [i 3] [c 'X]) (string-set! s i c) s) 93 | => ""] 94 | 95 | [(let ([s (string #\a #\b #\c)] [i -10] [c #\X]) (string-set! s i c) s) 96 | => ""] 97 | [(let ([s (string #\a #\b #\c)] [i -11]) (string-set! s i #\X) s) 98 | => ""] 99 | [(let ([s (string #\a #\b #\c)] [i -1] [c 'X]) (string-set! s i c) s) 100 | => ""] 101 | 102 | [(let ([s (string #\a #\b #\c)] [i 'foo] [c #\X]) (string-set! s i c) s) 103 | => ""] 104 | [(let ([s (string #\a #\b #\c)] [i 'foo]) (string-set! s i #\X) s) 105 | => ""] 106 | [(let ([s (string #\a #\b #\c)] [i 'foo] [c 'X]) (string-set! s i c) s) 107 | => ""] 108 | 109 | 110 | 111 | [(let ([s '(string #\a #\b #\c)] [i 1] [c #\X]) (string-set! s i c) s) 112 | => ""] 113 | [(let ([s '(string #\a #\b #\c)] [i 1]) (string-set! s i #\X) s) 114 | => ""] 115 | [(let ([s '(string #\a #\b #\c)] [i 1] [c 'X]) (string-set! s i c) s) 116 | => ""] 117 | 118 | [(let ([s '(string #\a #\b #\c)] [i 1] [c #\X]) (string-set! s 1 c) s) 119 | => ""] 120 | [(let ([s '(string #\a #\b #\c)] [i 1]) (string-set! s 1 #\X) s) 121 | => ""] 122 | [(let ([s '(string #\a #\b #\c)] [i 1] [c 'X]) (string-set! s 1 c) s) 123 | => ""] 124 | 125 | [(let ([s '(string #\a #\b #\c)] [i 3] [c #\X]) (string-set! s i c) s) 126 | => ""] 127 | [(let ([s '(string #\a #\b #\c)] [i 3]) (string-set! s i #\X) s) 128 | => ""] 129 | [(let ([s '(string #\a #\b #\c)] [i 3] [c 'X]) (string-set! s i c) s) 130 | => ""] 131 | 132 | [(let ([s '(string #\a #\b #\c)] [i -10] [c #\X]) (string-set! s i c) s) 133 | => ""] 134 | [(let ([s '(string #\a #\b #\c)] [i -11]) (string-set! s i #\X) s) 135 | => ""] 136 | [(let ([s '(string #\a #\b #\c)] [i -1] [c 'X]) (string-set! s i c) s) 137 | => ""] 138 | 139 | [(let ([s '(string #\a #\b #\c)] [i 'foo] [c #\X]) (string-set! s i c) s) 140 | => ""] 141 | [(let ([s '(string #\a #\b #\c)] [i 'foo]) (string-set! s i #\X) s) 142 | => ""] 143 | [(let ([s '(string #\a #\b #\c)] [i 'foo] [c 'X]) (string-set! s i c) s) 144 | => ""] 145 | ) 146 | 147 | (add-tests-with-string-output "string errors" 148 | [(let ([f (lambda (a b c) (string a b c))]) 149 | (f #\a #\b #\c)) => "\"abc\"\n"] 150 | [(let ([f (lambda (a b c) (string a b c))]) 151 | (f #\a 12 #\c)) => ""] 152 | [(let ([f string]) 153 | (f #\a #\b #\c)) => "\"abc\"\n"] 154 | [(let ([f string]) 155 | (f #\a #\b 'x)) => ""] 156 | [(string #\a #\b #\c) => "\"abc\"\n"] 157 | [(string #\a #\b #t) => ""] 158 | ) 159 | -------------------------------------------------------------------------------- /src/tests-3.4-req.scm: -------------------------------------------------------------------------------- 1 | 2 | (add-tests-with-string-output "nontail apply" 3 | [(let ([f (lambda () 12)]) 4 | (fx+ (apply f '()) 1)) => "13\n"] 5 | [(let ([f (lambda (x) (fx+ x 12))]) 6 | (fx+ (apply f 13 '()) 1)) => "26\n"] 7 | [(let ([f (lambda (x) (fx+ x 12))]) 8 | (fx+ (apply f (cons 13 '())) 1)) => "26\n"] 9 | [(let ([f (lambda (x y z) (fx+ x (fx* y z)))]) 10 | (fx+ (apply f 12 '(7 2)) 1)) => "27\n"] 11 | [(cons (apply vector '(1 2 3 4 5 6 7 8)) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 12 | [(cons (apply vector 1 '(2 3 4 5 6 7 8)) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 13 | [(cons (apply vector 1 2 '(3 4 5 6 7 8)) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 14 | [(cons (apply vector 1 2 3 '(4 5 6 7 8)) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 15 | [(cons (apply vector 1 2 3 4 '(5 6 7 8)) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 16 | [(cons (apply vector 1 2 3 4 5 '(6 7 8)) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 17 | [(cons (apply vector 1 2 3 4 5 6 '(7 8)) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 18 | [(cons (apply vector 1 2 3 4 5 6 7 '(8)) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 19 | [(cons (apply vector 1 2 3 4 5 6 7 8 ()) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 20 | ) 21 | 22 | (add-tests-with-string-output "tail apply" 23 | [(let ([f (lambda () 12)]) 24 | (apply f '())) => "12\n"] 25 | [(let ([f (lambda (x) (fx+ x 12))]) 26 | (apply f 13 '())) => "25\n"] 27 | [(let ([f (lambda (x) (fx+ x 12))]) 28 | (apply f (cons 13 '()))) => "25\n"] 29 | [(let ([f (lambda (x y z) (fx+ x (fx* y z)))]) 30 | (apply f 12 '(7 2))) => "26\n"] 31 | [(apply vector '(1 2 3 4 5 6 7 8)) => "#(1 2 3 4 5 6 7 8)\n"] 32 | [(apply vector 1 '(2 3 4 5 6 7 8)) => "#(1 2 3 4 5 6 7 8)\n"] 33 | [(apply vector 1 2 '(3 4 5 6 7 8)) => "#(1 2 3 4 5 6 7 8)\n"] 34 | [(apply vector 1 2 3 '(4 5 6 7 8)) => "#(1 2 3 4 5 6 7 8)\n"] 35 | [(apply vector 1 2 3 4 '(5 6 7 8)) => "#(1 2 3 4 5 6 7 8)\n"] 36 | [(apply vector 1 2 3 4 5 '(6 7 8)) => "#(1 2 3 4 5 6 7 8)\n"] 37 | [(apply vector 1 2 3 4 5 6 '(7 8)) => "#(1 2 3 4 5 6 7 8)\n"] 38 | [(apply vector 1 2 3 4 5 6 7 '(8)) => "#(1 2 3 4 5 6 7 8)\n"] 39 | [(apply vector 1 2 3 4 5 6 7 8 ()) => "#(1 2 3 4 5 6 7 8)\n"] 40 | ) 41 | 42 | 43 | 44 | 45 | (add-tests-with-string-output "nontail apply" 46 | [(let ([f (lambda () 12)]) 47 | (fx+ (apply f '()) 1)) => "13\n"] 48 | [(let ([f (lambda (x) (fx+ x 12))]) 49 | (fx+ (apply f 13 '()) 1)) => "26\n"] 50 | [(let ([f (lambda (x) (fx+ x 12))]) 51 | (fx+ (apply f (cons 13 '())) 1)) => "26\n"] 52 | [(let ([f (lambda (x y z) (fx+ x (fx* y z)))]) 53 | (fx+ (apply f 12 '(7 2)) 1)) => "27\n"] 54 | [(cons (apply vector '(1 2 3 4 5 6 7 8)) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 55 | [(cons (apply vector 1 '(2 3 4 5 6 7 8)) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 56 | [(cons (apply vector 1 2 '(3 4 5 6 7 8)) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 57 | [(cons (apply vector 1 2 3 '(4 5 6 7 8)) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 58 | [(cons (apply vector 1 2 3 4 '(5 6 7 8)) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 59 | [(cons (apply vector 1 2 3 4 5 '(6 7 8)) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 60 | [(cons (apply vector 1 2 3 4 5 6 '(7 8)) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 61 | [(cons (apply vector 1 2 3 4 5 6 7 '(8)) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 62 | [(cons (apply vector 1 2 3 4 5 6 7 8 ()) '()) => "(#(1 2 3 4 5 6 7 8))\n"] 63 | ) 64 | 65 | (add-tests-with-string-output "tail apply" 66 | [(let ([f (lambda () 12)]) 67 | (apply f '())) => "12\n"] 68 | [(let ([f (lambda (x) (fx+ x 12))]) 69 | (apply f 13 '())) => "25\n"] 70 | [(let ([f (lambda (x) (fx+ x 12))]) 71 | (apply f (cons 13 '()))) => "25\n"] 72 | [(let ([f (lambda (x y z) (fx+ x (fx* y z)))]) 73 | (apply f 12 '(7 2))) => "26\n"] 74 | [(apply vector '(1 2 3 4 5 6 7 8)) => "#(1 2 3 4 5 6 7 8)\n"] 75 | [(apply vector 1 '(2 3 4 5 6 7 8)) => "#(1 2 3 4 5 6 7 8)\n"] 76 | [(apply vector 1 2 '(3 4 5 6 7 8)) => "#(1 2 3 4 5 6 7 8)\n"] 77 | [(apply vector 1 2 3 '(4 5 6 7 8)) => "#(1 2 3 4 5 6 7 8)\n"] 78 | [(apply vector 1 2 3 4 '(5 6 7 8)) => "#(1 2 3 4 5 6 7 8)\n"] 79 | [(apply vector 1 2 3 4 5 '(6 7 8)) => "#(1 2 3 4 5 6 7 8)\n"] 80 | [(apply vector 1 2 3 4 5 6 '(7 8)) => "#(1 2 3 4 5 6 7 8)\n"] 81 | [(apply vector 1 2 3 4 5 6 7 '(8)) => "#(1 2 3 4 5 6 7 8)\n"] 82 | [(apply vector 1 2 3 4 5 6 7 8 ()) => "#(1 2 3 4 5 6 7 8)\n"] 83 | ) 84 | -------------------------------------------------------------------------------- /src/tests-4.1-req.scm: -------------------------------------------------------------------------------- 1 | (load "tests-4.1.3-req.scm") 2 | (load "tests-4.1.2-req.scm") 3 | (load "tests-4.1.1-req.scm") 4 | -------------------------------------------------------------------------------- /src/tests-4.1.1-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output "remainder/modulo/quotient" 2 | ;;[#\tab => "#\\tab\n"] 3 | [(fxquotient 16 4) => "4\n"] 4 | [(fxquotient 5 2) => "2\n"] 5 | [(fxquotient -45 7) => "-6\n"] 6 | [(fxquotient 10 -3) => "-3\n"] 7 | [(fxquotient -17 -9) => "1\n"] 8 | 9 | [(fxremainder 16 4) => "0\n"] 10 | [(fxremainder 5 2) => "1\n"] 11 | [(fxremainder -45 7) => "-3\n"] 12 | [(fxremainder 10 -3) => "1\n"] 13 | [(fxremainder -17 -9) => "-8\n"] 14 | 15 | ; [(fxmodulo 16 4) => "0\n"] 16 | ; [(fxmodulo 5 2) => "1\n"] 17 | ; [(fxmodulo -45 7) => "4\n"] 18 | ; [(fxmodulo 10 -3) => "-2\n"] 19 | ; [(fxmodulo -17 -9) => "-8\n"] 20 | ) 21 | -------------------------------------------------------------------------------- /src/tests-4.1.2-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output "write-char" 2 | [(begin 3 | (write-char #\a) 4 | (flush-output-port (current-output-port)) 5 | (exit)) => "a"] 6 | [(begin 7 | (write-char #\a) 8 | (close-output-port (current-output-port)) 9 | (exit)) => "a"] 10 | [(begin 11 | (write-char #\H) 12 | (write-char #\e) 13 | (write-char #\l) 14 | (write-char #\l) 15 | (write-char #\o) 16 | (write-char #\space) 17 | (flush-output-port) 18 | (write-char #\W) 19 | (write-char #\o) 20 | (write-char #\r) 21 | (write-char #\l) 22 | (write-char #\d) 23 | (write-char #\!) 24 | (flush-output-port (current-output-port)) 25 | (exit)) => "Hello World!"] 26 | ) 27 | -------------------------------------------------------------------------------- /src/tests-4.1.3-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output-noboot "write/display" 2 | [(fx+ -536870911 -1) => "-536870912\n"] 3 | [(begin 4 | (write '(1 2 3)) 5 | (exit)) => "(1 2 3)"] 6 | [(begin 7 | (write '"Hello World!") 8 | (exit)) => "\"Hello World!\""] 9 | ) 10 | -------------------------------------------------------------------------------- /src/tests-4.2-req.scm: -------------------------------------------------------------------------------- 1 | (load "tests-4.2.3-req.scm") 2 | (load "tests-4.2.2-req.scm") 3 | (load "tests-4.2.1-req.scm") -------------------------------------------------------------------------------- /src/tests-4.2.1-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output "inner define" 2 | [(let () 3 | (define x 3) 4 | (define y 4) 5 | (fx+ x y)) 6 | => "7\n"] 7 | [(let () 8 | (define x 3) 9 | (set! x 4) 10 | (define y x) 11 | (fx+ x y)) 12 | => "8\n"]) -------------------------------------------------------------------------------- /src/tests-4.2.2-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output "eof-object" 2 | [(eof-object? (eof-object)) => "#t\n"] 3 | 4 | [(null? (eof-object)) => "#f\n"] 5 | [(boolean? (eof-object)) => "#f\n"] 6 | [(string? (eof-object)) => "#f\n"] 7 | [(char? (eof-object)) => "#f\n"] 8 | [(pair? (eof-object)) => "#f\n"] 9 | [(symbol? (eof-object)) => "#f\n"] 10 | [(procedure? (eof-object)) => "#f\n"] 11 | [(vector? (eof-object)) => "#f\n"] 12 | [(not (eof-object)) => "#f\n"] 13 | 14 | [(eof-object? #\a) => "#f\n"] 15 | [(eof-object? #t) => "#f\n"] 16 | [(eof-object? 12) => "#f\n"] 17 | [(eof-object? '(1 2 3)) => "#f\n"] 18 | [(eof-object? '()) => "#f\n"] 19 | [(eof-object? '#(foo)) => "#f\n"] 20 | [(eof-object? (lambda (x) x)) => "#f\n"] 21 | [(eof-object? 'baz) => "#f\n"] 22 | ) 23 | -------------------------------------------------------------------------------- /src/tests-4.2.3-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output "read-char" 2 | [(begin 3 | (let ([p (open-output-file "stst.tmp" 'replace)]) 4 | (display "Hello World!" p) 5 | (close-output-port p)) 6 | (let ([p (open-input-file "stst.tmp")]) 7 | (define loop 8 | (lambda () 9 | (let ([x (read-char p)]) 10 | (if (eof-object? x) 11 | (begin 12 | (close-input-port p) 13 | '()) 14 | (begin 15 | (display x) 16 | (loop)))))) 17 | (loop)) 18 | (exit)) 19 | => "Hello World!"] 20 | [(let ([s (make-string 10000)] 21 | [t "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz12344567890<>,./?;:'\"[]{}\\|`~!@#$%^&*()-_=+"]) 22 | (define fill-string! 23 | (lambda (i j) 24 | (unless (fx= i (string-length s)) 25 | (if (fx>= j (string-length t)) 26 | (fill-string! i (fx- j (string-length t))) 27 | (begin 28 | (string-set! s i (string-ref t j)) 29 | (fill-string! (fxadd1 i) (fx+ j 17))))))) 30 | (define write-string! 31 | (lambda (i p) 32 | (cond 33 | [(fx= i (string-length s)) (close-output-port p)] 34 | [else 35 | (write-char (string-ref s i) p) 36 | (write-string! (fxadd1 i) p)]))) 37 | (define verify 38 | (lambda (i p) 39 | (let ([x (read-char p)]) 40 | (cond 41 | [(eof-object? x) 42 | (close-input-port p) 43 | (fx= i (string-length s))] 44 | [(fx= i (string-length s)) (error 'verify "file too short")] 45 | [(char= (string-ref s i) x) 46 | (verify (fxadd1 i) p)] 47 | [else (error 'verify "mismatch")])))) 48 | (fill-string! 0 0) 49 | (write-string! 0 (open-output-file "stst.tmp" 'replace)) 50 | (verify 0 (open-input-file "stst.tmp"))) => "#t\n"] 51 | ) 52 | -------------------------------------------------------------------------------- /src/tests-4.3-req.scm: -------------------------------------------------------------------------------- 1 | 2 | #!eof 3 | 4 | (add-tests-with-string-output "tokenizer" 5 | [(let () 6 | (define test-tokenizer 7 | (lambda (p) 8 | ;(display (input-port? p) (standard-error-port)) 9 | (let ([tok (read-token p)]) 10 | (cond 11 | [(eof-object? tok) 'ok] 12 | [(or (eq? tok 'lparen) 13 | (eq? tok 'rparen) 14 | (eq? tok 'vparen) 15 | (eq? tok 'lbrack) 16 | (eq? tok 'rbrack) 17 | (eq? tok 'dot) 18 | (and (pair? tok) 19 | (or (eq? (car tok) 'datum) 20 | (eq? (car tok) 'macro)))) 21 | (test-tokenizer p)] 22 | [else 23 | (display tok) 24 | (error 'test "Invalid token ~s" tok)])))) 25 | (define test-file 26 | (lambda (filename) 27 | (display "Testing " (standard-error-port)) 28 | (display filename (standard-error-port)) 29 | (display "..." (standard-error-port)) 30 | (let ([p (open-input-file filename)]) 31 | ; (display (input-port? p)(standard-error-port)) 32 | (test-tokenizer p)))) 33 | (define test-files 34 | (lambda (files) 35 | (unless (null? files) 36 | (test-file (car files)) 37 | (test-files (cdr files))))) 38 | (define filenames 39 | '("libsymboltable-3.3.ss" 40 | "libhandlers-3.3.ss" 41 | "libcore-4.3.ss" 42 | "libio-4.2.ss" 43 | "libwriter-4.1.ss" 44 | "libtokenizer-4.3.ss" 45 | "compiler-4.3.ss")) 46 | (when (null? filenames) 47 | (error 'no-files-provided-in-test "add them")) 48 | (test-files filenames) 49 | 'ok) => "ok\n"] 50 | 51 | ) 52 | 53 | 54 | 55 | (add-tests-with-string-output "reader" 56 | [(let () 57 | (define test-reader 58 | (lambda (p) 59 | (let ([x (read p)]) 60 | (cond 61 | [(eof-object? x) 'ok] 62 | [else (test-reader p)])))) 63 | (define test-file 64 | (lambda (filename) 65 | (display "Testing " (standard-error-port)) 66 | (display filename (standard-error-port)) 67 | (display "..." (standard-error-port)) 68 | (test-reader (open-input-file filename)))) 69 | (define test-files 70 | (lambda (files) 71 | (unless (null? files) 72 | (test-file (car files)) 73 | (test-files (cdr files))))) 74 | (define filenames 75 | '("libsymboltable-3.3.ss" 76 | "libhandlers-3.3.ss" 77 | "libcore-4.3.ss" 78 | "libio-4.2.ss" 79 | "libwriter-4.1.ss" 80 | "libtokenizer-4.3.ss" 81 | "compiler-4.3.ss")) 82 | (when (null? filenames) 83 | (error 'no-files-provided-in-test "add them")) 84 | (test-files filenames) 85 | 'ok) => "ok\n"] 86 | 87 | ) 88 | -------------------------------------------------------------------------------- /src/tests-5.1-req.scm: -------------------------------------------------------------------------------- 1 | 2 | #!eof 3 | (add-tests-with-string-output "tokenizer" 4 | [(let () 5 | (define test-tokenizer 6 | (lambda (p) 7 | ;(display (input-port? p) (standard-error-port)) 8 | (let ([tok (read-token p)]) 9 | (cond 10 | [(eof-object? tok) 'ok] 11 | [(or (eq? tok 'lparen) 12 | (eq? tok 'rparen) 13 | (eq? tok 'vparen) 14 | (eq? tok 'lbrack) 15 | (eq? tok 'rbrack) 16 | (eq? tok 'dot) 17 | (and (pair? tok) 18 | (or (eq? (car tok) 'datum) 19 | (eq? (car tok) 'macro)))) 20 | (test-tokenizer p)] 21 | [else 22 | (display tok) 23 | (error 'test "Invalid token ~s" tok)])))) 24 | (define test-file 25 | (lambda (filename) 26 | (display "Testing " (standard-error-port)) 27 | (display filename (standard-error-port)) 28 | (display "..." (standard-error-port)) 29 | (let ([p (open-input-file filename)]) 30 | ; (display (input-port? p)(standard-error-port)) 31 | (test-tokenizer p)))) 32 | (define test-files 33 | (lambda (files) 34 | (unless (null? files) 35 | (test-file (car files)) 36 | (test-files (cdr files))))) 37 | (define filenames 38 | '("libsymboltable-4.4.ss" 39 | "libhandlers-3.3.ss" 40 | "libcore-4.4.ss" 41 | "libio-4.2.ss" 42 | "libwriter-4.4.ss" 43 | "libtokenizer-4.3.ss" 44 | "compiler-5.1.ss")) 45 | (when (null? filenames) 46 | (error 'no-files-provided-in-test "add them")) 47 | (test-files filenames) 48 | 'ok) => "ok\n"] 49 | 50 | ) 51 | 52 | 53 | 54 | (add-tests-with-string-output "reader" 55 | [(let () 56 | (define test-reader 57 | (lambda (p) 58 | (let ([x (read p)]) 59 | (cond 60 | [(eof-object? x) 'ok] 61 | [else (test-reader p)])))) 62 | (define test-file 63 | (lambda (filename) 64 | (display "Testing " (standard-error-port)) 65 | (display filename (standard-error-port)) 66 | (display "..." (standard-error-port)) 67 | (test-reader (open-input-file filename)))) 68 | (define test-files 69 | (lambda (files) 70 | (unless (null? files) 71 | (test-file (car files)) 72 | (test-files (cdr files))))) 73 | (define filenames 74 | '("libsymboltable-4.4.ss" 75 | "libhandlers-3.3.ss" 76 | "libcore-4.4.ss" 77 | "libio-4.2.ss" 78 | "libwriter-4.4.ss" 79 | "libtokenizer-4.3.ss" 80 | "compiler-5.1.ss")) 81 | (when (null? filenames) 82 | (error 'no-files-provided-in-test "add them")) 83 | (test-files filenames) 84 | 'ok) => "ok\n"] 85 | 86 | ) 87 | -------------------------------------------------------------------------------- /src/tests-5.2-req.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | (add-tests-with-string-output "overflow" 4 | [(letrec ([f 5 | (lambda (i) 6 | (when (fx<= i 1000) 7 | (let ([x (make-vector 1000)]) 8 | (f (fxadd1 i)))))]) 9 | (f 0) 10 | 100) => "100\n"] 11 | [(letrec ([f 12 | (lambda (i) 13 | (when (fx<= i 100000) 14 | (let ([x (list 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 15 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)]) 16 | (f (fxadd1 i)))))]) 17 | (f 0) 18 | 100) => "100\n"]) 19 | -------------------------------------------------------------------------------- /src/tests-5.3-req.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | (add-tests-with-string-output "call/cc" 4 | [(call/cc (lambda (k) 12)) => "12\n"] 5 | [(call/cc (lambda (k) (k 12))) => "12\n"] 6 | [(call/cc (lambda (k) (fx+ 1 (k 12)))) => "12\n"] 7 | [(fx+ (call/cc (lambda (k) (k 12))) 8 | (call/cc (lambda (k) 13))) => "25\n"] 9 | [(letrec ([fact 10 | (lambda (n k) 11 | (cond 12 | [(fxzero? n) (k 1)] 13 | [else (fx* n (fact (fxsub1 n) k))]))]) 14 | (call/cc 15 | (lambda (k) 16 | (fact 5 k)))) => "1\n"] 17 | [(call/cc 18 | (lambda (k) 19 | (letrec ([fact 20 | (lambda (n) 21 | (cond 22 | [(fxzero? n) (k 1)] 23 | [else (fx* n (fact (fxsub1 n)))]))]) 24 | (fact 5)))) => "1\n"] 25 | [(let ([k #f]) 26 | (letrec ([fact 27 | (lambda (n) 28 | (cond 29 | [(fxzero? n) 30 | (call/cc 31 | (lambda (nk) 32 | (set! k nk) 33 | (k 1)))] 34 | [else (fx* n (fact (fxsub1 n)))]))]) 35 | (let ([v (fact 5)]) 36 | v))) => "120\n"] 37 | [(let ([k #f]) 38 | (letrec ([fact 39 | (lambda (n) 40 | (cond 41 | [(fxzero? n) 42 | (call/cc 43 | (lambda (nk) 44 | (set! k nk) 45 | (k 1)))] 46 | [else (fx* n (fact (fxsub1 n)))]))]) 47 | (let ([v (fact 5)]) 48 | (let ([nk k]) 49 | (set! k (lambda (x) (cons v x))) 50 | (nk v))))) => "(120 . 14400)\n"] 51 | ) 52 | 53 | -------------------------------------------------------------------------------- /src/tests-5.6-req.scm: -------------------------------------------------------------------------------- 1 | 2 | (add-tests-with-string-output "fxmodulo" 3 | [(fxmodulo 16 4) => "0\n"] 4 | [(fxmodulo 5 2) => "1\n"] 5 | [(fxmodulo -45 7) => "4\n"] 6 | [(fxmodulo 10 -3) => "-2\n"] 7 | [(fxmodulo -17 -9) => "-8\n"] 8 | 9 | [(let ([t 4]) (fxmodulo 16 t)) => "0\n"] 10 | [(let ([t 2]) (fxmodulo 5 t)) => "1\n"] 11 | [(let ([t 7]) (fxmodulo -45 t)) => "4\n"] 12 | [(let ([t -3]) (fxmodulo 10 t)) => "-2\n"] 13 | [(let ([t -9]) (fxmodulo -17 t)) => "-8\n"] 14 | ) 15 | 16 | -------------------------------------------------------------------------------- /src/tests-6.1-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output "define function" 2 | [(let () 3 | (define (x) 3) 4 | (define (y) 4) 5 | (fx+ (x) (y))) 6 | => "7\n"] 7 | [(let () 8 | (define (f x y) (fx+ x y)) 9 | (f 3 4)) 10 | => "7\n"] 11 | [(let () 12 | (define (f x) (fx+ x x)) 13 | (f 3)) 14 | => "6\n"]) 15 | -------------------------------------------------------------------------------- /src/tests-6.2-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output-noboot "load" 2 | [(let () 3 | (load "self.scm") 4 | (load "reader.scm") 5 | (char-numeric? #\9)) 6 | => "#t\n"] 7 | [(let () 8 | (load "self.scm") 9 | (load "reader.scm") 10 | (char-numeric? #\c)) 11 | => "#f\n"]) 12 | -------------------------------------------------------------------------------- /src/tests-6.3-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output-noboot "peek-char" 2 | [(let () 3 | (load "self.scm") 4 | (load "reader.scm") 5 | (let ((f (open-input-file "reader.scm"))) 6 | (peek-char f))) 7 | => "#\\;\n"] 8 | [(let () 9 | (load "self.scm") 10 | (load "reader.scm") 11 | (let ((f (open-input-file "reader.scm"))) 12 | (peek-char f) 13 | (read1-char f) 14 | (read1-char f))) 15 | => "#\\;\n"] 16 | ) 17 | 18 | (add-tests-with-string-output-noboot "read-token" 19 | [(let () 20 | (load "self.scm") 21 | (load "reader.scm") 22 | (let ((f (open-input-file "reader.scm"))) 23 | (read-token f) 24 | (read-token f))) 25 | => "define\n"] 26 | ) 27 | 28 | (add-tests-with-string-output-noboot "read" 29 | [(let () 30 | (load "self.scm") 31 | (load "reader.scm") 32 | (let ((f (open-input-file "reader.scm"))) 33 | (read f) 34 | (read f) 35 | (read f) 36 | (read f) 37 | (read f) 38 | (read f))) 39 | => "(define (char-numeric? c) (and (<= (char->fixnum #\\0) (char->fixnum c)) (<= (char->fixnum c) (char->fixnum #\\9))))\n"] 40 | ) 41 | -------------------------------------------------------------------------------- /src/tests-6.4-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output-noboot "load compiler" 2 | [(let () 3 | (load "self.scm") 4 | (load "reader.scm") 5 | (load "compiler.scm") 6 | 1 7 | ) 8 | => "1\n"] 9 | ) 10 | -------------------------------------------------------------------------------- /src/tests-6.4.1-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output "let loop" 2 | [(let () 3 | (let loop ((x 1) (r 0)) 4 | (if (fx= x 0) 5 | r 6 | (loop (fx- x 1) (fx+ r 1)))) 7 | ) 8 | => "1\n"] 9 | ) 10 | -------------------------------------------------------------------------------- /src/tests-6.4.2-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output "system" 2 | [(let () 3 | (system "echo hello") 4 | ) 5 | => "hello\n0\n"] 6 | ) 7 | -------------------------------------------------------------------------------- /src/tests-6.5-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output-noboot "test self" 2 | [(let () 3 | (load "self.scm") 4 | (load "reader.scm") 5 | (load "compiler.scm") 6 | (string-append "hello" ", " "there")) 7 | => "\"hello, there\"\n"] 8 | [(let () 9 | (load "self.scm") 10 | (load "reader.scm") 11 | (load "compiler.scm") 12 | (member 'x '(w x y z))) 13 | => "(x y z)\n"] 14 | [(let () 15 | (load "self.scm") 16 | (load "reader.scm") 17 | (load "compiler.scm") 18 | (list? '(x y . z))) 19 | => "#f\n"] 20 | [(let () 21 | (load "self.scm") 22 | (load "reader.scm") 23 | (load "compiler.scm") 24 | (length-vararg '(x y . z))) 25 | => "2\n"] 26 | [(let () 27 | (load "self.scm") 28 | (load "reader.scm") 29 | (load "compiler.scm") 30 | (reverse '(1 2 3))) 31 | => "(3 2 1)\n"] 32 | [(let () 33 | (load "self.scm") 34 | (load "reader.scm") 35 | (load "compiler.scm") 36 | (for-each display '(1 2 3)) 37 | 4) 38 | => "1234\n"] 39 | [(let () 40 | (load "self.scm") 41 | (load "reader.scm") 42 | (load "compiler.scm") 43 | (for-each (lambda (x y) (display (+ x y))) '(1 2 3) '(6 5 4)) 44 | 7) 45 | => "7777\n"] 46 | [(let () 47 | (load "self.scm") 48 | (load "reader.scm") 49 | (load "compiler.scm") 50 | (printf "hello\n") 51 | 1) 52 | => "hello\n1\n"] 53 | [(let () 54 | (load "self.scm") 55 | (load "reader.scm") 56 | (load "compiler.scm") 57 | (printf "hello ~s and ~s for ~a\n" "here" "there" 1) 58 | 1) 59 | => "hello here and there for 1\n1\n"] 60 | [(let () 61 | (load "self.scm") 62 | (load "reader.scm") 63 | (load "compiler.scm") 64 | (+ 2 4)) 65 | => "6\n"] 66 | [(let () 67 | (load "self.scm") 68 | (load "reader.scm") 69 | (load "compiler.scm") 70 | (string-append "foo" "bar")) 71 | => "\"foobar\"\n"] 72 | ) 73 | -------------------------------------------------------------------------------- /src/tests-6.6-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output-noboot "test compiler" 2 | [(let () 3 | (begin 4 | (let () 5 | (load "self.scm") 6 | (load "reader.scm") 7 | (load "compiler.scm") 8 | (all-conversions ''#(foo))) 9 | 'ok)) 10 | => "ok\n"] 11 | [(let () 12 | (begin 13 | (let () 14 | (load "self.scm") 15 | (load "reader.scm") 16 | (load "compiler.scm") 17 | (all-conversions '(list 1 2 3))) 18 | 'ok)) 19 | => "ok\n"] 20 | [(let () 21 | (load "self.scm") 22 | (load "reader.scm") 23 | (load "compiler.scm") 24 | (emit-program '(let () (fx+ 2 2))) 25 | 'ok) 26 | => " .text\n .globl scheme_entry\n .type scheme_entry, @function\nscheme_entry:\n mov 4(%esp), %ecx\n mov %ebx, 4(%ecx)\n mov %esi, 16(%ecx)\n mov %edi, 20(%ecx)\n mov %ebp, 24(%ecx)\n mov %esp, 28(%ecx)\n mov %ecx, %esi\n mov 12(%esp), %ebp\n mov 8(%esp), %esp\n mov $0, %edi\n call L_scheme_entry\n mov %esi, %ecx\n mov 4(%ecx), %ebx\n mov 16(%ecx), %esi\n mov 20(%ecx), %edi\n mov 24(%ecx), %ebp\n mov 28(%ecx), %esp\n ret\n .text\n .globl L_scheme_entry\n .type L_scheme_entry, @function\nL_scheme_entry:\n mov $8, %eax\n mov %eax, -4(%esp)\n mov $8, %eax\n add -4(%esp), %eax\n ret\nok\n"] 27 | [(let () 28 | (load "self.scm") 29 | (load "reader.scm") 30 | (load "compiler.scm") 31 | (emit-program 2) 32 | 'ok) 33 | => " .text\n .globl scheme_entry\n .type scheme_entry, @function\nscheme_entry:\n mov 4(%esp), %ecx\n mov %ebx, 4(%ecx)\n mov %esi, 16(%ecx)\n mov %edi, 20(%ecx)\n mov %ebp, 24(%ecx)\n mov %esp, 28(%ecx)\n mov %ecx, %esi\n mov 12(%esp), %ebp\n mov 8(%esp), %esp\n mov $0, %edi\n call L_scheme_entry\n mov %esi, %ecx\n mov 4(%ecx), %ebx\n mov 16(%ecx), %esi\n mov 20(%ecx), %edi\n mov 24(%ecx), %ebp\n mov 28(%ecx), %esp\n ret\n .text\n .globl L_scheme_entry\n .type L_scheme_entry, @function\nL_scheme_entry:\n mov $8, %eax\n ret\nok\n" 34 | ] 35 | ) 36 | -------------------------------------------------------------------------------- /src/tests-6.7-req.scm: -------------------------------------------------------------------------------- 1 | (add-tests-with-string-output-noboot "test compiler on tests" 2 | [(let () 3 | (flush-output-port) 4 | (load "self.scm") 5 | (load "reader.scm") 6 | (load "compiler.scm") 7 | (load "tests-1.9-req.scm") 8 | (load "tests-1.8-req.scm") 9 | (load "tests-1.7-req.scm") 10 | (load "tests-1.6-opt.scm") 11 | (load "tests-1.6-req.scm") 12 | (load "tests-1.4-req.scm") 13 | (load "tests-1.2-req.scm") 14 | ;; missing 1.1, 1.3, 1.5 15 | ;; b/c large numbers overflow due to double tagging 16 | (test-all) 17 | 'Ok) 18 | => "#\\~\nOk\n Ok.\nPassed all 255 tests.\nOk\n"] 19 | 20 | [(let () 21 | (flush-output-port) 22 | (load "self.scm") 23 | (load "reader.scm") 24 | (load "compiler.scm") 25 | (load "tests-2.9-req.scm") 26 | (load "tests-2.8-req.scm") 27 | (load "tests-2.6-req.scm") 28 | (load "tests-2.4-req.scm") 29 | (load "tests-2.3-req.scm") 30 | (load "tests-2.2-req.scm") 31 | (load "tests-2.1-req.scm") 32 | (test-all) 33 | 'Ok) 34 | => "120\nOk\n Ok.\nPassed all 169 tests.\nOk\n"] 35 | 36 | [(let () 37 | (flush-output-port) 38 | (load "self.scm") 39 | (load "reader.scm") 40 | (load "compiler.scm") 41 | (load "tests-3.4-req.scm") 42 | (load "tests-3.3-req.scm") 43 | (load "tests-3.2-req.scm") 44 | (load "tests-3.1-req.scm") 45 | (test-all) 46 | 'Ok) 47 | => "#(1 2 3 4 5 6)\nOk\n Ok.\nPassed all 138 tests.\nOk\n"] 48 | 49 | [(let () 50 | (flush-output-port) 51 | (load "self.scm") 52 | (load "reader.scm") 53 | (load "compiler.scm") 54 | (load "tests-4.2-req.scm") 55 | (load "tests-4.1.2-req.scm") 56 | (load "tests-4.1.1-req.scm") 57 | ;; missing 4.1.3 b/c large numbers overflow 58 | (test-all) 59 | 'Ok) 60 | => "-8\nOk\n Ok.\nPassed all 35 tests.\nOk\n"] 61 | 62 | [(let () 63 | (flush-output-port) 64 | (load "self.scm") 65 | (load "reader.scm") 66 | (load "compiler.scm") 67 | (load "tests-5.2-req.scm") 68 | (test-all) 69 | 'Ok) 70 | => "100\nOk\n Ok.\nPassed all 2 tests.\nOk\n"] 71 | ) 72 | -------------------------------------------------------------------------------- /src/tests-driver.scm: -------------------------------------------------------------------------------- 1 | ;; Test runner for the incremental compiler 2 | (define-syntax add-tests-with-string-output-noboot 3 | (syntax-rules (=>) 4 | [(_ test-name [expr => output-string] ...) 5 | (set! all-tests 6 | (cons 7 | '(test-name [expr string output-string noboot] ...) 8 | all-tests))])) 9 | 10 | (define-syntax add-tests-with-string-output 11 | (syntax-rules (=>) 12 | [(_ test-name [expr => output-string] ...) 13 | (set! all-tests 14 | (cons 15 | '(test-name [expr string output-string] ...) 16 | all-tests))])) 17 | 18 | (define enable-boot-tests #f) 19 | 20 | (define emit-program (lambda (expr) 0)) ;; re-implemented by compiler.scm 21 | 22 | (define emit-library (lambda () #f)) ;; re-implemented by compiler.scm 23 | 24 | (define (build) 25 | (unless (zero? (system "make stst --quiet")) 26 | (error 'make "Could not build target."))) 27 | 28 | (define (execute fn) 29 | (unless (zero? (system (string-append "./stst >" fn))) 30 | (error 'make "Produced program exited abnormally."))) 31 | 32 | (define compile-port 33 | (make-parameter 34 | (current-output-port) 35 | (lambda (p) 36 | (unless (output-port? p) 37 | (error 'compile-port (format "Not an output port ~s." p))) 38 | p))) 39 | 40 | (define (emit . args) 41 | (apply fprintf (compile-port) args) 42 | (newline (compile-port))) 43 | 44 | (define runtime-file 45 | (make-parameter 46 | "startup.c" 47 | (lambda (fname) 48 | (unless (string? fname) 49 | (error 'runtime-file (format "Not a string ~s." fname))) 50 | fname))) 51 | 52 | (define lib-file 53 | (make-parameter 54 | "lib.s" 55 | (lambda (fname) 56 | (unless (string? fname) 57 | (error 'lib-file (format "Not a string ~s." fname))) 58 | fname))) 59 | 60 | (define (compile-lib) 61 | (let ([p (open-output-file (lib-file) 'replace)]) 62 | (parameterize ([compile-port p]) 63 | (emit-library)) 64 | (close-output-port p))) 65 | 66 | (define (get-string . args) 67 | (let ((fn (if (null? args) "stst.out" (car args)))) 68 | (let ((port (open-input-file fn))) 69 | (let f ((r '())) 70 | (let ([c (read-char port)]) 71 | (cond 72 | [(eof-object? c) 73 | (close-input-port port) 74 | (apply string (reverse r))] 75 | [else (f (cons c r))])))))) 76 | 77 | ;; Just like emit-program, but send generated asm to outfile 78 | (define (compile-program expr) 79 | (let ([p (open-output-file "stst.s" 'replace)]) 80 | (parameterize ([compile-port p]) 81 | (emit-program expr)) 82 | (close-output-port p))) 83 | 84 | ;; Compile and run a single expression, great for interactive devel 85 | (define (run expr . args) 86 | (let ((fn (if (null? args) "stst.out" (car args)))) 87 | (compile-program expr) 88 | (build) 89 | (execute fn) 90 | (get-string fn))) 91 | 92 | (define (boot-run expr) 93 | (let ([p (open-output-file "stst.scm" 'replace)]) 94 | (write expr p) 95 | (close-output-port p)) 96 | (system "./boot stst.out") 97 | (let ((r (get-string))) 98 | (substring r 0 (- (string-length r) 3)))) 99 | 100 | (define all-tests '()) 101 | 102 | (define (test-with-string-output test-id expr expected-output noboot) 103 | (unless (string=? expected-output (run expr)) 104 | (error 'test (format "Output mismatch for test ~s, expected ~s, got ~s." 105 | test-id expected-output (get-string)))) 106 | (when enable-boot-tests 107 | (unless noboot 108 | (let ((r (boot-run expr))) 109 | (unless (string=? expected-output r) 110 | (error 'test (format "boot: Output mismatch for test ~s, expected ~s, got ~s." 111 | test-id expected-output r)))))) 112 | ) 113 | 114 | (define (test-one test-id test) 115 | (let ([expr (car test)] 116 | [type (cadr test)] 117 | [out (caddr test)] 118 | [noboot (if (null? (cdddr test)) #f (eq? 'noboot (cadddr test)))]) 119 | (printf "Test ~s:~s ..." test-id expr) 120 | (flush-output-port) 121 | (case type 122 | [(string) (test-with-string-output test-id expr out noboot)] 123 | [else (error 'test (format "Invalid test type ~s." type))]) 124 | (printf " Ok.\n"))) 125 | 126 | (define (test-all) 127 | (let f ([i 0] [ls (reverse all-tests)]) 128 | (if (null? ls) 129 | (printf "Passed all ~s tests.\n" i) 130 | (let ([x (car ls)] [ls (cdr ls)]) 131 | (let* ([test-name (car x)] 132 | [tests (cdr x)] 133 | [n (length tests)]) 134 | (printf "Performing ~a tests ...\n" test-name) 135 | (let g ([i i] [tests tests]) 136 | (cond 137 | [(null? tests) (f i ls)] 138 | [else 139 | (test-one i (car tests)) 140 | (g (add1 i) (cdr tests))]))))))) 141 | --------------------------------------------------------------------------------