├── .gitignore ├── Dockerfile ├── README ├── circle.yml ├── compile.scm ├── docs └── r7rs.pdf ├── lower-tests.scm ├── lower.scm ├── other_tests └── r4rstest.scm ├── parser-lib-tests.scm ├── parser-lib.scm ├── rakefile ├── runtime.c ├── runtime.ll.h ├── runtime_shared.h ├── scheme-parser-tests.scm ├── scheme-parser.scm └── tests ├── 001_int_constant.scm ├── 002_symbol_constants.scm ├── 009_list_literals.scm ├── 010_car.scm ├── 011_int_operations.scm ├── 020_lambda.scm ├── 021_let.scm ├── 030_define.scm └── rakefile /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | *~ 3 | *.bc 4 | *.ll 5 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM debian:testing-slim 2 | MAINTAINER mike.aizatsky@gmail.com 3 | RUN apt-get update 4 | RUN apt-get install -y build-essential clang rake chicken-bin libchicken-dev llvm 5 | RUN chicken-install test r7rs 6 | 7 | RUN mkdir /src /build /out 8 | COPY . /src/ 9 | WORKDIR /src/ 10 | CMD rake -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | This is an experimental Scheme->LLVM compiler. 2 | -------------------------------------------------------------------------------- /circle.yml: -------------------------------------------------------------------------------- 1 | machine: 2 | services: 3 | - docker 4 | 5 | test: 6 | post: 7 | - docker build -t $CIRCLE_PROJECT_REPONAME . 8 | - docker run -v $CIRCLE_ARTIFACTS:/out $CIRCLE_PROJECT_REPONAME -------------------------------------------------------------------------------- /compile.scm: -------------------------------------------------------------------------------- 1 | (load "scheme-parser.scm") 2 | (load "lower.scm") 3 | (require-extension srfi-13) 4 | 5 | (define literal-var-num 0) 6 | (define local-var-num 0) 7 | (define globals "") 8 | (define global-init "") 9 | (define global-def "") 10 | (define initial-environment '((car "@car") (cdr "@cdr") (+ "@add"))) 11 | (define symbols '()) 12 | 13 | (define (next-local-var) 14 | (set! local-var-num (+ local-var-num 1)) 15 | (string-append "%t." (number->string local-var-num))) 16 | 17 | (define (next-literal-var) 18 | (set! literal-var-num (+ literal-var-num 1)) 19 | (string-append "@L." (number->string literal-var-num))) 20 | 21 | (define (add-global s) 22 | (set! globals (string-append globals s "\n"))) 23 | 24 | (define (add-global-init s) 25 | (set! global-init (string-append global-init s "\n"))) 26 | 27 | (define (add-global-def s) 28 | (set! global-def (string-append global-def s "\n"))) 29 | 30 | (define (gen-global-init . params) 31 | (add-global-init (apply format params))) 32 | 33 | (define (gen-global-def . params) 34 | (add-global-def (apply format params))) 35 | 36 | (define (gen-global . params) 37 | (add-global (apply format params))) 38 | 39 | (define (gen . params) 40 | (display (apply format params)) 41 | (newline)) 42 | 43 | (define (gen-to-list instruction-list . params) 44 | (instruction-list (string-append (apply format params)))) 45 | 46 | (define main-list 47 | (lambda (s) 48 | (display s) 49 | (newline))) 50 | 51 | (define global-list 52 | (lambda (s) 53 | (add-global s))) 54 | 55 | (define global-init-list 56 | (lambda (s) 57 | (add-global-init s))) 58 | 59 | (define (error i . params) 60 | (i (string-append "ERROR: " (apply format params) "\n"))) 61 | 62 | (define (compile-number-literal e i) 63 | (let ((var-name (next-literal-var))) 64 | (gen-global-def 65 | "~a = internal constant DATA {i8* inttoptr (i32 ~a to i8*), i8 T_INT}; ~a " 66 | var-name e e) 67 | var-name)) 68 | 69 | (define (compile-symbol e i) 70 | (let ((p (assoc e symbols))) 71 | (if p 72 | (let* ((var-name (cadr p))) 73 | var-name) 74 | (let* ((var-name (next-literal-var)) 75 | (var-str (next-literal-var)) 76 | (str (symbol->string e)) 77 | (str-ptr-var (next-local-var)) 78 | (res-ptr-var (next-local-var)) 79 | (res-ptr-var-load (next-local-var)) 80 | (call-res-var (next-local-var)) 81 | (result-var (next-local-var)) 82 | (array-len (+ (string-length str) 1))) 83 | (set! symbols (cons (list e var-name) symbols)) 84 | (gen-global-def "~a = internal constant DATA {i8* inttoptr (i32 0 to i8*), i8 T_SYMBOL}; ~a" var-name e) 85 | (gen-global-def "~a = internal constant [~a x i8] c\"~a\\00\"" 86 | var-str array-len str) 87 | (gen-global-init "; init ~a" e) 88 | (gen-global-init "~A = getelementptr [~a x i8]* ~a, i64 0, i64 0" 89 | str-ptr-var array-len var-str) 90 | (gen-global-init "call void @init_symbol(i8* ~a, DATA* ~a)" 91 | str-ptr-var var-name) 92 | var-name)))) 93 | 94 | (define (compile-lambda e i env) 95 | (let* ((formals (cadr e)) 96 | (body (caddr e)) 97 | (proc-name (next-literal-var)) 98 | (formals-definition (map (lambda (x) (format "DATA* %~a" x)) formals)) 99 | (add-env (map (lambda (x) (list x (format "%~a" x))) formals))) 100 | (gen-global "define DATA* ~a(~a) {; ~a" 101 | proc-name (string-join formals-definition ",") e) 102 | (let ((ret (compile body global-list (append add-env env)))) 103 | (gen-global "ret DATA* ~a" ret) 104 | (gen-global "}") 105 | (let* ((var-data (next-literal-var)) 106 | (var-lambda (next-literal-var)) 107 | (args-type (map (lambda (x) (format "DATA*" x)) formals)) 108 | (function-type (format "DATA* (~a)*" (string-join args-type ", "))) 109 | (function-cast (format "bitcast (~a ~a to i8*)" 110 | function-type proc-name))) 111 | (gen-global-def "~a = internal constant DATA {i8* bitcast (LAMBDA* ~a to i8*), i8 T_LAMBDA}; ~a" 112 | var-data var-lambda e) 113 | (gen-global-def "~a = internal constant LAMBDA {i32 ~a, i8* ~a}; ~a" 114 | var-lambda (length formals) function-cast e) 115 | var-data)))) 116 | 117 | (define (compile-call e i env) 118 | (let* ((val (compile (car e) i env)) 119 | (args (map (lambda (e1) (compile e1 i env)) (cdr e))) 120 | (args-with-types 121 | (map (lambda (s) (string-append "DATA* " s)) args)) 122 | (var (next-local-var)) 123 | (arglist (string-join args-with-types ", "))) 124 | (gen-to-list i "~a = call DATA* @call~a(DATA* ~a, ~a)" 125 | var (length args) val arglist) 126 | var)) 127 | 128 | (define (compile-pair-literal e i) 129 | (let ((var-name (next-literal-var)) 130 | (h (compile-literal (car e) global-init-list)) 131 | (t (compile-literal (cdr e) global-init-list)) 132 | (cons-var (next-literal-var)) 133 | (data-addr-var (next-local-var)) 134 | (type-addr-var (next-local-var)) 135 | (casted-value-var (next-local-var)) 136 | (car-addr-var (next-local-var)) 137 | (cdr-addr-var (next-local-var))) 138 | (gen-global-def "~a = internal constant DATA {i8* bitcast (CONS* ~a to i8*), i8 T_CONS}; ~a" 139 | var-name cons-var e) 140 | (gen-global-def "~a = internal constant CONS {DATA* ~a, DATA* ~a}" cons-var h t) 141 | var-name)) 142 | 143 | (define (compile-literal e i) 144 | (cond 145 | ((number? e) (compile-number-literal e i)) 146 | ((pair? e) (compile-pair-literal e i)) 147 | ((symbol? e) (compile-symbol e i)) 148 | ((null? e) "inttoptr(i64 0 to DATA*)") 149 | (else (i "CAN'T COMPILE LITERAL: ") 150 | (i e) 151 | (i "\n")))) 152 | 153 | (define (compile-define e i env) 154 | (error i "can't compile define: ~a" e)) 155 | 156 | 157 | (define (gen-sizeof type i) 158 | (let ((sz (next-local-var)) 159 | (szi (next-local-var))) 160 | (gen-to-list i "; sizeof ~a" type) 161 | (gen-to-list i "~a = getelementptr ~a* null, i32 1" sz type) 162 | (gen-to-list i "~a = ptrtoint ~a* ~a to i32" szi type sz) 163 | szi)) 164 | 165 | ;; compiles let definitions 166 | ;; returns new environment 167 | (define (compile-let-defs defs i env) 168 | (let loop ((d defs)) 169 | (if (null? d) 170 | env 171 | (let* ((def (car d)) 172 | (def-name (car def)) 173 | (var (next-local-var)) 174 | (val (compile (cadr def) i env)) 175 | (val-addr (next-local-var)) 176 | (var-addr (next-local-var)) 177 | (data-sizeof (gen-sizeof "DATA" i))) 178 | (gen-to-list i "; init ~a" def-name) 179 | (gen-to-list i "~a = malloc DATA" var) 180 | (gen-to-list i "~a = bitcast DATA* ~a to i8*" val-addr val) 181 | (gen-to-list i "~a = bitcast DATA* ~a to i8*" var-addr var) 182 | (gen-to-list i "call void @llvm.memcpy.i32(i8* ~a, i8* ~a, i32 ~a, i32 0)" 183 | var-addr val-addr data-sizeof) 184 | (cons (list def-name var) (loop (cdr d))))))) 185 | 186 | 187 | (define (compile-let e i env) 188 | (let* ((defs (cadr e)) 189 | (body (cddr e)) 190 | (new-env (compile-let-defs defs i env))) 191 | (compile-list body i new-env))) 192 | 193 | (define (compile e i env) 194 | (gen-to-list i "; compile ~a in ~a" e env) 195 | (let ((r (cond 196 | ((number? e) (compile-literal e main-list)) 197 | ((pair? e) 198 | (cond 199 | ((eq? 'quote (car e)) (compile-literal (cadr e) main-list)) 200 | ((eq? 'let (car e)) (compile-let e main-list env)) 201 | ((eq? 'lambda (car e)) (compile-lambda e main-list env)) 202 | (#t (compile-call e i env)))) 203 | (else 204 | (let ((binding (assoc e env))) 205 | (if binding 206 | (cadr binding) 207 | (error i "can't compile ~a in env: ~a" e env))))))) 208 | r)) 209 | 210 | (define (compile-list exprs i env) 211 | (let loop ((ee exprs)) 212 | (if (not (null? (cdr ee))) 213 | (begin 214 | (compile (car ee) i env) 215 | (loop (cdr ee))) 216 | (compile (car ee) i env)))) 217 | 218 | (define (output-header) 219 | (display "#include \"runtime.ll.h\"\n") 220 | (display "define void @scheme_main() {\n")) 221 | 222 | (define (output-footer) 223 | (display "ret void\n") 224 | (display "}\n") 225 | (display globals) 226 | (display global-def) 227 | (display "define void @scheme_init() {\n") 228 | (display global-init) 229 | (display "ret void\n}\n")) 230 | 231 | (define (read-list) 232 | (let loop () 233 | (let ((e (read))) 234 | (if (not (eof-object? e)) 235 | (cons e (loop)) 236 | '() 237 | )))) 238 | 239 | (define (read-and-compile) 240 | (output-header) 241 | (let* ((ee (read-list)) 242 | (lee (lower ee))) 243 | (display (format "; ~a\n" lee)) 244 | (let ((r (compile-list lee main-list initial-environment))) 245 | (display (format 246 | "call %struct.Data* @display( %struct.Data* ~a ) \n" 247 | r)))) 248 | (output-footer)) 249 | 250 | (read-and-compile) 251 | -------------------------------------------------------------------------------- /docs/r7rs.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikea/scheme-llvm/0d580352a73ea98913363c9e996d253962ec06c9/docs/r7rs.pdf -------------------------------------------------------------------------------- /lower-tests.scm: -------------------------------------------------------------------------------- 1 | (use test) 2 | (load "lower.scm") 3 | 4 | (test-group "primitve-expr" 5 | (test "abc" (lower "abc")) 6 | (test '(12) (lower '(12)))) 7 | 8 | (test-group "define" 9 | (test '((let ((x 5)) x)) 10 | (lower '((define x 5) 11 | x))) 12 | (test '((let ((f (lambda (x) (+ 1 x)))) (f 5))) 13 | (lower '((define (f x) (+ 1 x)) 14 | (f 5)))) 15 | ) 16 | 17 | 18 | (test-exit) -------------------------------------------------------------------------------- /lower.scm: -------------------------------------------------------------------------------- 1 | ;; A module which lowers R5RS scheme into the scheme, which 2 | ;; is acceptable by compiler 3 | 4 | (define (lower-define e t) 5 | (if (pair? (cadr e)) 6 | ; (define ( ) body) 7 | (let ((var (caadr e)) 8 | (formals (cdadr e)) 9 | (body (caddr e))) 10 | (lower-define 11 | `(define ,var (lambda (,@formals) ,body)) 12 | t)) 13 | ; (define ) 14 | (let ((var (cadr e)) 15 | (expr (caddr e))) 16 | `((let ((,var ,expr)) 17 | ,@(lower t)))))) 18 | 19 | (define (lower-expr e t) 20 | (define (loop e t) 21 | (if t 22 | (cons e (lower t)) 23 | e)) 24 | (if (and (pair? e) (symbol? (car e))) 25 | (case (car e) 26 | ((define) (lower-define e t)) 27 | (else (loop e t))) 28 | (loop e t))) 29 | 30 | (define (lower e) 31 | (if (null? e) 32 | e 33 | (if (pair? e) 34 | (lower-expr (car e) (cdr e)) 35 | (lower-expr e #f)))) -------------------------------------------------------------------------------- /other_tests/r4rstest.scm: -------------------------------------------------------------------------------- 1 | ;;;;"r4rstest.scm": Test R4RS correctness of scheme implementations. 2 | ;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000, 2003, 2004, 2006, 2007 Free Software Foundation, Inc. 3 | ;; 4 | ;; This program is free software: you can redistribute it and/or modify 5 | ;; it under the terms of the GNU General Public License as 6 | ;; published by the Free Software Foundation, either version 3 of the 7 | ;; License, or (at your option) any later version. 8 | ;; 9 | ;; This program is distributed in the hope that it will be useful, but 10 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;; General Public License for more details. 13 | ;; 14 | ;; You should have received a copy of the GNU General Public 15 | ;; License along with this program. If not, see 16 | ;; . 17 | 18 | ;;;;"r4rstest.scm": Test R4RS correctness of scheme implementations. 19 | ;;; Author: Aubrey Jaffer 20 | ;;; Home-page: http://swiss.csail.mit.edu/~jaffer/Scheme 21 | ;;; Current version: http://swiss.csail.mit.edu/ftpdir/scm/r4rstest.scm 22 | ;;; CVS Head: 23 | ;;; http://savannah.gnu.org/cgi-bin/viewcvs/scm/scm/r4rstest.scm?rev=HEAD&only_with_tag=HEAD&content-type=text/vnd.viewcvs-markup 24 | 25 | ;;; This includes examples from 26 | ;;; William Clinger and Jonathan Rees, editors. 27 | ;;; Revised^4 Report on the Algorithmic Language Scheme 28 | ;;; and the IEEE specification. 29 | 30 | ;;; The input tests read this file expecting it to be named "r4rstest.scm". 31 | ;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running 32 | ;;; these tests. You may need to delete them in order to run 33 | ;;; "r4rstest.scm" more than once. 34 | 35 | ;;; There are three optional tests: 36 | ;;; (TEST-CONT) tests multiple returns from call-with-current-continuation 37 | ;;; 38 | ;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE 39 | ;;; 40 | ;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by 41 | ;;; either standard. 42 | 43 | ;;; If you are testing a R3RS version which does not have `list?' do: 44 | ;;; (define list? #f) 45 | 46 | ;;; send corrections or additions to agj @ alum.mit.edu 47 | 48 | (define cur-section '())(define errs '()) 49 | (define SECTION (lambda args 50 | (display "SECTION") (write args) (newline) 51 | (set! cur-section args) #t)) 52 | (define record-error (lambda (e) (set! errs (cons (list cur-section e) errs)))) 53 | 54 | (define test 55 | (lambda (expect fun . args) 56 | (write (cons fun args)) 57 | (display " ==> ") 58 | ((lambda (res) 59 | (write res) 60 | (newline) 61 | (cond ((not (equal? expect res)) 62 | (record-error (list res expect (cons fun args))) 63 | (display " BUT EXPECTED ") 64 | (write expect) 65 | (newline) 66 | #f) 67 | (else #t))) 68 | (if (procedure? fun) (apply fun args) (car args))))) 69 | (define (report-errs) 70 | (newline) 71 | (if (null? errs) (display "Passed all tests") 72 | (begin 73 | (display "errors were:") 74 | (newline) 75 | (display "(SECTION (got expected (call)))") 76 | (newline) 77 | (for-each (lambda (l) (write l) (newline)) 78 | errs))) 79 | (newline)) 80 | 81 | (SECTION 2 1);; test that all symbol characters are supported. 82 | '(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.) 83 | 84 | (SECTION 3 4) 85 | (define disjoint-type-functions 86 | (list boolean? char? null? number? pair? procedure? string? symbol? vector?)) 87 | (define type-examples 88 | (list 89 | #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) )) 90 | (define i 1) 91 | (for-each (lambda (x) (display (make-string i #\space)) 92 | (set! i (+ 3 i)) 93 | (write x) 94 | (newline)) 95 | disjoint-type-functions) 96 | (define type-matrix 97 | (map (lambda (x) 98 | (let ((t (map (lambda (f) (f x)) disjoint-type-functions))) 99 | (write t) 100 | (write x) 101 | (newline) 102 | t)) 103 | type-examples)) 104 | (set! i 0) 105 | (define j 0) 106 | (for-each (lambda (x y) 107 | (set! j (+ 1 j)) 108 | (set! i 0) 109 | (for-each (lambda (f) 110 | (set! i (+ 1 i)) 111 | (cond ((and (= i j)) 112 | (cond ((not (f x)) (test #t f x)))) 113 | ((f x) (test #f f x))) 114 | (cond ((and (= i j)) 115 | (cond ((not (f y)) (test #t f y)))) 116 | ((f y) (test #f f y)))) 117 | disjoint-type-functions)) 118 | (list #t #\a '() 9739 '(test) record-error "test" 'car '#(a b c)) 119 | (list #f #\newline '() -3252 '(t . t) car "" 'nil '#())) 120 | (SECTION 4 1 2) 121 | (test '(quote a) 'quote (quote 'a)) 122 | (test '(quote a) 'quote ''a) 123 | (SECTION 4 1 3) 124 | (test 12 (if #f + *) 3 4) 125 | (SECTION 4 1 4) 126 | (test 8 (lambda (x) (+ x x)) 4) 127 | (define reverse-subtract 128 | (lambda (x y) (- y x))) 129 | (test 3 reverse-subtract 7 10) 130 | (define add4 131 | (let ((x 4)) 132 | (lambda (y) (+ x y)))) 133 | (test 10 add4 6) 134 | (test '(3 4 5 6) (lambda x x) 3 4 5 6) 135 | (test '(5 6) (lambda (x y . z) z) 3 4 5 6) 136 | (SECTION 4 1 5) 137 | (test 'yes 'if (if (> 3 2) 'yes 'no)) 138 | (test 'no 'if (if (> 2 3) 'yes 'no)) 139 | (test '1 'if (if (> 3 2) (- 3 2) (+ 3 2))) 140 | (SECTION 4 1 6) 141 | (define x 2) 142 | (test 3 'define (+ x 1)) 143 | (set! x 4) 144 | (test 5 'set! (+ x 1)) 145 | (SECTION 4 2 1) 146 | (test 'greater 'cond (cond ((> 3 2) 'greater) 147 | ((< 3 2) 'less))) 148 | (test 'equal 'cond (cond ((> 3 3) 'greater) 149 | ((< 3 3) 'less) 150 | (else 'equal))) 151 | (test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr) 152 | (else #f))) 153 | (test 'composite 'case (case (* 2 3) 154 | ((2 3 5 7) 'prime) 155 | ((1 4 6 8 9) 'composite))) 156 | (test 'consonant 'case (case (car '(c d)) 157 | ((a e i o u) 'vowel) 158 | ((w y) 'semivowel) 159 | (else 'consonant))) 160 | (test #t 'and (and (= 2 2) (> 2 1))) 161 | (test #f 'and (and (= 2 2) (< 2 1))) 162 | (test '(f g) 'and (and 1 2 'c '(f g))) 163 | (test #t 'and (and)) 164 | (test #t 'or (or (= 2 2) (> 2 1))) 165 | (test #t 'or (or (= 2 2) (< 2 1))) 166 | (test #f 'or (or #f #f #f)) 167 | (test #f 'or (or)) 168 | (test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0))) 169 | (SECTION 4 2 2) 170 | (test 6 'let (let ((x 2) (y 3)) (* x y))) 171 | (test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) 172 | (test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) 173 | (test #t 'letrec (letrec ((even? 174 | (lambda (n) (if (zero? n) #t (odd? (- n 1))))) 175 | (odd? 176 | (lambda (n) (if (zero? n) #f (even? (- n 1)))))) 177 | (even? 88))) 178 | (define x 34) 179 | (test 5 'let (let ((x 3)) (define x 5) x)) 180 | (test 34 'let x) 181 | (test 6 'let (let () (define x 6) x)) 182 | (test 34 'let x) 183 | (test 34 'let (let ((x x)) x)) 184 | (test 7 'let* (let* ((x 3)) (define x 7) x)) 185 | (test 34 'let* x) 186 | (test 8 'let* (let* () (define x 8) x)) 187 | (test 34 'let* x) 188 | (test 9 'letrec (letrec () (define x 9) x)) 189 | (test 34 'letrec x) 190 | (test 10 'letrec (letrec ((x 3)) (define x 10) x)) 191 | (test 34 'letrec x) 192 | (define (s x) (if x (let () (set! s x) (set! x s)))) 193 | (SECTION 4 2 3) 194 | (define x 0) 195 | (test 6 'begin (begin (set! x (begin (begin 5))) 196 | (begin ((begin +) (begin x) (begin (begin 1)))))) 197 | (SECTION 4 2 4) 198 | (test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5)) 199 | (i 0 (+ i 1))) 200 | ((= i 5) vec) 201 | (vector-set! vec i i))) 202 | (test 25 'do (let ((x '(1 3 5 7 9))) 203 | (do ((x x (cdr x)) 204 | (sum 0 (+ sum (car x)))) 205 | ((null? x) sum)))) 206 | (test 1 'let (let foo () 1)) 207 | (test '((6 1 3) (-5 -2)) 'let 208 | (let loop ((numbers '(3 -2 1 6 -5)) 209 | (nonneg '()) 210 | (neg '())) 211 | (cond ((null? numbers) (list nonneg neg)) 212 | ((negative? (car numbers)) 213 | (loop (cdr numbers) 214 | nonneg 215 | (cons (car numbers) neg))) 216 | (else 217 | (loop (cdr numbers) 218 | (cons (car numbers) nonneg) 219 | neg))))) 220 | ;;From: Allegro Petrofsky 221 | (test -1 'let (let ((f -)) (let f ((n (f 1))) n))) 222 | 223 | (SECTION 4 2 6) 224 | (test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4)) 225 | (test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name))) 226 | (test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) 227 | (test '((foo 7) . cons) 228 | 'quasiquote 229 | `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))) 230 | 231 | ;;; sqt is defined here because not all implementations are required to 232 | ;;; support it. 233 | (define (sqt x) 234 | (do ((i 0 (+ i 1))) 235 | ((> (* i i) x) (- i 1)))) 236 | 237 | (test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8)) 238 | (test 5 'quasiquote `,(+ 2 3)) 239 | (test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) 240 | 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) 241 | (test '(a `(b ,x ,'y d) e) 'quasiquote 242 | (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e))) 243 | (test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4))) 244 | (test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4))) 245 | (SECTION 5 2 1) 246 | (define (tprint x) #t) 247 | (test #t 'tprint (tprint 56)) 248 | (define add3 (lambda (x) (+ x 3))) 249 | (test 6 'define (add3 3)) 250 | (define first car) 251 | (test 1 'define (first '(1 2))) 252 | (define foo (lambda () 9)) 253 | (test 9 'define (foo)) 254 | (define foo foo) 255 | (test 9 'define (foo)) 256 | (define foo (let ((foo foo)) (lambda () (+ 1 (foo))))) 257 | (test 10 'define (foo)) 258 | (define old-+ +) 259 | (begin (begin (begin) 260 | (begin (begin (begin) (define + (lambda (x y) (list y x))) 261 | (begin))) 262 | (begin)) 263 | (begin) 264 | (begin (begin (begin) (test '(3 6) add3 6) 265 | (begin)))) 266 | (set! + old-+) 267 | (test 9 add3 6) 268 | (begin) 269 | (begin (begin)) 270 | (begin (begin (begin (begin)))) 271 | (SECTION 5 2 2) 272 | (test 45 'define 273 | (let ((x 5)) 274 | (begin (begin (begin) 275 | (begin (begin (begin) (define foo (lambda (y) (bar x y))) 276 | (begin))) 277 | (begin)) 278 | (begin) 279 | (begin) 280 | (begin (define bar (lambda (a b) (+ (* a b) a)))) 281 | (begin)) 282 | (begin) 283 | (begin (foo (+ x 3))))) 284 | (define x 34) 285 | (define (foo) (define x 5) x) 286 | (test 5 foo) 287 | (test 34 'define x) 288 | (define foo (lambda () (define x 5) x)) 289 | (test 5 foo) 290 | (test 34 'define x) 291 | (define (foo x) ((lambda () (define x 5) x)) x) 292 | (test 88 foo 88) 293 | (test 4 foo 4) 294 | (test 34 'define x) 295 | (test 99 'internal-define (letrec ((foo (lambda (arg) 296 | (or arg (and (procedure? foo) 297 | (foo 99)))))) 298 | (define bar (foo #f)) 299 | (foo #f))) 300 | (test 77 'internal-define (letrec ((foo 77) 301 | (bar #f) 302 | (retfoo (lambda () foo))) 303 | (define baz (retfoo)) 304 | (retfoo))) 305 | (SECTION 6 1) 306 | (test #f not #t) 307 | (test #f not 3) 308 | (test #f not (list 3)) 309 | (test #t not #f) 310 | (test #f not '()) 311 | (test #f not (list)) 312 | (test #f not 'nil) 313 | 314 | ;(test #t boolean? #f) 315 | ;(test #f boolean? 0) 316 | ;(test #f boolean? '()) 317 | (SECTION 6 2) 318 | (test #t eqv? 'a 'a) 319 | (test #f eqv? 'a 'b) 320 | (test #t eqv? 2 2) 321 | (test #t eqv? '() '()) 322 | (test #t eqv? '10000 '10000) 323 | (test #f eqv? (cons 1 2)(cons 1 2)) 324 | (test #f eqv? (lambda () 1) (lambda () 2)) 325 | (test #f eqv? #f 'nil) 326 | (let ((p (lambda (x) x))) 327 | (test #t eqv? p p)) 328 | (define gen-counter 329 | (lambda () 330 | (let ((n 0)) 331 | (lambda () (set! n (+ n 1)) n)))) 332 | (let ((g (gen-counter))) (test #t eqv? g g)) 333 | (test #f eqv? (gen-counter) (gen-counter)) 334 | (letrec ((f (lambda () (if (eqv? f g) 'f 'both))) 335 | (g (lambda () (if (eqv? f g) 'g 'both)))) 336 | (test #f eqv? f g)) 337 | 338 | (test #t eq? 'a 'a) 339 | (test #f eq? (list 'a) (list 'a)) 340 | (test #t eq? '() '()) 341 | (test #t eq? car car) 342 | (let ((x '(a))) (test #t eq? x x)) 343 | (let ((x '#())) (test #t eq? x x)) 344 | (let ((x (lambda (x) x))) (test #t eq? x x)) 345 | 346 | (define test-eq?-eqv?-agreement 347 | (lambda (obj1 obj2) 348 | (cond ((eq? (eq? obj1 obj2) (eqv? obj1 obj2))) 349 | (else 350 | (record-error (list #f #t (list 'test-eq?-eqv?-agreement obj1 obj2))) 351 | (display "eqv? and eq? disagree about ") 352 | (write obj1) 353 | (display #\space) 354 | (write obj2) 355 | (newline))))) 356 | 357 | (test-eq?-eqv?-agreement '#f '#f) 358 | (test-eq?-eqv?-agreement '#t '#t) 359 | (test-eq?-eqv?-agreement '#t '#f) 360 | (test-eq?-eqv?-agreement '(a) '(a)) 361 | (test-eq?-eqv?-agreement '(a) '(b)) 362 | (test-eq?-eqv?-agreement car car) 363 | (test-eq?-eqv?-agreement car cdr) 364 | (test-eq?-eqv?-agreement (list 'a) (list 'a)) 365 | (test-eq?-eqv?-agreement (list 'a) (list 'b)) 366 | (test-eq?-eqv?-agreement '#(a) '#(a)) 367 | (test-eq?-eqv?-agreement '#(a) '#(b)) 368 | (test-eq?-eqv?-agreement "abc" "abc") 369 | (test-eq?-eqv?-agreement "abc" "abz") 370 | 371 | (test #t equal? 'a 'a) 372 | (test #t equal? '(a) '(a)) 373 | (test #t equal? '(a (b) c) '(a (b) c)) 374 | (test #t equal? "abc" "abc") 375 | (test #t equal? 2 2) 376 | (test #t equal? (make-vector 5 'a) (make-vector 5 'a)) 377 | (SECTION 6 3) 378 | (test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ())))))) 379 | (define x (list 'a 'b 'c)) 380 | (define y x) 381 | (and list? (test #t list? y)) 382 | (set-cdr! x 4) 383 | (test '(a . 4) 'set-cdr! x) 384 | (test #t eqv? x y) 385 | (test '(a b c . d) 'dot '(a . (b . (c . d)))) 386 | (and list? (test #f list? y)) 387 | (and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x)))) 388 | 389 | ;(test #t pair? '(a . b)) 390 | ;(test #t pair? '(a . 1)) 391 | ;(test #t pair? '(a b c)) 392 | ;(test #f pair? '()) 393 | ;(test #f pair? '#(a b)) 394 | 395 | (test '(a) cons 'a '()) 396 | (test '((a) b c d) cons '(a) '(b c d)) 397 | (test '("a" b c) cons "a" '(b c)) 398 | (test '(a . 3) cons 'a 3) 399 | (test '((a b) . c) cons '(a b) 'c) 400 | 401 | (test 'a car '(a b c)) 402 | (test '(a) car '((a) b c d)) 403 | (test 1 car '(1 . 2)) 404 | 405 | (test '(b c d) cdr '((a) b c d)) 406 | (test 2 cdr '(1 . 2)) 407 | 408 | (test '(a 7 c) list 'a (+ 3 4) 'c) 409 | (test '() list) 410 | 411 | (test 3 length '(a b c)) 412 | (test 3 length '(a (b) (c d e))) 413 | (test 0 length '()) 414 | 415 | (test '(x y) append '(x) '(y)) 416 | (test '(a b c d) append '(a) '(b c d)) 417 | (test '(a (b) (c)) append '(a (b)) '((c))) 418 | (test '() append) 419 | (test '(a b c . d) append '(a b) '(c . d)) 420 | (test 'a append '() 'a) 421 | 422 | (test '(c b a) reverse '(a b c)) 423 | (test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f)))) 424 | 425 | (test 'c list-ref '(a b c d) 2) 426 | 427 | (test '(a b c) memq 'a '(a b c)) 428 | (test '(b c) memq 'b '(a b c)) 429 | (test '#f memq 'a '(b c d)) 430 | (test '#f memq (list 'a) '(b (a) c)) 431 | (test '((a) c) member (list 'a) '(b (a) c)) 432 | (test '(101 102) memv 101 '(100 101 102)) 433 | 434 | (define e '((a 1) (b 2) (c 3))) 435 | (test '(a 1) assq 'a e) 436 | (test '(b 2) assq 'b e) 437 | (test #f assq 'd e) 438 | (test #f assq (list 'a) '(((a)) ((b)) ((c)))) 439 | (test '((a)) assoc (list 'a) '(((a)) ((b)) ((c)))) 440 | (test '(5 7) assv 5 '((2 3) (5 7) (11 13))) 441 | (SECTION 6 4) 442 | ;(test #t symbol? 'foo) 443 | (test #t symbol? (car '(a b))) 444 | ;(test #f symbol? "bar") 445 | ;(test #t symbol? 'nil) 446 | ;(test #f symbol? '()) 447 | ;(test #f symbol? #f) 448 | ;;; But first, what case are symbols in? Determine the standard case: 449 | (define char-standard-case char-upcase) 450 | (if (string=? (symbol->string 'A) "a") 451 | (set! char-standard-case char-downcase)) 452 | (test #t 'standard-case 453 | (string=? (symbol->string 'a) (symbol->string 'A))) 454 | (test #t 'standard-case 455 | (or (string=? (symbol->string 'a) "A") 456 | (string=? (symbol->string 'A) "a"))) 457 | (define (str-copy s) 458 | (let ((v (make-string (string-length s)))) 459 | (do ((i (- (string-length v) 1) (- i 1))) 460 | ((< i 0) v) 461 | (string-set! v i (string-ref s i))))) 462 | (define (string-standard-case s) 463 | (set! s (str-copy s)) 464 | (do ((i 0 (+ 1 i)) 465 | (sl (string-length s))) 466 | ((>= i sl) s) 467 | (string-set! s i (char-standard-case (string-ref s i))))) 468 | (test (string-standard-case "flying-fish") symbol->string 'flying-fish) 469 | (test (string-standard-case "martin") symbol->string 'Martin) 470 | (test "Malvina" symbol->string (string->symbol "Malvina")) 471 | (test #t 'standard-case (eq? 'a 'A)) 472 | 473 | (define x (string #\a #\b)) 474 | (define y (string->symbol x)) 475 | (string-set! x 0 #\c) 476 | (test "cb" 'string-set! x) 477 | (test "ab" symbol->string y) 478 | (test y string->symbol "ab") 479 | 480 | (test #t eq? 'mISSISSIppi 'mississippi) 481 | (test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt"))) 482 | (test 'JollyWog string->symbol (symbol->string 'JollyWog)) 483 | 484 | (SECTION 6 5 5) 485 | (test #t number? 3) 486 | (test #t complex? 3) 487 | (test #t real? 3) 488 | (test #t rational? 3) 489 | (test #t integer? 3) 490 | 491 | (test #t exact? 3) 492 | (test #f inexact? 3) 493 | 494 | (test 1 expt 0 0) 495 | (test 0 expt 0 1) 496 | (test 0 expt 0 256) 497 | ;;(test 0 expt 0 -255) 498 | (test 1 expt -1 256) 499 | (test -1 expt -1 255) 500 | (test 1 expt -1 -256) 501 | (test -1 expt -1 -255) 502 | (test 1 expt 256 0) 503 | (test 1 expt -256 0) 504 | (test 256 expt 256 1) 505 | (test -256 expt -256 1) 506 | (test 8 expt 2 3) 507 | (test -8 expt -2 3) 508 | (test 9 expt 3 2) 509 | (test 9 expt -3 2) 510 | 511 | (test #t = 22 22 22) 512 | (test #t = 22 22) 513 | (test #f = 34 34 35) 514 | (test #f = 34 35) 515 | (test #t > 3 -6246) 516 | (test #f > 9 9 -2424) 517 | (test #t >= 3 -4 -6246) 518 | (test #t >= 9 9) 519 | (test #f >= 8 9) 520 | (test #t < -1 2 3 4 5 6 7 8) 521 | (test #f < -1 2 3 4 4 5 6 7) 522 | (test #t <= -1 2 3 4 5 6 7 8) 523 | (test #t <= -1 2 3 4 4 5 6 7) 524 | (test #f < 1 3 2) 525 | (test #f >= 1 3 2) 526 | 527 | (test #t zero? 0) 528 | (test #f zero? 1) 529 | (test #f zero? -1) 530 | (test #f zero? -100) 531 | (test #t positive? 4) 532 | (test #f positive? -4) 533 | (test #f positive? 0) 534 | (test #f negative? 4) 535 | (test #t negative? -4) 536 | (test #f negative? 0) 537 | (test #t odd? 3) 538 | (test #f odd? 2) 539 | (test #f odd? -4) 540 | (test #t odd? -1) 541 | (test #f even? 3) 542 | (test #t even? 2) 543 | (test #t even? -4) 544 | (test #f even? -1) 545 | 546 | (test 38 max 34 5 7 38 6) 547 | (test -24 min 3 5 5 330 4 -24) 548 | 549 | (test 7 + 3 4) 550 | (test '3 + 3) 551 | (test 0 +) 552 | (test 4 * 4) 553 | (test 1 *) 554 | 555 | (test -1 - 3 4) 556 | (test -3 - 3) 557 | (test 7 abs -7) 558 | (test 7 abs 7) 559 | (test 0 abs 0) 560 | 561 | (test 5 quotient 35 7) 562 | (test -5 quotient -35 7) 563 | (test -5 quotient 35 -7) 564 | (test 5 quotient -35 -7) 565 | (test 1 modulo 13 4) 566 | (test 1 remainder 13 4) 567 | (test 3 modulo -13 4) 568 | (test -1 remainder -13 4) 569 | (test -3 modulo 13 -4) 570 | (test 1 remainder 13 -4) 571 | (test -1 modulo -13 -4) 572 | (test -1 remainder -13 -4) 573 | (test 0 modulo 0 86400) 574 | (test 0 modulo 0 -86400) 575 | (define (divtest n1 n2) 576 | (= n1 (+ (* n2 (quotient n1 n2)) 577 | (remainder n1 n2)))) 578 | (test #t divtest 238 9) 579 | (test #t divtest -238 9) 580 | (test #t divtest 238 -9) 581 | (test #t divtest -238 -9) 582 | 583 | (test 4 gcd 0 4) 584 | (test 4 gcd -4 0) 585 | (test 4 gcd 32 -36) 586 | (test 0 gcd) 587 | (test 288 lcm 32 -36) 588 | (test 1 lcm) 589 | 590 | (SECTION 6 5 5) 591 | ;;; Implementations which don't allow division by 0 can have fragile 592 | ;;; string->number. 593 | (define (test-string->number str) 594 | (define ans (string->number str)) 595 | (cond ((not ans) #t) ((number? ans) #t) (else ans))) 596 | (for-each (lambda (str) (test #t test-string->number str)) 597 | '("+#.#" "-#.#" "#.#" "1/0" "-1/0" "0/0" 598 | "+1/0i" "-1/0i" "0/0i" "0/0-0/0i" "1/0-1/0i" "-1/0+1/0i" 599 | "#i" "#e" "#" "#i0/0")) 600 | (cond ((number? (string->number "1+1i")) ;More kawa bait 601 | (test #t number? (string->number "#i-i")) 602 | (test #t number? (string->number "#i+i")) 603 | (test #t number? (string->number "#i2+i")))) 604 | 605 | ;;;;From: fred@sce.carleton.ca (Fred J Kaudel) 606 | ;;; Modified by jaffer. 607 | (define (test-inexact) 608 | (define f3.9 (string->number "3.9")) 609 | (define f4.0 (string->number "4.0")) 610 | (define f-3.25 (string->number "-3.25")) 611 | (define f.25 (string->number ".25")) 612 | (define f4.5 (string->number "4.5")) 613 | (define f3.5 (string->number "3.5")) 614 | (define f0.0 (string->number "0.0")) 615 | (define f0.8 (string->number "0.8")) 616 | (define f1.0 (string->number "1.0")) 617 | (define f1e300 (and (string->number "1+3i") (string->number "1e300"))) 618 | (define f1e-300 (and (string->number "1+3i") (string->number "1e-300"))) 619 | (define wto write-test-obj) 620 | (define lto load-test-obj) 621 | (newline) 622 | (display ";testing inexact numbers; ") 623 | (newline) 624 | (SECTION 6 2) 625 | (test #f eqv? 1 f1.0) 626 | (test #f eqv? 0 f0.0) 627 | (test #t eqv? f0.0 f0.0) 628 | (cond ((= f0.0 (- f0.0)) 629 | (test #t eqv? f0.0 (- f0.0)) 630 | (test #t equal? f0.0 (- f0.0)))) 631 | (cond ((= f0.0 (* -5 f0.0)) 632 | (test #t eqv? f0.0 (* -5 f0.0)) 633 | (test #t equal? f0.0 (* -5 f0.0)))) 634 | (SECTION 6 5 5) 635 | (and f1e300 636 | (let ((f1e300+1e300i (make-rectangular f1e300 f1e300))) 637 | (test f1.0 'magnitude (/ (magnitude f1e300+1e300i) 638 | (* f1e300 (sqrt 2)))) 639 | (test f.25 / f1e300+1e300i (* 4 f1e300+1e300i)))) 640 | (and f1e-300 641 | (let ((f1e-300+1e-300i (make-rectangular f1e-300 f1e-300))) 642 | (test f1.0 'magnitude (round (/ (magnitude f1e-300+1e-300i) 643 | (* f1e-300 (sqrt 2))))) 644 | (test f.25 / f1e-300+1e-300i (* 4 f1e-300+1e-300i)))) 645 | (test #t = f0.0 f0.0) 646 | (test #t = f0.0 (- f0.0)) 647 | (test #t = f0.0 (* -5 f0.0)) 648 | (test #t inexact? f3.9) 649 | (test #t 'max (inexact? (max f3.9 4))) 650 | (test f4.0 max f3.9 4) 651 | (test f4.0 exact->inexact 4) 652 | (test f4.0 exact->inexact 4.0) 653 | (test 4 inexact->exact 4) 654 | (test 4 inexact->exact 4.0) 655 | (test (- f4.0) round (- f4.5)) 656 | (test (- f4.0) round (- f3.5)) 657 | (test (- f4.0) round (- f3.9)) 658 | (test f0.0 round f0.0) 659 | (test f0.0 round f.25) 660 | (test f1.0 round f0.8) 661 | (test f4.0 round f3.5) 662 | (test f4.0 round f4.5) 663 | 664 | ;;(test f1.0 expt f0.0 f0.0) 665 | ;;(test f1.0 expt f0.0 0) 666 | ;;(test f1.0 expt 0 f0.0) 667 | (test f0.0 expt f0.0 f1.0) 668 | (test f0.0 expt f0.0 1) 669 | (test f0.0 expt 0 f1.0) 670 | (test f1.0 expt -25 f0.0) 671 | (test f1.0 expt f-3.25 f0.0) 672 | (test f1.0 expt f-3.25 0) 673 | ;;(test f0.0 expt f0.0 f-3.25) 674 | 675 | (test (atan 1) atan 1 1) 676 | (set! write-test-obj (list f.25 f-3.25)) ;.25 inexact errors less likely. 677 | (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj))) 678 | (test #t call-with-output-file 679 | "tmp3" 680 | (lambda (test-file) 681 | (write-char #\; test-file) 682 | (display #\; test-file) 683 | (display ";" test-file) 684 | (write write-test-obj test-file) 685 | (newline test-file) 686 | (write load-test-obj test-file) 687 | (output-port? test-file))) 688 | (check-test-file "tmp3") 689 | (set! write-test-obj wto) 690 | (set! load-test-obj lto) 691 | (let ((x (string->number "4195835.0")) 692 | (y (string->number "3145727.0"))) 693 | (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y))))) 694 | (report-errs)) 695 | 696 | (define (test-inexact-printing) 697 | (let ((f0.0 (string->number "0.0")) 698 | (f0.5 (string->number "0.5")) 699 | (f1.0 (string->number "1.0")) 700 | (f2.0 (string->number "2.0"))) 701 | (define log2 702 | (let ((l2 (log 2))) 703 | (lambda (x) (/ (log x) l2)))) 704 | 705 | (define (slow-frexp x) 706 | (if (zero? x) 707 | (list f0.0 0) 708 | (let* ((l2 (log2 x)) 709 | (e (floor (log2 x))) 710 | (e (if (= l2 e) 711 | (inexact->exact e) 712 | (+ (inexact->exact e) 1))) 713 | (f (/ x (expt 2 e)))) 714 | (list f e)))) 715 | 716 | (define float-precision 717 | (let ((mantissa-bits 718 | (do ((i 0 (+ i 1)) 719 | (eps f1.0 (* f0.5 eps))) 720 | ((= f1.0 (+ f1.0 eps)) 721 | i))) 722 | (minval 723 | (do ((x f1.0 (* f0.5 x))) 724 | ((zero? (* f0.5 x)) x)))) 725 | (lambda (x) 726 | (apply (lambda (f e) 727 | (let ((eps 728 | (cond ((= f1.0 f) (expt f2.0 (+ 1 (- e mantissa-bits)))) 729 | ((zero? f) minval) 730 | (else (expt f2.0 (- e mantissa-bits)))))) 731 | (if (zero? eps) ;Happens if gradual underflow. 732 | minval 733 | eps))) 734 | (slow-frexp x))))) 735 | 736 | (define (float-print-test x) 737 | (define (testit number) 738 | (eqv? number (string->number (number->string number)))) 739 | (let ((eps (float-precision x)) 740 | (all-ok? #t)) 741 | (do ((j -100 (+ j 1))) 742 | ((or (not all-ok?) (> j 100)) all-ok?) 743 | (let* ((xx (+ x (* j eps))) 744 | (ok? (testit xx))) 745 | (cond ((not ok?) 746 | (display "Number readback failure for ") 747 | (display `(+ ,x (* ,j ,eps))) 748 | (newline) 749 | (display xx) 750 | (newline) 751 | (set! all-ok? #f)) 752 | ;; (else (display xx) (newline)) 753 | ))))) 754 | 755 | (define (mult-float-print-test x) 756 | (let ((res #t)) 757 | (for-each 758 | (lambda (mult) 759 | (or (float-print-test (* mult x)) (set! res #f))) 760 | (map string->number 761 | '("1.0" "10.0" "100.0" "1.0e20" "1.0e50" "1.0e100" 762 | "0.1" "0.01" "0.001" "1.0e-20" "1.0e-50" "1.0e-100"))) 763 | res)) 764 | 765 | (SECTION 6 5 6) 766 | (test #t 'float-print-test (float-print-test f0.0)) 767 | (test #t 'mult-float-print-test (mult-float-print-test f1.0)) 768 | (test #t 'mult-float-print-test (mult-float-print-test 769 | (string->number "3.0"))) 770 | (test #t 'mult-float-print-test (mult-float-print-test 771 | (string->number "7.0"))) 772 | (test #t 'mult-float-print-test (mult-float-print-test 773 | (string->number "3.1415926535897931"))) 774 | (test #t 'mult-float-print-test (mult-float-print-test 775 | (string->number "2.7182818284590451"))))) 776 | 777 | (define (test-bignum) 778 | (define tb 779 | (lambda (n1 n2) 780 | (= n1 (+ (* n2 (quotient n1 n2)) 781 | (remainder n1 n2))))) 782 | (define b3-3 (string->number "33333333333333333333")) 783 | (define b3-2 (string->number "33333333333333333332")) 784 | (define b3-0 (string->number "33333333333333333330")) 785 | (define b2-0 (string->number "2177452800")) 786 | (newline) 787 | (display ";testing bignums; ") 788 | (newline) 789 | (SECTION 6 5 7) 790 | (test 0 modulo b3-3 3) 791 | (test 0 modulo b3-3 -3) 792 | (test 0 remainder b3-3 3) 793 | (test 0 remainder b3-3 -3) 794 | (test 2 modulo b3-2 3) 795 | (test -1 modulo b3-2 -3) 796 | (test 2 remainder b3-2 3) 797 | (test 2 remainder b3-2 -3) 798 | (test 1 modulo (- b3-2) 3) 799 | (test -2 modulo (- b3-2) -3) 800 | (test -2 remainder (- b3-2) 3) 801 | (test -2 remainder (- b3-2) -3) 802 | 803 | (test 3 modulo 3 b3-3) 804 | (test b3-0 modulo -3 b3-3) 805 | (test 3 remainder 3 b3-3) 806 | (test -3 remainder -3 b3-3) 807 | (test (- b3-0) modulo 3 (- b3-3)) 808 | (test -3 modulo -3 (- b3-3)) 809 | (test 3 remainder 3 (- b3-3)) 810 | (test -3 remainder -3 (- b3-3)) 811 | 812 | (test 0 modulo (- b2-0) 86400) 813 | (test 0 modulo b2-0 -86400) 814 | (test 0 modulo b2-0 86400) 815 | (test 0 modulo (- b2-0) -86400) 816 | (test 0 modulo 0 (- b2-0)) 817 | (test #t 'remainder (tb (string->number "281474976710655325431") 65535)) 818 | (test #t 'remainder (tb (string->number "281474976710655325430") 65535)) 819 | 820 | (let ((n (string->number 821 | "30414093201713378043612608166064768844377641568960512"))) 822 | (and n (exact? n) 823 | (do ((pow3 1 (* 3 pow3)) 824 | (cnt 21 (+ -1 cnt))) 825 | ((negative? cnt) 826 | (zero? (modulo n pow3)))))) 827 | 828 | (SECTION 6 5 8) 829 | (test "281474976710655325431" number->string 830 | (string->number "281474976710655325431")) 831 | (report-errs)) 832 | 833 | (define (test-numeric-predicates) 834 | (let* ((big-ex (expt 2 150)) 835 | (big-inex (exact->inexact big-ex))) 836 | (newline) 837 | (display ";testing bignum-inexact comparisons;") 838 | (newline) 839 | (SECTION 6 5 5) 840 | (test #f = (+ big-ex 1) big-inex (- big-ex 1)) 841 | (test #f = big-inex (+ big-ex 1) (- big-ex 1)) 842 | (test #t < (- (inexact->exact big-inex) 1) 843 | big-inex 844 | (+ (inexact->exact big-inex) 1)))) 845 | 846 | 847 | (SECTION 6 5 9) 848 | (test "0" number->string 0) 849 | (test "100" number->string 100) 850 | (test "100" number->string 256 16) 851 | (test 100 string->number "100") 852 | (test 256 string->number "100" 16) 853 | (test #f string->number "") 854 | (test #f string->number ".") 855 | (test #f string->number "d") 856 | (test #f string->number "D") 857 | (test #f string->number "i") 858 | (test #f string->number "I") 859 | (test #f string->number "3i") 860 | (test #f string->number "3I") 861 | (test #f string->number "33i") 862 | (test #f string->number "33I") 863 | (test #f string->number "3.3i") 864 | (test #f string->number "3.3I") 865 | (test #f string->number "-") 866 | (test #f string->number "+") 867 | (test #t 'string->number (or (not (string->number "80000000" 16)) 868 | (positive? (string->number "80000000" 16)))) 869 | (test #t 'string->number (or (not (string->number "-80000000" 16)) 870 | (negative? (string->number "-80000000" 16)))) 871 | 872 | (SECTION 6 6) 873 | (test #t eqv? '#\ #\Space) 874 | (test #t eqv? #\space '#\Space) 875 | (test #t char? #\a) 876 | (test #t char? #\() 877 | (test #t char? #\space) 878 | (test #t char? '#\newline) 879 | 880 | (test #f char=? #\A #\B) 881 | (test #f char=? #\a #\b) 882 | (test #f char=? #\9 #\0) 883 | (test #t char=? #\A #\A) 884 | 885 | (test #t char? #\A #\B) 891 | (test #f char>? #\a #\b) 892 | (test #t char>? #\9 #\0) 893 | (test #f char>? #\A #\A) 894 | 895 | (test #t char<=? #\A #\B) 896 | (test #t char<=? #\a #\b) 897 | (test #f char<=? #\9 #\0) 898 | (test #t char<=? #\A #\A) 899 | 900 | (test #f char>=? #\A #\B) 901 | (test #f char>=? #\a #\b) 902 | (test #t char>=? #\9 #\0) 903 | (test #t char>=? #\A #\A) 904 | 905 | (test #f char-ci=? #\A #\B) 906 | (test #f char-ci=? #\a #\B) 907 | (test #f char-ci=? #\A #\b) 908 | (test #f char-ci=? #\a #\b) 909 | (test #f char-ci=? #\9 #\0) 910 | (test #t char-ci=? #\A #\A) 911 | (test #t char-ci=? #\A #\a) 912 | 913 | (test #t char-ci? #\A #\B) 922 | (test #f char-ci>? #\a #\B) 923 | (test #f char-ci>? #\A #\b) 924 | (test #f char-ci>? #\a #\b) 925 | (test #t char-ci>? #\9 #\0) 926 | (test #f char-ci>? #\A #\A) 927 | (test #f char-ci>? #\A #\a) 928 | 929 | (test #t char-ci<=? #\A #\B) 930 | (test #t char-ci<=? #\a #\B) 931 | (test #t char-ci<=? #\A #\b) 932 | (test #t char-ci<=? #\a #\b) 933 | (test #f char-ci<=? #\9 #\0) 934 | (test #t char-ci<=? #\A #\A) 935 | (test #t char-ci<=? #\A #\a) 936 | 937 | (test #f char-ci>=? #\A #\B) 938 | (test #f char-ci>=? #\a #\B) 939 | (test #f char-ci>=? #\A #\b) 940 | (test #f char-ci>=? #\a #\b) 941 | (test #t char-ci>=? #\9 #\0) 942 | (test #t char-ci>=? #\A #\A) 943 | (test #t char-ci>=? #\A #\a) 944 | 945 | (test #t char-alphabetic? #\a) 946 | (test #t char-alphabetic? #\A) 947 | (test #t char-alphabetic? #\z) 948 | (test #t char-alphabetic? #\Z) 949 | (test #f char-alphabetic? #\0) 950 | (test #f char-alphabetic? #\9) 951 | (test #f char-alphabetic? #\space) 952 | (test #f char-alphabetic? #\;) 953 | 954 | (test #f char-numeric? #\a) 955 | (test #f char-numeric? #\A) 956 | (test #f char-numeric? #\z) 957 | (test #f char-numeric? #\Z) 958 | (test #t char-numeric? #\0) 959 | (test #t char-numeric? #\9) 960 | (test #f char-numeric? #\space) 961 | (test #f char-numeric? #\;) 962 | 963 | (test #f char-whitespace? #\a) 964 | (test #f char-whitespace? #\A) 965 | (test #f char-whitespace? #\z) 966 | (test #f char-whitespace? #\Z) 967 | (test #f char-whitespace? #\0) 968 | (test #f char-whitespace? #\9) 969 | (test #t char-whitespace? #\space) 970 | (test #f char-whitespace? #\;) 971 | 972 | (test #f char-upper-case? #\0) 973 | (test #f char-upper-case? #\9) 974 | (test #f char-upper-case? #\space) 975 | (test #f char-upper-case? #\;) 976 | 977 | (test #f char-lower-case? #\0) 978 | (test #f char-lower-case? #\9) 979 | (test #f char-lower-case? #\space) 980 | (test #f char-lower-case? #\;) 981 | 982 | (test #\. integer->char (char->integer #\.)) 983 | (test #\A integer->char (char->integer #\A)) 984 | (test #\a integer->char (char->integer #\a)) 985 | (test #\A char-upcase #\A) 986 | (test #\A char-upcase #\a) 987 | (test #\a char-downcase #\A) 988 | (test #\a char-downcase #\a) 989 | (SECTION 6 7) 990 | (test #t string? "The word \"recursion\\\" has many meanings.") 991 | ;(test #t string? "") 992 | (define f (make-string 3 #\*)) 993 | (test "?**" 'string-set! (begin (string-set! f 0 #\?) f)) 994 | (test "abc" string #\a #\b #\c) 995 | (test "" string) 996 | (test 3 string-length "abc") 997 | (test #\a string-ref "abc" 0) 998 | (test #\c string-ref "abc" 2) 999 | (test 0 string-length "") 1000 | (test "" substring "ab" 0 0) 1001 | (test "" substring "ab" 1 1) 1002 | (test "" substring "ab" 2 2) 1003 | (test "a" substring "ab" 0 1) 1004 | (test "b" substring "ab" 1 2) 1005 | (test "ab" substring "ab" 0 2) 1006 | (test "foobar" string-append "foo" "bar") 1007 | (test "foo" string-append "foo") 1008 | (test "foo" string-append "foo" "") 1009 | (test "foo" string-append "" "foo") 1010 | (test "" string-append) 1011 | (test "" make-string 0) 1012 | (test #t string=? "" "") 1013 | (test #f string? "" "") 1015 | (test #t string<=? "" "") 1016 | (test #t string>=? "" "") 1017 | (test #t string-ci=? "" "") 1018 | (test #f string-ci? "" "") 1020 | (test #t string-ci<=? "" "") 1021 | (test #t string-ci>=? "" "") 1022 | 1023 | (test #f string=? "A" "B") 1024 | (test #f string=? "a" "b") 1025 | (test #f string=? "9" "0") 1026 | (test #t string=? "A" "A") 1027 | 1028 | (test #t string? "A" "B") 1034 | (test #f string>? "a" "b") 1035 | (test #t string>? "9" "0") 1036 | (test #f string>? "A" "A") 1037 | 1038 | (test #t string<=? "A" "B") 1039 | (test #t string<=? "a" "b") 1040 | (test #f string<=? "9" "0") 1041 | (test #t string<=? "A" "A") 1042 | 1043 | (test #f string>=? "A" "B") 1044 | (test #f string>=? "a" "b") 1045 | (test #t string>=? "9" "0") 1046 | (test #t string>=? "A" "A") 1047 | 1048 | (test #f string-ci=? "A" "B") 1049 | (test #f string-ci=? "a" "B") 1050 | (test #f string-ci=? "A" "b") 1051 | (test #f string-ci=? "a" "b") 1052 | (test #f string-ci=? "9" "0") 1053 | (test #t string-ci=? "A" "A") 1054 | (test #t string-ci=? "A" "a") 1055 | 1056 | (test #t string-ci? "A" "B") 1065 | (test #f string-ci>? "a" "B") 1066 | (test #f string-ci>? "A" "b") 1067 | (test #f string-ci>? "a" "b") 1068 | (test #t string-ci>? "9" "0") 1069 | (test #f string-ci>? "A" "A") 1070 | (test #f string-ci>? "A" "a") 1071 | 1072 | (test #t string-ci<=? "A" "B") 1073 | (test #t string-ci<=? "a" "B") 1074 | (test #t string-ci<=? "A" "b") 1075 | (test #t string-ci<=? "a" "b") 1076 | (test #f string-ci<=? "9" "0") 1077 | (test #t string-ci<=? "A" "A") 1078 | (test #t string-ci<=? "A" "a") 1079 | 1080 | (test #f string-ci>=? "A" "B") 1081 | (test #f string-ci>=? "a" "B") 1082 | (test #f string-ci>=? "A" "b") 1083 | (test #f string-ci>=? "a" "b") 1084 | (test #t string-ci>=? "9" "0") 1085 | (test #t string-ci>=? "A" "A") 1086 | (test #t string-ci>=? "A" "a") 1087 | (SECTION 6 8) 1088 | (test #t vector? '#(0 (2 2 2 2) "Anna")) 1089 | ;(test #t vector? '#()) 1090 | (test '#(a b c) vector 'a 'b 'c) 1091 | (test '#() vector) 1092 | (test 3 vector-length '#(0 (2 2 2 2) "Anna")) 1093 | (test 0 vector-length '#()) 1094 | (test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5) 1095 | (test '#(0 ("Sue" "Sue") "Anna") 'vector-set 1096 | (let ((vec (vector 0 '(2 2 2 2) "Anna"))) 1097 | (vector-set! vec 1 '("Sue" "Sue")) 1098 | vec)) 1099 | (test '#(hi hi) make-vector 2 'hi) 1100 | (test '#() make-vector 0) 1101 | (test '#() make-vector 0 'a) 1102 | (SECTION 6 9) 1103 | (test #t procedure? car) 1104 | ;(test #f procedure? 'car) 1105 | (test #t procedure? (lambda (x) (* x x))) 1106 | (test #f procedure? '(lambda (x) (* x x))) 1107 | (test #t call-with-current-continuation procedure?) 1108 | (test 7 apply + (list 3 4)) 1109 | (test 7 apply (lambda (a b) (+ a b)) (list 3 4)) 1110 | (test 17 apply + 10 (list 3 4)) 1111 | (test '() apply list '()) 1112 | (define compose (lambda (f g) (lambda args (f (apply g args))))) 1113 | (test 30 (compose sqt *) 12 75) 1114 | 1115 | (test '(b e h) map cadr '((a b) (d e) (g h))) 1116 | (test '(5 7 9) map + '(1 2 3) '(4 5 6)) 1117 | (test '(1 2 3) map + '(1 2 3)) 1118 | (test '(1 2 3) map * '(1 2 3)) 1119 | (test '(-1 -2 -3) map - '(1 2 3)) 1120 | (test '#(0 1 4 9 16) 'for-each 1121 | (let ((v (make-vector 5))) 1122 | (for-each (lambda (i) (vector-set! v i (* i i))) 1123 | '(0 1 2 3 4)) 1124 | v)) 1125 | (test -3 call-with-current-continuation 1126 | (lambda (exit) 1127 | (for-each (lambda (x) (if (negative? x) (exit x))) 1128 | '(54 0 37 -3 245 19)) 1129 | #t)) 1130 | (define list-length 1131 | (lambda (obj) 1132 | (call-with-current-continuation 1133 | (lambda (return) 1134 | (letrec ((r (lambda (obj) (cond ((null? obj) 0) 1135 | ((pair? obj) (+ (r (cdr obj)) 1)) 1136 | (else (return #f)))))) 1137 | (r obj)))))) 1138 | (test 4 list-length '(1 2 3 4)) 1139 | (test #f list-length '(a b . c)) 1140 | (test '() map cadr '()) 1141 | 1142 | ;;; This tests full conformance of call-with-current-continuation. It 1143 | ;;; is a separate test because some schemes do not support call/cc 1144 | ;;; other than escape procedures. I am indebted to 1145 | ;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this 1146 | ;;; code. The function leaf-eq? compares the leaves of 2 arbitrary 1147 | ;;; trees constructed of conses. 1148 | (define (next-leaf-generator obj eot) 1149 | (letrec ((return #f) 1150 | (cont (lambda (x) 1151 | (recur obj) 1152 | (set! cont (lambda (x) (return eot))) 1153 | (cont #f))) 1154 | (recur (lambda (obj) 1155 | (if (pair? obj) 1156 | (for-each recur obj) 1157 | (call-with-current-continuation 1158 | (lambda (c) 1159 | (set! cont c) 1160 | (return obj))))))) 1161 | (lambda () (call-with-current-continuation 1162 | (lambda (ret) (set! return ret) (cont #f)))))) 1163 | (define (leaf-eq? x y) 1164 | (let* ((eot (list 'eot)) 1165 | (xf (next-leaf-generator x eot)) 1166 | (yf (next-leaf-generator y eot))) 1167 | (letrec ((loop (lambda (x y) 1168 | (cond ((not (eq? x y)) #f) 1169 | ((eq? eot x) #t) 1170 | (else (loop (xf) (yf))))))) 1171 | (loop (xf) (yf))))) 1172 | (define (test-cont) 1173 | (newline) 1174 | (display ";testing continuations; ") 1175 | (newline) 1176 | (SECTION 6 9) 1177 | (test #t leaf-eq? '(a (b (c))) '((a) b c)) 1178 | (test #f leaf-eq? '(a (b (c))) '((a) b c d)) 1179 | (report-errs)) 1180 | 1181 | ;;; Test Optional R4RS DELAY syntax and FORCE procedure 1182 | (define (test-delay) 1183 | (newline) 1184 | (display ";testing DELAY and FORCE; ") 1185 | (newline) 1186 | (SECTION 6 9) 1187 | (test 3 'delay (force (delay (+ 1 2)))) 1188 | (test '(3 3) 'delay (let ((p (delay (+ 1 2)))) 1189 | (list (force p) (force p)))) 1190 | (test 2 'delay (letrec ((a-stream 1191 | (letrec ((next (lambda (n) 1192 | (cons n (delay (next (+ n 1))))))) 1193 | (next 0))) 1194 | (head car) 1195 | (tail (lambda (stream) (force (cdr stream))))) 1196 | (head (tail (tail a-stream))))) 1197 | (letrec ((count 0) 1198 | (p (delay (begin (set! count (+ count 1)) 1199 | (if (> count x) 1200 | count 1201 | (force p))))) 1202 | (x 5)) 1203 | (test 6 force p) 1204 | (set! x 10) 1205 | (test 6 force p)) 1206 | (test 3 'force 1207 | (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1))))) 1208 | (c #f)) 1209 | (force p))) 1210 | (report-errs)) 1211 | 1212 | (SECTION 6 10 1) 1213 | (test #t input-port? (current-input-port)) 1214 | (test #t output-port? (current-output-port)) 1215 | (test #t call-with-input-file "r4rstest.scm" input-port?) 1216 | (define this-file (open-input-file "r4rstest.scm")) 1217 | (test #t input-port? this-file) 1218 | (SECTION 6 10 2) 1219 | (test #\; peek-char this-file) 1220 | (test #\; read-char this-file) 1221 | (test '(define cur-section '()) read this-file) 1222 | (test #\( peek-char this-file) 1223 | (test '(define errs '()) read this-file) 1224 | (close-input-port this-file) 1225 | (close-input-port this-file) 1226 | (define (check-test-file name) 1227 | (define test-file (open-input-file name)) 1228 | (test #t 'input-port? 1229 | (call-with-input-file 1230 | name 1231 | (lambda (test-file) 1232 | (test load-test-obj read test-file) 1233 | (test #t eof-object? (peek-char test-file)) 1234 | (test #t eof-object? (read-char test-file)) 1235 | (input-port? test-file)))) 1236 | (test #\; read-char test-file) 1237 | (test #\; read-char test-file) 1238 | (test #\; read-char test-file) 1239 | (test write-test-obj read test-file) 1240 | (test load-test-obj read test-file) 1241 | (close-input-port test-file)) 1242 | (SECTION 6 10 3) 1243 | (define write-test-obj 1244 | '(#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) 1245 | (define load-test-obj 1246 | (list 'define 'foo (list 'quote write-test-obj))) 1247 | (test #t call-with-output-file 1248 | "tmp1" 1249 | (lambda (test-file) 1250 | (write-char #\; test-file) 1251 | (display #\; test-file) 1252 | (display ";" test-file) 1253 | (write write-test-obj test-file) 1254 | (newline test-file) 1255 | (write load-test-obj test-file) 1256 | (output-port? test-file))) 1257 | (check-test-file "tmp1") 1258 | 1259 | (define test-file (open-output-file "tmp2")) 1260 | (write-char #\; test-file) 1261 | (display #\; test-file) 1262 | (display ";" test-file) 1263 | (write write-test-obj test-file) 1264 | (newline test-file) 1265 | (write load-test-obj test-file) 1266 | (test #t output-port? test-file) 1267 | (close-output-port test-file) 1268 | (check-test-file "tmp2") 1269 | (define (test-sc4) 1270 | (newline) 1271 | (display ";testing scheme 4 functions; ") 1272 | (newline) 1273 | (SECTION 6 7) 1274 | (test '(#\P #\space #\l) string->list "P l") 1275 | (test '() string->list "") 1276 | (test "1\\\"" list->string '(#\1 #\\ #\")) 1277 | (test "" list->string '()) 1278 | (SECTION 6 8) 1279 | (test '(dah dah didah) vector->list '#(dah dah didah)) 1280 | (test '() vector->list '#()) 1281 | (test '#(dididit dah) list->vector '(dididit dah)) 1282 | (test '#() list->vector '()) 1283 | (SECTION 6 10 4) 1284 | (load "tmp1") 1285 | (test write-test-obj 'load foo) 1286 | (report-errs)) 1287 | 1288 | (report-errs) 1289 | (let ((have-inexacts? 1290 | (and (string->number "0.0") (inexact? (string->number "0.0")))) 1291 | (have-bignums? 1292 | (let ((n (string->number 1293 | "1427247692705959881058285969449495136382746625"))) 1294 | (and n (exact? n))))) 1295 | (cond (have-inexacts? 1296 | (test-inexact) 1297 | (test-inexact-printing))) 1298 | (if have-bignums? (test-bignum)) 1299 | (if (and have-inexacts? have-bignums?) 1300 | (test-numeric-predicates))) 1301 | 1302 | (newline) 1303 | (display "To fully test continuations, Scheme 4, and DELAY/FORCE do:") 1304 | (newline) 1305 | (display "(test-cont) (test-sc4) (test-delay)") 1306 | (newline) 1307 | "last item in file" 1308 | -------------------------------------------------------------------------------- /parser-lib-tests.scm: -------------------------------------------------------------------------------- 1 | (use r7rs) 2 | (use test) 3 | 4 | (include "parser-lib.scm") 5 | (import parser-lib) 6 | 7 | (test-group "nop" 8 | (test '(#t . 0) (nop "abc" 0))) 9 | 10 | (test-group "nop" 11 | (test '#f (fail "abc" 0))) 12 | 13 | (test-group "any-char" 14 | (test '("a" . 1) (any-char "abc" 0)) 15 | (test '("b" . 2) (any-char "abc" 1)) 16 | (test '("c" . 3) (any-char "abc" 2)) 17 | (test #f (any-char "abc" 3)) 18 | ) 19 | 20 | (test-group "char" 21 | (test '("a" . 1) ((char #\a) "abc" 0)) 22 | (test #f ((char #\b) "abc" 0)) 23 | (test #f ((char #\b) "abc" 3)) 24 | ) 25 | 26 | (test-group "if-char" 27 | (test '("a" . 1) ((if-char char-alphabetic?) "abc" 0)) 28 | (test #f ((if-char char-numeric?) "abc" 0)) 29 | (test #f ((if-char char-alphabetic?) "abc" 3)) 30 | ) 31 | 32 | (test-group "seq" 33 | (test '(("a" "b") . 2) ((seq any-char any-char) "abc" 0)) 34 | (test #f ((seq any-char any-char) "abc" 2)) 35 | (test '(("a" "b") . 2) ((seq (char #\a) 36 | (char #\b)) "abc" 0)) 37 | (test #f ((seq (char #\b) 38 | (char #\b)) "abc" 0)) 39 | (test #f ((seq (char #\a) 40 | (char #\c)) "abc" 0)) 41 | ) 42 | 43 | (test-group "str-seq" 44 | (test '("ab" . 2) ((str-seq any-char any-char) "abc" 0)) 45 | (test #f ((str-seq any-char any-char) "abc" 2)) 46 | (test '("ab" . 2) ((str-seq (char #\a) (char #\b)) "abc" 0)) 47 | (test #f ((str-seq (char #\b) (char #\b)) "abc" 0)) 48 | (test #f ((str-seq (char #\c) (char #\c)) "abc" 0)) 49 | ) 50 | 51 | (test-group "matches" 52 | (test '("123" . 3) ((matches "123") "123abc" 0)) 53 | (test #f ((matches "123") "abc123" 0)) 54 | (test #f ((matches "1234") "123" 0)) 55 | ) 56 | 57 | (test-group "while" 58 | (test '(("1" "2" "3") . 3) ((while (if-char char-numeric?)) "123abc" 0)) 59 | (test '(("1" "2" "3") . 3) ((while (if-char char-numeric?)) "123" 0)) 60 | (test '(("12" "12") . 4) ((while (matches "12")) "12123" 0)) 61 | (test '(() . 0) ((while (if-char char-numeric?)) "abc123abc" 0)) 62 | ) 63 | 64 | (test-group "while1" 65 | (test '(("1" "2" "3") . 3) ((while1 (if-char char-numeric?)) "123abc" 0)) 66 | (test #f ((while1 (if-char char-numeric?)) "abc123abc" 0)) 67 | ) 68 | 69 | (test-group "while-char" 70 | (test '("123" . 3) ((while-char char-numeric?) "123abc" 0)) 71 | (test '("123" . 3) ((while-char char-numeric?) "123" 0)) 72 | (test '("" . 0) ((while-char char-numeric?) "abc" 0)) 73 | ) 74 | 75 | (test-group "while1-char" 76 | (test '("123" . 3) ((while1-char char-numeric?) "123abc" 0)) 77 | (test '("123" . 3) ((while1-char char-numeric?) "123" 0)) 78 | (test #f ((while1-char char-numeric?) "abc" 0)) 79 | ) 80 | 81 | (test-group "choice" 82 | (test '("123" . 3) ((choice (while1-char char-numeric?) 83 | (char #\a)) "123abc" 0)) 84 | (test '("a" . 1) ((choice (while1-char char-numeric?) 85 | (char #\a)) "abc123" 0)) 86 | (test #f ((choice (while1-char char-numeric?) 87 | (char #\a)) "xabc123" 0)) 88 | ) 89 | 90 | 91 | (test-group "parser-macro" 92 | (test '(#t . 1) (let ((p (parser c1 <- any-char))) 93 | (p "abc" 0))) 94 | (test '(#t . 2) (let ((p (parser c1 <- any-char 95 | c2 <- any-char))) 96 | (p "abc" 0))) 97 | (test '(#t . 2) (let ((p (parser c1 <- (char #\a) 98 | c2 <- any-char))) 99 | (p "abc" 0))) 100 | (test #f (let ((p (parser c1 <- (char #\a) 101 | c2 <- any-char))) 102 | (p "dabc" 0))) 103 | (test '("ab" . 2) (let ((p (parser c1 <- any-char 104 | c2 <- any-char 105 | return (string-append c1 c2)))) 106 | (p "abc" 0))) 107 | (test '("b" . 2) (let ((p (parser any-char 108 | c <- any-char 109 | return c))) 110 | (p "abc" 0))) 111 | (test '("c" . 3) (let ((p (parser (matches "ab") 112 | c <- any-char 113 | return c))) 114 | (p "abc" 0))) 115 | (test #f (let ((p (parser c1 <- any-char 116 | c2 <- (char #\a) 117 | return (string-append c1 c2)))) 118 | (p "abc" 0))) 119 | (test #f (let ((p (parser c1 <- any-char 120 | c2 <- (char #\b) 121 | c3 <- (char #\a) 122 | return (string-append c1 c2)))) 123 | (p "abc" 0))) 124 | ) 125 | 126 | (test-exit) -------------------------------------------------------------------------------- /parser-lib.scm: -------------------------------------------------------------------------------- 1 | ;; The module defines haskell-style parser combinators. 2 | ;; 3 | ;; A parser is a function of two arguments: 4 | ;; - string which is parsed 5 | ;; - offset to start parsing from 6 | ;; Parser function returns either: 7 | ;; - #f if parsing was not successful 8 | ;; - a pair (parsing_result . new_starting_offset) 9 | ;; (require-extension syntax-case) 10 | (require-extension r7rs) 11 | 12 | (define-library parser-lib 13 | (import (scheme base)) 14 | (export any-char char choice if-char fail nop parser while while1 str-seq seq matches while-char while1-char) 15 | 16 | (begin 17 | 18 | (define (nop s p) 19 | (cons #t p)) 20 | 21 | (define (fail s p) 22 | #f) 23 | 24 | ;; Accepts any char 25 | ;; TODO: should return a character not string 26 | (define (any-char s p) 27 | (if (< p (string-length s)) 28 | (cons (substring s p (+ p 1)) (+ p 1)) 29 | #f)) 30 | 31 | ;; Accepts a char if predicate is true on it 32 | (define (if-char predicate) 33 | (lambda (s i) 34 | (let ((r (any-char s i))) 35 | (if (and r 36 | (predicate (string-ref (car r) 0))) 37 | r 38 | #f)))) 39 | 40 | ;; Accepts a given char 41 | (define (char c) 42 | (if (char? c) 43 | (if-char (lambda (c1) (equal? c c1))) 44 | (error "argument shoul be char" c))) 45 | 46 | ;; Accepts specified string 47 | (define (matches m) 48 | (lambda (s i) 49 | (let ((n (string-length m))) 50 | (if (and (<= (+ i n) (string-length s)) 51 | (string=? m (substring s i (+ i n)))) 52 | (cons m (+ i n)) 53 | #f)))) 54 | 55 | (define (while parser) 56 | (lambda (s i) 57 | (let ((len (string-length s))) 58 | (let loop ((j i) 59 | (result '())) 60 | (if (< j len) 61 | (let ((r (parser s j))) 62 | (if r 63 | (loop (cdr r) (append result (list (car r)))) 64 | (cons result j))) 65 | (cons result j)))))) 66 | 67 | ;; The same as while, but succeeds only if parser matched at least 1 times 68 | (define (while1 parser) 69 | (lambda (s i) 70 | (let ((r ((while parser) s i))) 71 | (if (and r 72 | (> (length (car r)) 0)) 73 | r 74 | #f)))) 75 | 76 | ;; A parser, which calls all passed parsers consequently. The result of 77 | ;; the successful parse is the list of parsers results. 78 | (define (seq . parsers) 79 | (lambda (s i) 80 | (let loop ((pos i) 81 | (pp parsers) 82 | (result '())) 83 | (if (pair? pp) 84 | (let ((r ((car pp) s pos))) 85 | (if r 86 | (loop (cdr r) (cdr pp) (append result (list (car r)))) 87 | #f)) 88 | (cons result pos))))) 89 | 90 | ;; Tries to parse by each of the parsers consequently. 91 | ;; Returns the result of first successful one. 92 | (define (choice . parsers) 93 | (lambda (s i) 94 | (let loop ((p parsers)) 95 | (if (pair? p) 96 | (let ((r ((car p) s i))) 97 | (if r 98 | r 99 | (loop (cdr p)))) 100 | #f)))) 101 | 102 | 103 | 104 | (define-syntax parser 105 | (syntax-rules (<-) 106 | ((parser) 107 | (lambda (s p) 108 | (cons #t p))) 109 | ((parser v <- head-parser . tail) 110 | (lambda (s p) 111 | (let* ((head-result (head-parser s p))) 112 | (if head-result 113 | (let* ((v (car head-result)) 114 | (tail-parser (parser . tail)) 115 | (head-pos (cdr head-result)) 116 | (tail-result (tail-parser s head-pos))) 117 | (if tail-result 118 | (cons (car tail-result) (cdr tail-result)) 119 | #f)) 120 | #f)))) 121 | ((parser return e) 122 | (lambda (s p) 123 | (cons e p))) 124 | ((parser head-parser . tail) 125 | (lambda (s p) 126 | (let* ((head-result (head-parser s p))) 127 | (if head-result 128 | (let* ((v (car head-result)) 129 | (tail-parser (parser . tail)) 130 | (head-pos (cdr head-result)) 131 | (tail-result (tail-parser s head-pos))) 132 | (if tail-result 133 | (cons (car tail-result) (cdr tail-result)) 134 | #f)) 135 | #f)))))) 136 | 137 | 138 | ;; Calls parsers consequently, requires all parsers to return strings. 139 | ;; The result of this parser is concatenated string of all parsers results. 140 | (define (str-seq . parsers) 141 | (parser r <- (apply seq parsers) return (apply string-append r))) 142 | 143 | ;; Create a parser which accepts all chars while predicate is true. 144 | ;; The result is the substring which matched. 145 | (define (while-char predicate) 146 | (parser r <- (while (if-char predicate)) return (apply string-append r))) 147 | 148 | ;; Create a parser which accepts all chars while predicate is true. 149 | ;; The result is the substring which matched. 150 | (define (while1-char predicate) 151 | (parser r <- (while1 (if-char predicate)) return (apply string-append r))) 152 | 153 | )) -------------------------------------------------------------------------------- /rakefile: -------------------------------------------------------------------------------- 1 | require 'rake' 2 | require 'tempfile' 3 | require 'rake/clean' 4 | require 'fileutils' 5 | 6 | load 'tests/rakefile' 7 | 8 | CLEAN.include("*.bc") 9 | CLEAN.include("*.ll") 10 | 11 | rule ".bc" => ".c" do |t| 12 | sh "clang -c -emit-llvm -o #{t.name} #{t.source}" 13 | end 14 | 15 | # rule ".bc" => ".ll" do |t| 16 | # sh "llvm-as -f -o #{t.name} #{t.source}" 17 | # sh "opt -f -std-compile-opts -o #{t.name} #{t.name}" 18 | # end 19 | 20 | 21 | task :unit_test do 22 | sh "csi -b parser-lib-tests.scm" 23 | sh "csi -b scheme-parser-tests.scm" 24 | sh "csi -b lower-tests.scm" 25 | end 26 | 27 | task :runtime => "runtime.bc" 28 | 29 | task :test => [:runtime, :unit_test, "test:all"] 30 | task :default => :test 31 | -------------------------------------------------------------------------------- /runtime.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | #include "runtime_shared.h" 7 | 8 | typedef struct { 9 | void* data; 10 | char type; 11 | } Data; 12 | 13 | typedef struct { 14 | Data* car; 15 | Data* cdr; 16 | } Cons; 17 | 18 | typedef struct { 19 | int arity; 20 | void* proc; 21 | } Lambda; 22 | 23 | typedef Data* (*proc0)(); 24 | typedef Data* (*proc1)(Data*); 25 | typedef Data* (*proc2)(Data*, Data*); 26 | typedef Data* (*proc3)(Data*, Data*, Data*); 27 | typedef Data* (*proc4)(Data*, Data*, Data*, Data*); 28 | typedef Data* (*proc5)(Data*, Data*, Data*, Data*, Data*); 29 | typedef Data* (*proc6)(Data*, Data*, Data*, Data*, Data*, Data*); 30 | typedef Data* (*proc7)(Data*, Data*, Data*, Data*, Data*, Data*, Data*); 31 | typedef Data* (*proc8)(Data*, Data*, Data*, Data*, Data*, Data*, Data*, Data*); 32 | typedef Data* (*proc9)(Data*, Data*, Data*, Data*, Data*, Data*, Data*, Data*, Data*); 33 | 34 | #define CONS(d) ((Cons*)(d->data)) 35 | #define CHARP(d) ((char*)(d->data)) 36 | #define INT(d) ((int)(d->data)) 37 | #define LAMBDA(d) ((Lambda*)(d->data)) 38 | #define PROC(d) ((void*)(LAMBDA(d)->proc)) 39 | 40 | #define CHECK(b) assert(b) 41 | #define CHECK_IS_CONS(d) CHECK(d && d->type == T_CONS) 42 | #define CHECK_IS_INT(d) CHECK(d && d->type == T_INT) 43 | #define CHECK_IS_SYMBOL(d) CHECK(d && d->type == T_SYMBOL) 44 | #define CHECK_IS_LAMBDA(d, a) CHECK(d && d->type == T_LAMBDA && LAMBDA(d)->arity == a) 45 | 46 | Data* _car(Data* d) { 47 | if (!d) { 48 | fprintf(stderr, "ERROR: calling (car ())\n"); 49 | exit(2); 50 | } 51 | CHECK_IS_CONS(d); 52 | return CONS(d)->car; 53 | } 54 | 55 | Data* _cdr(Data* d) { 56 | if (!d) { 57 | fprintf(stderr, "ERROR: calling (cdr ())\n"); 58 | exit(2); 59 | } 60 | CHECK_IS_CONS(d); 61 | return CONS(d)->cdr; 62 | } 63 | 64 | Data* _add(Data* d1, Data* d2) { 65 | CHECK_IS_INT(d1); 66 | CHECK_IS_INT(d2); 67 | 68 | int i = INT(d1) + INT(d2); 69 | Data* result = malloc(sizeof(Data)); 70 | result->type = T_INT; 71 | result->data = (void*)i; 72 | return result; 73 | } 74 | 75 | Lambda lcar = {1, _car}; 76 | Data car = {&lcar, T_LAMBDA}; 77 | 78 | Lambda lcdr = {1, _cdr}; 79 | Data cdr = {&lcdr, T_LAMBDA}; 80 | 81 | Lambda ladd = {2, _add}; 82 | Data add = {&ladd, T_LAMBDA}; 83 | 84 | Data* display(Data* d); 85 | 86 | void display_int(Data* d) { 87 | CHECK_IS_INT(d); 88 | printf("%d", INT(d)); 89 | } 90 | 91 | void display_symbol(Data* d) { 92 | CHECK_IS_SYMBOL(d); 93 | printf("%s", CHARP(d)); 94 | } 95 | 96 | void display_cons(Data* d) { 97 | CHECK_IS_CONS(d); 98 | printf("("); 99 | display(_car(d)); 100 | Data* t = _cdr(d); 101 | while (t) { 102 | if (t->type == T_CONS) { 103 | printf(" "); 104 | display(_car(t)); 105 | t = _cdr(t); 106 | } 107 | else { 108 | printf(" . "); 109 | display(t); 110 | break; 111 | } 112 | } 113 | printf(")"); 114 | } 115 | 116 | Data* display(Data* d) { 117 | if (!d) { 118 | printf("()"); 119 | return 0; 120 | } 121 | switch (d->type) { 122 | case T_INT : 123 | display_int(d); 124 | break; 125 | case T_SYMBOL : 126 | display_symbol(d); 127 | break; 128 | case T_CONS : 129 | display_cons(d); 130 | break; 131 | default : 132 | fprintf(stderr, "Unknown type: %d\n", d->type); 133 | assert(0); 134 | } 135 | return 0; 136 | } 137 | 138 | Data* call0(Data* d) { 139 | CHECK_IS_LAMBDA(d, 0); 140 | return ((proc0)(PROC(d)))(); 141 | } 142 | 143 | Data* call1(Data* d, Data* p1) { 144 | CHECK_IS_LAMBDA(d, 1); 145 | return ((proc1)(PROC(d)))(p1); 146 | } 147 | 148 | Data* call2(Data* d, Data* p1, Data* p2) { 149 | CHECK_IS_LAMBDA(d, 2); 150 | return ((proc2)(PROC(d)))(p1, p2); 151 | } 152 | 153 | Data* call3(Data* d, Data* p1, Data* p2, Data* p3) { 154 | CHECK_IS_LAMBDA(d, 3); 155 | return ((proc3)(PROC(d)))(p1, p2, p3); 156 | } 157 | 158 | Data* call4(Data* d, Data* p1, Data* p2, Data* p3, Data* p4) { 159 | CHECK_IS_LAMBDA(d, 4); 160 | return ((proc4)(PROC(d)))(p1, p2, p3, p4); 161 | } 162 | 163 | Data* call5(Data* d, Data* p1, Data* p2, Data* p3, Data* p4, Data* p5) { 164 | CHECK_IS_LAMBDA(d, 5); 165 | return ((proc5)(PROC(d)))(p1, p2, p3, p4, p5); 166 | } 167 | 168 | Data* call6(Data* d, Data* p1, Data* p2, Data* p3, Data* p4, Data* p5, Data* p6) { 169 | CHECK_IS_LAMBDA(d, 6); 170 | return ((proc6)(PROC(d)))(p1, p2, p3, p4, p5, p6); 171 | } 172 | 173 | Data* call7(Data* d, Data* p1, Data* p2, Data* p3, Data* p4, Data* p5, Data* p6, Data* p7) { 174 | CHECK_IS_LAMBDA(d, 7); 175 | return ((proc7)(PROC(d)))(p1, p2, p3, p4, p5, p6, p7); 176 | } 177 | 178 | Data* call8(Data* d, Data* p1, Data* p2, Data* p3, Data* p4, Data* p5, Data* p6, Data* p7, 179 | Data* p8) { 180 | CHECK_IS_LAMBDA(d, 8); 181 | return ((proc8)(PROC(d)))(p1, p2, p3, p4, p5, p6, p7, p8); 182 | } 183 | 184 | Data* call9(Data* d, Data* p1, Data* p2, Data* p3, Data* p4, Data* p5, Data* p6, Data* p7, 185 | Data* p8, Data* p9) { 186 | CHECK_IS_LAMBDA(d, 9); 187 | return ((proc9)(PROC(d)))(p1, p2, p3, p4, p5, p6, p7, p8, p9); 188 | } 189 | 190 | char** symbols; 191 | int symbols_size; 192 | int symbols_count; 193 | 194 | void init_symbol(char* str, Data* data) { 195 | int i; 196 | for (i = 0; i < symbols_count; i++) { 197 | if (!strcmp(str, symbols[i])) { 198 | data->data = symbols[i]; 199 | return; 200 | } 201 | } 202 | 203 | // not found, should add new one 204 | 205 | if (symbols_count == symbols_size) { 206 | // reallocate 207 | char** old = symbols; 208 | symbols = malloc(sizeof(char*) * symbols_size * 2); 209 | memset(symbols, 0, sizeof(char*) * symbols_size * 2); 210 | memcpy(symbols, old, sizeof(char*) * symbols_size); 211 | symbols_size *= 2; 212 | } 213 | 214 | char** s = &symbols[symbols_count]; 215 | symbols_count++; 216 | 217 | int len = strlen(str); 218 | *s = malloc(len + 1); 219 | memcpy(*s, str, len + 1); 220 | data->data = *s; 221 | } 222 | 223 | void init_symbols() { 224 | symbols_size = 100; 225 | symbols = malloc(sizeof(char*) * symbols_size); 226 | memset(symbols, 0, sizeof(char*) * symbols_size); 227 | symbols_count = 0; 228 | } 229 | 230 | 231 | void scheme_main(void); 232 | void scheme_init(void); 233 | 234 | int main(int argc, char** argv) { 235 | init_symbols(); 236 | scheme_init(); 237 | scheme_main(); 238 | return 0; 239 | } 240 | -------------------------------------------------------------------------------- /runtime.ll.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef RUNTIME_H 3 | #define RUNTIME_H 4 | 5 | #include "runtime_shared.h" 6 | 7 | #define DATA %struct.Data 8 | #define CONS %struct.Cons 9 | #define LAMBDA %struct.Lambda 10 | 11 | DATA = type { i8*, i8 } 12 | CONS = type { DATA*, DATA* } 13 | LAMBDA = type { i32, i8* } 14 | 15 | @car = external global DATA 16 | @cdr = external global DATA 17 | @add = external global DATA 18 | 19 | 20 | declare DATA* @display(DATA* %d) 21 | declare void @init_symbol(i8* %str, DATA* %data) 22 | declare DATA* @get_env(DATA* %symbol) 23 | declare void @llvm.memcpy.i32(i8* %dst, i8* %src, i32 %size, i32 %align) 24 | 25 | declare DATA* @call0(DATA* %d) 26 | declare DATA* @call1(DATA* %d, DATA* %p1) 27 | declare DATA* @call2(DATA* %d, DATA* %p1, DATA* %p2) 28 | declare DATA* @call3(DATA* %d, DATA* %p1, DATA* %p2, DATA* %p3) 29 | declare DATA* @call4(DATA* %d, DATA* %p1, DATA* %p2, DATA* %p3, DATA* %p4) 30 | declare DATA* @call5(DATA* %d, DATA* %p1, DATA* %p2, DATA* %p3, DATA* %p4, DATA* %p5) 31 | declare DATA* @call6(DATA* %d, DATA* %p1, DATA* %p2, DATA* %p3, DATA* %p4, DATA* %p5, 32 | DATA* %p6) 33 | declare DATA* @call7(DATA* %d, DATA* %p1, DATA* %p2, DATA* %p3, DATA* %p4, DATA* %p5, 34 | DATA* %p6, DATA* %p7) 35 | declare DATA* @call8(DATA* %d, DATA* %p1, DATA* %p2, DATA* %p3, DATA* %p4, DATA* %p5, 36 | DATA* %p6, DATA* %p7, DATA* %p8) 37 | declare DATA* @call9(DATA* %d, DATA* %p1, DATA* %p2, DATA* %p3, DATA* %p4, DATA* %p5, 38 | DATA* %p6, DATA* %p7, DATA* %p8, DATA* %p9) 39 | 40 | #endif 41 | 42 | -------------------------------------------------------------------------------- /runtime_shared.h: -------------------------------------------------------------------------------- 1 | #ifndef RUNTIME_SHARED_H 2 | #define RUNTIME_SHARED_H 3 | 4 | #define T_CONS 1 5 | #define T_STRING 2 6 | #define T_SYMBOL 3 7 | #define T_INT 4 8 | #define T_CHAR 5 9 | #define T_BUILTIN 6 10 | #define T_LAMBDA 7 11 | 12 | #endif 13 | -------------------------------------------------------------------------------- /scheme-parser-tests.scm: -------------------------------------------------------------------------------- 1 | ;; (require-extension syntax-case) 2 | 3 | (use test) 4 | (load "scheme-parser.scm") 5 | 6 | 7 | (test-group "symbol" 8 | (test '(abc . 3) (symbol "abc" 0)) 9 | (test '(... . 3) (symbol "..." 0)) 10 | (test '(ab@cd . 5) (symbol "ab@cd" 0)) 11 | (test '($ab@cd . 6) (symbol "$ab@cd" 0)) 12 | (test #f (symbol "@ab@cd" 0)) 13 | (test '(+ . 1) (symbol "+34abc" 0)) 14 | (test #f (symbol "34abc" 0)) 15 | ) 16 | 17 | (test-group "string" 18 | (test '("abc" . 5) (string "\"abc\"" 0)) 19 | (test '("a\"c" . 6) (string "\"a\\\"c\"" 0)) 20 | (test '("a\\c" . 6) (string "\"a\\\\c\"" 0)) 21 | (test #f (string "34abc" 0)) 22 | ) 23 | 24 | (test-group "literal" 25 | (test '("abc" . 5) (literal "\"abc\"" 0)) 26 | (test '((quote abc) . 4) (literal "'abc" 0)) 27 | (test '((quote abc) . 11) (literal "(quote abc)" 0)) 28 | (test '((quote abc) . 14) (literal "(quote abc)" 0)) 29 | ) 30 | 31 | (test-group "number" 32 | (test '(123 . 3) (number "123" 0)) 33 | (test '(64 . 5) (number "#o100" 0)) 34 | (test '(4 . 5) (number "#b100" 0)) 35 | (test '(256 . 5) (number "#x100" 0)) 36 | ) 37 | 38 | (test-group "list" 39 | (test '(() . 2) (datum "()" 0)) 40 | (test '((1) . 3) (datum "(1)" 0)) 41 | (test '((1 2) . 5) (datum "(1 2)" 0)) 42 | (test '((1 (3 4) 2) . 11) (datum "(1 (3 4) 2)" 0)) 43 | (test '((1 . 2) . 7) (datum "(1 . 2)" 0)) 44 | (test '((1 2 . 3) . 9) (datum "(1 2 . 3)" 0)) 45 | ) 46 | 47 | (test-exit) -------------------------------------------------------------------------------- /scheme-parser.scm: -------------------------------------------------------------------------------- 1 | ;; (require-extension syntax-case) 2 | (require-extension srfi-1) 3 | 4 | (load "parser-lib.scm") 5 | (import parser-lib) 6 | 7 | (define (special-initial? c) 8 | (or (char=? #\! c) 9 | (char=? #\$ c) 10 | (char=? #\% c) 11 | (char=? #\& c) 12 | (char=? #\* c) 13 | (char=? #\/ c) 14 | (char=? #\: c) 15 | (char=? #\< c) 16 | (char=? #\= c) 17 | (char=? #\> c) 18 | (char=? #\? c) 19 | (char=? #\^ c) 20 | (char=? #\_ c) 21 | (char=? #\~ c))) 22 | 23 | (define (initial? c) 24 | (or (char-alphabetic? c) (special-initial? c))) 25 | 26 | (define (special-subsequent? c) 27 | (or (char=? #\+ c) 28 | (char=? #\- c) 29 | (char=? #\. c) 30 | (char=? #\@ c))) 31 | 32 | (define (subsequent? c) 33 | (or (initial? c) 34 | (char-numeric? c) 35 | (special-subsequent? c))) 36 | 37 | (define (whitespace? c) 38 | (or (char=? #\space c) 39 | (char=? #\newline c))) 40 | 41 | (define (!whitespace? c) 42 | (not (whitespace? c))) 43 | 44 | (define (digitr? r) 45 | (lambda (c) 46 | (case r 47 | ((2) (and (char<=? #\0 c) (char>=? #\1 c))) 48 | ((8) (and (char<=? #\0 c) (char>=? #\7 c))) 49 | ((10) (and (char<=? #\0 c) (char>=? #\9 c))) 50 | ((16) (or (and (char<=? #\0 c) (char>=? #\9 c)) 51 | (and (char<=? #\a c) (char>=? #\f c)))) 52 | (else #f)))) 53 | 54 | (define (hash? c) 55 | (char=? #\# c)) 56 | 57 | (define (token s) 58 | (parser t <- (matches s) 59 | (while-char whitespace?) 60 | return t)) 61 | 62 | (define peculiar-identifier 63 | (choice (token "+") 64 | (token "-") 65 | (token "..."))) 66 | 67 | (define identifier 68 | (parser i <- (choice (str-seq (if-char initial?) 69 | (while-char subsequent?)) 70 | peculiar-identifier) 71 | return i)) 72 | 73 | (define string-element 74 | (choice (if-char (lambda (c) 75 | (not (or (char=? #\" c) (char=? #\\ c))))) 76 | (parser (matches "\\\"") 77 | return "\"") 78 | (parser (matches "\\\\") 79 | return "\\"))) 80 | 81 | (define string 82 | (parser (matches "\"") 83 | s <- (while string-element) 84 | (token "\"") 85 | return (apply string-append s))) 86 | 87 | (define boolean fail) ;; TODO 88 | (define character fail) ;; TODO 89 | 90 | (define (digit r) 91 | (parser c <- (if-char (digitr? r)) 92 | return (- (char->integer (string-ref c 0)) (char->integer #\0)))) 93 | 94 | (define sign 95 | (choice (parser (token "+") 96 | return 1) 97 | (parser (token "-") 98 | return -1) 99 | (parser nop 100 | return 1))) 101 | 102 | (define exponent-marker 103 | (choice (token "e") 104 | (token "s") 105 | (token "f") 106 | (token "d") 107 | (token "l"))) 108 | 109 | (define suffix 110 | (choice (seq exponent-marker sign (while (digit 10))) 111 | nop)) 112 | 113 | (define (decimal r) 114 | (case r 115 | ((10) (choice (seq (uinteger 10) suffix) 116 | (seq (matches ".") (while1 (digit 10)) (while-char hash?) suffix) 117 | (seq (while1 (digit 10)) (matches ".") (while (digit 10)) 118 | (while-char hash?) suffix) 119 | (seq (while1 (digit 10)) (while1-char hash?) (matches ".") 120 | (while-char hash?) suffix))) 121 | (else fail))) 122 | 123 | 124 | (define (uinteger r) 125 | (parser d <- (while1 (digit r)) 126 | h <- (while-char hash?) 127 | return (let ((i1 (fold (lambda (d1 d2) (+ (* d2 r) d1)) 0 d)) 128 | (h (expt r (string-length h)))) 129 | (* i1 h)))) 130 | 131 | (define (ureal r) 132 | (choice (seq (uinteger r) (token "/") (uinteger r)) 133 | (uinteger r) 134 | (decimal r))) 135 | 136 | (define (real r) 137 | (parser s <- sign 138 | u <- (ureal r) 139 | return (* s u))) 140 | 141 | (define (complex r) 142 | (choice (seq (real r) (token "@") (real r)) 143 | (seq (real r) (token "+") (ureal r) (token "i")) 144 | (seq (real r) (token "-") (ureal r) (token "i")) 145 | (seq (real r) (token "+") (token "i")) 146 | (seq (real r) (token "-") (token "i")) 147 | (seq (token "+") (ureal r) (token "i")) 148 | (seq (token "-") (ureal r) (token "i")) 149 | (seq (token "+") (token "i")) 150 | (seq (token "-") (token "i")) 151 | (real r))) 152 | 153 | (define exactness 154 | (choice (parser (matches "#i") 155 | return (lambda (n) (exact->inexact n))) 156 | (parser (matches "#e") 157 | return (lambda (n) (inexact->exact n))) 158 | (parser nop 159 | return (lambda (n) n)))) 160 | 161 | (define (radix r) 162 | (case r 163 | ((2) (matches "#b")) 164 | ((8) (matches "#o")) 165 | ((16) (matches "#x")) 166 | ((10) (choice (matches "#d") 167 | nop)) 168 | (else fail))) 169 | 170 | (define (prefix r) 171 | (choice (parser r <- (radix r) 172 | e <- exactness 173 | return (cons e r)) 174 | (parser e <- exactness 175 | r <- (radix r) 176 | return (cons e r)))) 177 | 178 | (define (num r) 179 | (parser p <- (prefix r) 180 | n <- (complex r) 181 | return ((car p) n))) 182 | 183 | (define number 184 | (choice (num 2) 185 | (num 8) 186 | (num 10) 187 | (num 16))) 188 | 189 | ;; External representations 190 | (define symbol 191 | (parser i <- identifier 192 | return (string->symbol i))) 193 | 194 | (define simple-datum 195 | (parser r <- (choice boolean 196 | number 197 | character 198 | string 199 | symbol) 200 | (while-char whitespace?) 201 | return r)) 202 | 203 | (define vector fail) ;; TODO 204 | (define abbreviation fail) ;; TODO 205 | 206 | (define datum 207 | (letrec ((_datum (lambda (s i) ((choice simple-datum compound-datum) s i))) 208 | (_list (lambda (s i) 209 | ((choice (parser (token "(") 210 | l <- (while _datum) 211 | (token ")") 212 | return l) 213 | (parser (token "(") 214 | l <- (while1 _datum) 215 | (token ".") 216 | t <- _datum 217 | (token ")") 218 | return (let ((tt (last-pair l))) 219 | (begin 220 | (set-cdr! tt t) 221 | l))) 222 | abbreviation) s i))) 223 | (compound-datum (lambda (s i) ((choice _list vector) s i)))) 224 | _datum)) 225 | 226 | ;; Expressions 227 | 228 | (define quotation 229 | (choice (parser (matches "'") 230 | d <- datum 231 | return (list 'quote d)) 232 | (parser (token "(quote") 233 | d <- datum 234 | (token ")") 235 | return (list 'quote d)))) 236 | (define self-evaluating 237 | (choice boolean 238 | number 239 | character 240 | string)) 241 | 242 | (define literal 243 | (choice quotation self-evaluating)) 244 | 245 | (define variable fail) ;; TODO 246 | (define procedure-call fail) ;; TODO 247 | (define lambda-expression fail) ;; TODO 248 | (define conditional fail) ;; TODO 249 | (define assignment fail) ;; TODO 250 | (define derived-expression fail) ;; TODO 251 | (define macro-use fail) ;; TODO 252 | (define macro-block fail) ;; TODO 253 | 254 | (define expression 255 | (choice variable 256 | literal 257 | procedure-call 258 | lambda-expression 259 | conditional 260 | assignment 261 | derived-expression 262 | macro-use 263 | macro-block)) 264 | 265 | (define command expression) 266 | 267 | ;; Programs and definitions 268 | (define definition fail) ;; TODO 269 | (define syntax-definition fail) ;; TODO 270 | 271 | ;; (define command-or-definition 272 | ;; (choice command 273 | ;; definition 274 | ;; syntax-definition 275 | ;; (seq (matches "(begin") 276 | ;; (while1 command-or-definition) 277 | ;; (matches ")")))) 278 | 279 | ;; (define program 280 | ;; (while command-or-definition)) 281 | -------------------------------------------------------------------------------- /tests/001_int_constant.scm: -------------------------------------------------------------------------------- 1 | 12 2 | ;; 12 -------------------------------------------------------------------------------- /tests/002_symbol_constants.scm: -------------------------------------------------------------------------------- 1 | 'abc 2 | ;; abc -------------------------------------------------------------------------------- /tests/009_list_literals.scm: -------------------------------------------------------------------------------- 1 | '() 2 | ;; () 3 | '(a) 4 | ;; (a) 5 | '(1 2) 6 | ;; (1 2) 7 | '(a b c d e f g h) 8 | ;; (a b c d e f g h) 9 | '(1 ((2 3) (4 5) (5)) 6 7) 10 | ;; (1 ((2 3) (4 5) (5)) 6 7) 11 | '(1 . 2) 12 | ;; (1 . 2) 13 | '((3 . 4)) 14 | ;; ((3 . 4)) 15 | '((a . 1) (b . 2)) 16 | ;; ((a . 1) (b . 2)) 17 | '((a . 1) (b . 2) (c . 3) ((a . b) . (c . d)) . z) 18 | ;; ((a . 1) (b . 2) (c . 3) ((a . b) c . d) . z) -------------------------------------------------------------------------------- /tests/010_car.scm: -------------------------------------------------------------------------------- 1 | (car '(1 2)) 2 | ;; 1 3 | (car '(2 3 4)) 4 | ;; 2 5 | (car '(5 . 6)) 6 | ;; 5 7 | (car '(a b c)) 8 | ;; a 9 | (car '((a) b c d)) 10 | ;; (a) 11 | (car '()) 12 | ;; 13 | -------------------------------------------------------------------------------- /tests/011_int_operations.scm: -------------------------------------------------------------------------------- 1 | (+ 3 2) 2 | ;; 5 -------------------------------------------------------------------------------- /tests/020_lambda.scm: -------------------------------------------------------------------------------- 1 | ((lambda (x) x) '(1 2)) 2 | ;; (1 2) 3 | 4 | ((lambda (x) (car x)) '(1 2)) 5 | ;; 1 6 | 7 | ((lambda (x y) (+ x y)) 5 6) 8 | ;; 11 -------------------------------------------------------------------------------- /tests/021_let.scm: -------------------------------------------------------------------------------- 1 | (let ((x 1)) 2 | x) 3 | ;; 1 4 | (let ((x 1) 5 | (y 2)) 6 | y) 7 | ;; 2 8 | (let ((x 1) 9 | (y 2)) 10 | (+ x y)) 11 | ;; 3 12 | 13 | (let ((x (lambda(y) (+ 2 y)))) 14 | (x 3)) 15 | ;; 5 -------------------------------------------------------------------------------- /tests/030_define.scm: -------------------------------------------------------------------------------- 1 | (define p 80) 2 | p 3 | ;; 80 4 | 5 | (define (f x) (+ 3 x)) 6 | (f 20) 7 | ;; 23 -------------------------------------------------------------------------------- /tests/rakefile: -------------------------------------------------------------------------------- 1 | TESTS = FileList["tests/*.scm"] 2 | TEST_RESULTS = TESTS.ext("ok") 3 | 4 | namespace :test do 5 | 6 | def process_test_file(f, &block) 7 | puts "------- Testing #{f} (test:run_#{f})\n" 8 | content = File.read(f) 9 | 10 | test = "" 11 | response = "" 12 | content.each_line { |l| 13 | if (l =~ /^;;\s*(.*)/) 14 | expected = $1 15 | 16 | actual = block.call(test.strip) 17 | 18 | if (expected != actual) 19 | print "\nERROR in #{f}\n" 20 | print "EXPECTED: #{expected}\n" 21 | print "ACTUAL : #{actual}\n\n" 22 | fail 23 | elsif (actual == "") 24 | print "don't worry, failure expected\n" 25 | end 26 | 27 | test = "" 28 | else 29 | test += l 30 | end 31 | } 32 | end 33 | 34 | def run_test(test_data) 35 | dir = "/tmp/scheme-llvm" 36 | fin = dir + "/test.scm" 37 | fll = dir + "/test.ll" 38 | fbc = dir + "/test.bc" 39 | fmain = dir + "/main.bc" 40 | fout = dir + "/test.out" 41 | 42 | stream = open(fin, "w") 43 | stream.write(test_data) 44 | stream.close 45 | 46 | sh "cat #{fin} | csi -s compile.scm | cpp -P > #{fll}" 47 | sh "llvm-as -f -o #{fbc} #{fll}" 48 | sh "llvm-link -f -o #{fmain} runtime.bc #{fbc}" 49 | 50 | actual = "" 51 | sh "lli #{fmain} > #{fout}" do |ok, res| 52 | if ! ok 53 | actual = "" 54 | else 55 | stream = open(fout) 56 | actual = stream.read(); 57 | stream.close() 58 | end 59 | end 60 | 61 | actual 62 | end 63 | 64 | def verify_test(test_data) 65 | test_data = "(display (begin " + test_data + "))" 66 | 67 | fin = Tempfile.new("scheme-llvm-test-in") 68 | fout = Tempfile.new("scheme-llvm-test-out") 69 | fin.write(test_data) 70 | fin.close 71 | 72 | actual = "" 73 | sh "csi -s #{fin.path} > #{fout.path}" do |ok, res| 74 | if ! ok 75 | actual = "" 76 | else 77 | actual = fout.read() 78 | end 79 | end 80 | actual 81 | end 82 | 83 | TESTS.each do |f| 84 | task "verify_#{f}" => f do 85 | process_test_file(f) { |test_data| 86 | verify_test(test_data) 87 | } 88 | end 89 | 90 | task "run_#{f}" => [f, "verify_#{f}"] do 91 | mkdir_p "/tmp/scheme-llvm" 92 | process_test_file(f) { |test_data| 93 | run_test(test_data) 94 | } 95 | end 96 | 97 | task :all => "run_#{f}" 98 | end 99 | 100 | task :all do 101 | print "\n----------\nTEST SUITE PASSED\n----------\n\n" 102 | end 103 | 104 | 105 | end 106 | --------------------------------------------------------------------------------