Permalink
Browse files

Init commit

  • Loading branch information...
0 parents commit 030fbd9db404424213b0f2b3166597c67996b47d Meng Zhang committed Jan 3, 2013
Showing with 1,809 additions and 0 deletions.
  1. +62 −0 README.md
  2. +71 −0 ast.scm
  3. +71 −0 classify.scm
  4. +58 −0 closure.scm
  5. +14 −0 denotation.scm
  6. +209 −0 environment.scm
  7. +57 −0 expr.scm
  8. +476 −0 lib/init.scm
  9. +112 −0 nova.scm
  10. +155 −0 standard.scm
  11. +524 −0 tests/r5rs-tests.scm
62 README.md
@@ -0,0 +1,62 @@
+# Nova
+An R7RS implementation on the top of gambit scheme, and largely influenced by [chibi-scheme](http://code.google.com/p/chibi-scheme) and riaxpander.
+
+Currently a test suite(tests/r5rs-tests.scm) from chibi-scheme is fully passed with small modification.
+
+# Finished
+1. Hygienic Macro System (define-syntax, let-syntax, letrec-syntax)
+
+ Implemented with syntactic-closure. syntax-rules is supported with an modified chibi's version.
+
+# TODO
+1. R7RS module system support.
+
+2. Error message improvement
+
+ Most internal syntax didn't report location in error message, as the location information already
+ saved in expression's meta data, it should be trival to implement this.
+
+3. Proper local variable naming
+
+ All local variable will compiles into a form of "name.location-number", this could be improved.
+
+
+4. let-syntax, letrec-syntax lacks support for moving internal definition to proper location.
+
+```scheme
+ (let ()
+ (+ 1 2)
+ (let-syntax ()
+ (define x 100))
+ x)
+```
+
+expanded to
+
+```scheme
+ ((lambda ()
+ (+ 1 2)
+ (define x 100)
+ x))
+```
+
+which will report ill placed define error.
+
+
+# Internal document
+
+1. Environment
+
+ Mapping from `Name` to `Denotation`
+
+2. Denotation
+
+ A variable or macro transformer.
+
+3. Name
+
+ `Alias` or symbol
+
+4. Alias
+
+ A syntactic closure which has a `Name` form.
71 ast.scm
@@ -0,0 +1,71 @@
+;; AST definition
+(define-type ast
+ extender: define-ast-type
+ (meta ast/meta))
+
+(define-ast-type lit
+ (value lit/value))
+
+(define-ast-type ref
+ (name ref/name) ;; name?
+ (variable ref/variable)) ;; variable?, maybe #f
+
+(define-ast-type set
+ (variable set/variable) ;; ref?
+ (value set/value)) ;; ast?
+
+(define-ast-type def
+ (variable def/variable) ;; ref?
+ (value def/value)) ;; (promise of ast?)
+
+(define-ast-type app
+ (operator app/operator) ;; ast?
+ (params app/params)) ;; list of ast?
+
+(define-ast-type seq
+ (body seq/body)) ;; list of ast?
+
+(define-ast-type lam
+ (params lam/params) ;; list of ref?
+ (body lam/body) ;; list of ast?
+ (environment lam/environment unprintable:)) ;; environment
+
+(define-ast-type cnd
+ (test cnd/test) ;; ast?
+ (success cnd/success) ;; ast?
+ (fail cnd/fail)) ;; ast?
+
+(define (compile-ref ref)
+ (if (not (ref/variable ref))
+ (name->symbol (ref/name ref))
+ (let ((name (variable/name (ref/variable ref)))
+ (location (variable/location (ref/variable ref))))
+ (cond ((number? location)
+ (string->symbol
+ (string-append (symbol->string (name->symbol name))
+ "."
+ (number->string location #d10))))
+ ((name? location)
+ (name->symbol location))
+ (else
+ (error "Variable has bogus location" location))))))
+
+(define (ast->expr x #!optional (meta '(#(source1) "(generated)" 1 1)))
+ (let* ((a2e (lambda (expr) (ast->expr expr (or (ast/meta x) meta))))
+ (sexp
+ (cond
+ ((lam? x)
+ `(##lambda ,(map* a2e (lam/params x))
+ ,@(map a2e (lam/body x))))
+ ((cnd? x) `(##if ,(a2e (cnd/test x)) ,(a2e (cnd/success x)) ,(a2e (cnd/fail x))))
+ ((set? x) `(##set! ,(a2e (set/variable x)) ,(a2e (set/value x))))
+ ((def? x) `(##define ,(a2e (def/variable x)) ,(a2e (force (def/value x)))))
+ ((ref? x) (compile-ref x))
+ ((seq? x) `(##begin ,@(map a2e (seq/body x))))
+ ((lit? x)
+ (let ((v (lit/value x)))
+ (if (or (pair? v) (vector? v) (null? v) (symbol? v)) `',v v)))
+ ((app? x) (cons (a2e (app/operator x)) (map a2e (app/params x))))
+ (else
+ (classify-error "Invalid ast type:" x)))))
+ (make-expr sexp (or (ast/meta x) meta))))
71 classify.scm
@@ -0,0 +1,71 @@
+;; returns: List of AST
+(define (classify* forms environment)
+ (map (lambda (x) (classify x environment)) forms))
+
+
+;; Form x Environment -> AST | Macro
+(define (classify expr environment #!optional (allow-macro #f))
+ (receive-expr* (form meta) expr
+ (cond
+ ((pair? form)
+ (classify-pair expr environment))
+ ((name? form)
+ (classify-name expr environment allow-macro))
+ ((syntactic-closure? form)
+ (classify-syntactic-closure expr environment))
+ (else
+ ;; Self evaluating
+ (make-lit meta form)))))
+
+;; returns: AST
+(define (classify-syntactic-closure expr environment)
+ (receive-expr* (form meta) expr
+ (let ((environment*
+ (syntactic-filter (syntactic-closure/environment form)
+ (syntactic-closure/free-names form)
+ environment))
+ (form*
+ (syntactic-closure/form form)))
+ (classify form* environment*))))
+
+;; returns: Ref AST | Macro
+(define (classify-name expr environment allow-macro)
+ (receive-expr* (name meta) expr
+ (cond ((syntactic-lookup environment name)
+ => (lambda (denotation)
+ (cond ((variable? denotation)
+ (make-ref meta name denotation))
+ ((macro? denotation)
+ (if allow-macro
+ denotation
+ (classify-error "Invalid usage macro as variable" denotation name environment)))
+ (else
+ (classify-error "Invalid denotation:" denotation name environment)))))
+ (else
+ ;; free-vars
+ (make-ref meta (name->symbol name) #f)))))
+
+(define (classify-pair expr environment)
+ (receive-expr* (form meta) expr
+ (let ((operator (classify (car form) environment #t)))
+ (if (macro? operator)
+ (classify-macro operator expr environment)
+ (classify-apply operator expr environment)))))
+
+;; returns: Ref Ast
+(define (classify-apply operator expr environment)
+ (receive-expr* (form meta) expr
+ (make-app meta
+ operator
+ (classify* (cdr form) environment))))
+
+;; returns: Form
+(define (classify-macro macro expr environment)
+ (let ((result
+ ((macro/procedure macro) expr environment (macro/environment macro))))
+ (if (ast? result)
+ result
+ (classify result environment))))
+
+(define (classify-error . msg)
+ (apply error msg))
58 closure.scm
@@ -0,0 +1,58 @@
+(define-type syntactic-closure
+ constructor: make-syntactic-closure-internal
+ (environment syntactic-closure/environment unprintable:)
+ (free-names syntactic-closure/free-names unprintable:)
+ (form syntactic-closure/form))
+
+(define (make-syntactic-closure environment free-names form)
+ (if (closure-elision-safe? environment free-names form)
+ form
+ (make-syntactic-closure-internal environment free-names form)))
+
+(define (closure-elision-safe? environment free-names form)
+ environment ;ignore
+ (cond ((memq form free-names) ;++ Is EQ? the best comparator here?
+ #t)
+ ((syntactic-closure? form)
+ (not (or (pair? free-names)
+ (name? (syntactic-closure/form form)))))
+ ;; This is not valid unless the environment in which the
+ ;; syntactic closure is used agrees on whether the datum is
+ ;; self-evaluating or not.
+ ;; ((self-evaluating? form environment)
+ ;; #t)
+ (else #f)))
+
+(define (close-syntax form environment)
+ (make-syntactic-closure environment '() form))
+
+(define (name? object)
+ (or (symbol? object)
+ (alias? object)))
+
+(define (alias? object)
+ (and (syntactic-closure? object)
+ (name? (syntactic-closure/form object))))
+
+(define (name->symbol name)
+ (let ((lose (lambda ()
+ (name->symbol (error "Not a name:" name)))))
+ (let loop ((name name))
+ (cond ((syntactic-closure? name) (loop (syntactic-closure/form name)))
+ ((symbol? name) name)
+ (else (lose))))))
+
+(define (syntax->datum form)
+ (if (let recur ((form form))
+ (if (pair? form)
+ (or (recur (car form))
+ (recur (cdr form)))
+ (syntactic-closure? form)))
+ (let recur ((form form))
+ (cond ((pair? form)
+ (cons (recur (car form))
+ (recur (cdr form))))
+ ((syntactic-closure? form)
+ (recur (syntactic-closure/form form)))
+ (else form)))
+ form))
14 denotation.scm
@@ -0,0 +1,14 @@
+(define-type macro
+ (environment macro/environment unprintable:)
+ (procedure macro/procedure unprintable:))
+
+(define-type variable
+ (name variable/name)
+ (location variable/location))
+
+(define (denotation=? denotation-a denotation-b)
+ (or (eq? denotation-a denotation-b)
+ (and (variable? denotation-a)
+ (variable? denotation-b)
+ (eqv? (variable/location denotation-a)
+ (variable/location denotation-b)))))
209 environment.scm
@@ -0,0 +1,209 @@
+(define-type syntactic-environment
+ (operations syntactic-environment/operations unprintable:)
+ (parent syntactic-environment/parent unprintable:)
+ (data syntactic-environment/data set-syntactic-environment/data! unprintable:))
+
+(define-type syntactic-operations
+ (lookup syntactic-operations/lookup)
+ (bind! syntactic-operations/bind!)
+ (seal! syntactic-operations/seal!)
+ (disclose syntactic-operations/disclose))
+
+(define (null-syntactic-environment parameters . context)
+ (make-syntactic-environment null-syntactic-operations #f context))
+
+(define null-syntactic-operations
+ (let ()
+ (define (lose operation)
+ (error "Null syntactic environment:" operation))
+ (make-syntactic-operations
+ (lambda (environment name)
+ (lose `(syntactic-lookup ,environment ,name)))
+ (lambda (environment name denotation)
+ (lose `(syntactic-bind! ,environment ,name ,denotation)))
+ (lambda (environment)
+ (lose `(syntactic-seal! ,environment)))
+ (lambda (environment)
+ `(NULL ,@(syntactic-environment/data environment))))))
+
+;;; `Sealing' changes the state of the environment to indicate that no
+;;; further changes will be made to it. In the case of splicing
+;;; environments, this means that all new bindings will be made in the
+;;; parent;
+
+(define (syntactic-seal! environment)
+ ((syntactic-operations/seal! (syntactic-environment/operations environment))
+ environment))
+
+(define (syntactic-lookup environment name)
+ ((syntactic-operations/lookup (syntactic-environment/operations environment))
+ environment name))
+
+(define (syntactic-bind! environment name denotation)
+ (if (not (name? name))
+ (classify-error "Cannot bind non-identifier " name denotation))
+ ((syntactic-operations/bind! (syntactic-environment/operations environment))
+ environment name denotation))
+
+(define (disclose-syntactic-environment environment)
+ ((syntactic-operations/disclose
+ (syntactic-environment/operations environment))
+ environment))
+
+;; TODO: allocate-location
+(define (bind-variable! name environment)
+ (let ((variable (make-variable name (allocate-location environment name))))
+ (syntactic-bind! environment name variable)
+ variable))
+
+(define (name=? environment-a name-a environment-b name-b)
+ (if (and (name? name-a) (name? name-b))
+ (let ((denotation-a (syntactic-lookup environment-a name-a))
+ (denotation-b (syntactic-lookup environment-b name-b)))
+ (cond ((and denotation-a denotation-b)
+ (denotation=? denotation-a denotation-b))
+ ((and (not denotation-a) (not denotation-b))
+ (eq? (name->symbol name-a)
+ (name->symbol name-b)))
+ (else #f)))
+ #f))
+
+;;;; Extended Environments
+;;; Extended environments are simply frames in the environment tree
+;;; in which local bindings can be introduced.
+(define (syntactic-extend environment)
+ (make-syntactic-environment extended-syntactic-operations
+ environment
+ '()))
+
+(define extended-syntactic-operations
+ (let ()
+ (define (local-bindings environment)
+ (syntactic-environment/data environment))
+ (define (set-local-bindings! environment bindings)
+ (set-syntactic-environment/data! environment bindings))
+ (make-syntactic-operations
+ (lambda (environment name) ;lookup
+ (cond ((assq name (local-bindings environment))
+ => cdr)
+ (else
+ (syntactic-lookup (syntactic-environment/parent environment)
+ name))))
+ (lambda (environment name denotation) ;bind!
+ ;++ This should report more useful (and restartable) errors.
+ (cond ((assq name (local-bindings environment))
+ => (lambda (original-binding)
+ (error "Rebinding name:" environment name denotation
+ `(was ,(cdr original-binding)))))
+ (else
+ (set-local-bindings! environment
+ (cons (cons name denotation)
+ (local-bindings environment))))))
+ (lambda (environment) ;seal!
+ (void))
+ (lambda (environment) ;disclose
+ `(EXTENDED ,(map car (local-bindings environment)))))))
+
+;;;; Filtered Environments
+;;; Filtered environments are used to classify the form of a syntactic
+;;; closure; they make the free names of syntactic closures work.
+
+(define (syntactic-filter closing-environment free-names free-environment)
+ (if (or (not (pair? free-names))
+ (eq? closing-environment free-environment))
+ closing-environment
+ (make-syntactic-environment
+ filtered-syntactic-operations
+ closing-environment
+ (cons free-environment free-names))))
+
+(define filtered-syntactic-operations
+ (let ()
+ (define (closing-environment environment)
+ (syntactic-environment/parent environment))
+ (define (free-environment environment)
+ (car (syntactic-environment/data environment)))
+ (define (free-names environment)
+ (cdr (syntactic-environment/data environment)))
+ (define (choose-parent environment name)
+ ((if (memq name (free-names environment))
+ free-environment
+ closing-environment)
+ environment))
+ (make-syntactic-operations
+ (lambda (environment name) ;lookup
+ (syntactic-lookup (choose-parent environment name) name))
+ (lambda (environment name denotation) ;bind!
+ (syntactic-bind! (choose-parent environment name) name denotation))
+ (lambda (environment) ;seal!
+ (void))
+ (lambda (environment) ;disclose
+ `(FILTERED ,(free-names environment))))))
+
+;;;; Splicing Environments
+
+;;; These are for implementing LET-SYNTAX and LETREC-SYNTAX.
+
+(define (syntactic-splicing-extend environment)
+ (make-syntactic-environment splicing-syntactic-operations
+ environment
+ (cons #f '())))
+
+(define splicing-syntactic-operations
+ (let ()
+ (define (sealed? environment)
+ (car (syntactic-environment/data environment)))
+ (define (seal! environment)
+ (set-car! (syntactic-environment/data environment) #t))
+ (define (local-bindings environment)
+ (cdr (syntactic-environment/data environment)))
+ (define (set-local-bindings! environment bindings)
+ (set-cdr! (syntactic-environment/data environment) bindings))
+ (make-syntactic-operations
+ (lambda (environment name) ;lookup
+ (cond ((assq name (local-bindings environment))
+ => cdr)
+ (else
+ (syntactic-lookup (syntactic-environment/parent environment)
+ name))))
+ (lambda (environment name denotation) ;bind!
+ (cond ((assq name (local-bindings environment))
+ => (lambda (original-binding)
+ (error "Rebinding name:" environment name denotation
+ `(was ,(cdr original-binding)))))
+ ((sealed? environment)
+ (syntactic-bind! (syntactic-environment/parent environment)
+ name
+ denotation))
+ (else
+ (set-local-bindings! environment
+ (cons (cons name denotation)
+ (local-bindings environment))))))
+ (lambda (environment) ;seal!
+ (seal! environment))
+ (lambda (environment) ;disclose
+ `(SPLICING ,(map car (local-bindings environment)))))))
+
+;;;; Macrologies
+
+(define (apply-macrology macrology environment)
+ (macrology environment))
+
+(define null-macrology
+ (lambda (environment)
+ environment ;ignore
+ (values)))
+
+(define (make-macrology receiver)
+ (lambda (environment)
+ (define (define-macro name procedure)
+ (syntactic-bind! environment name (make-macro environment procedure)))
+ (receiver define-macro)))
+
+(define (compose-macrologies . macrologies)
+ (reduce compose-macrology null-macrology macrologies))
+
+(define (compose-macrology macrology-a macrology-b)
+ (lambda (environment)
+ (macrology-a environment)
+ (macrology-b environment)))
57 expr.scm
@@ -0,0 +1,57 @@
+(define (expr? obj) ;; returns false for expressions without 'attached notes'
+ (and (vector? obj)
+ (##fixnum.= (##vector-length obj) 4)
+ (let ((v0 (##vector-ref obj 0)))
+ (and (vector? v0)
+ (##fixnum.= (##vector-length v0) 1)
+ (let ((v00 (##vector-ref v0 0)))
+ (case v00
+ ((source1 source2) #t)
+ (else #f)))))))
+
+(define (expr/form expr)
+ (vector-ref expr 1))
+
+(define (expr/meta expr)
+ (let ((type (vector-ref expr 0))
+ (file (or (vector-ref expr 2) "(generated)"))
+ (pos (or (vector-ref expr 3) 0)))
+ (list type file (pos/line pos) (pos/col pos))))
+
+(define (expr*/form expr)
+ (if (expr? expr)
+ (expr/form expr)
+ expr))
+
+(define (expr*/meta expr)
+ (if (expr? expr)
+ (expr/meta expr)
+ #f))
+
+(define (pos/line pos)
+ (+ 1 (bitwise-and pos 65535)))
+
+(define (pos/col pos)
+ (+ 1 (quotient pos 65536)))
+
+(define (make-pos line col)
+ (+ (##fixnum.- line 1)
+ (* (##fixnum.- col 1) 65536)))
+
+(define-macro (receive-expr* sym expr . body)
+ `(receive ,sym
+ (if (expr? ,expr)
+ (values (expr/form ,expr) (expr/meta ,expr))
+ (values ,expr #f))
+ ,@body))
+
+(define (expr-strip-meta expr)
+ (receive-expr* (v _) expr
+ (cond ((pair? v)
+ (map* expr-strip-meta v))
+ ((vector? v)
+ (vector-map expr-strip-meta v))
+ (else v))))
+
+(define (make-expr form meta)
+ (vector (car meta) form (cadr meta) (make-pos (caddr meta) (cadddr meta))))
476 lib/init.scm
@@ -0,0 +1,476 @@
+(define identifier? name?)
+(define identifier=? name=?)
+
+(define (cons-source kar kdr source)
+ (cons kar kdr))
+
+(define (any pred ls . lol)
+ (define (any1 pred ls)
+ (if (null? (cdr ls))
+ (pred (car ls))
+ ((lambda (x) (if x x (any1 pred (cdr ls)))) (pred (car ls)))))
+ (define (anyn pred lol)
+ (if (every pair? lol)
+ ((lambda (x) (if x x (anyn pred (map cdr lol))))
+ (apply pred (map car lol)))
+ #f))
+ (if (null? lol) (if (pair? ls) (any1 pred ls) #f) (anyn pred (cons ls lol))))
+
+(define (every pred ls . lol)
+ (define (every1 pred ls)
+ (if (null? (cdr ls))
+ (pred (car ls))
+ (if (pred (car ls)) (every1 pred (cdr ls)) #f)))
+ (if (null? lol)
+ (if (pair? ls) (every1 pred ls) #t)
+ (not (apply any (lambda (x) (not (pred x))) ls lol))))
+
+(define (find-tail pred ls)
+ (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls)))))
+
+(define (find pred ls)
+ (cond ((find-tail pred ls) => car) (else #f)))
+
+(define sc-macro-transformer
+ (lambda (f)
+ (lambda (expr use-env mac-env)
+ (make-syntactic-closure mac-env '() (f (expr-strip-meta expr) use-env)))))
+
+(define rsc-macro-transformer
+ (lambda (f)
+ (lambda (expr use-env mac-env)
+ (f (expr-strip-meta expr) mac-env))))
+
+(define er-macro-transformer
+ (lambda (f)
+ (lambda (expr use-env mac-env)
+ ((lambda (rename compare) (f (expr-strip-meta expr) rename compare))
+ ((lambda (renames)
+ (lambda (identifier)
+ ((lambda (cell)
+ (if cell
+ (cdr cell)
+ ((lambda (name)
+ (set! renames (cons (cons identifier name) renames))
+ name)
+ (make-syntactic-closure mac-env '() identifier))))
+ (assq identifier renames))))
+ '())
+ (lambda (x y) (identifier=? use-env x use-env y))))))
+
+(define-syntax cond
+ (er-macro-transformer
+ (lambda (expr rename compare)
+ (if (null? (cdr expr))
+ #f
+ ((lambda (cl)
+ (if (compare (rename 'else) (car cl))
+ (if (pair? (cddr expr))
+ (error "non-final else in cond" expr)
+ (cons (rename 'begin) (cdr cl)))
+ (if (if (null? (cdr cl)) #t (compare (rename '=>) (cadr cl)))
+ (list (list (rename 'lambda) (list (rename 'tmp))
+ (list (rename 'if) (rename 'tmp)
+ (if (null? (cdr cl))
+ (rename 'tmp)
+ (list (car (cddr cl)) (rename 'tmp)))
+ (cons (rename 'cond) (cddr expr))))
+ (car cl))
+ (list (rename 'if)
+ (car cl)
+ (cons (rename 'begin) (cdr cl))
+ (cons (rename 'cond) (cddr expr))))))
+ (cadr expr))))))
+
+(define-syntax or
+ (er-macro-transformer
+ (lambda (expr rename compare)
+ (cond ((null? (cdr expr)) #f)
+ ((null? (cddr expr)) (cadr expr))
+ (else
+ (list (rename 'let) (list (list (rename 'tmp) (cadr expr)))
+ (list (rename 'if) (rename 'tmp)
+ (rename 'tmp)
+ (cons (rename 'or) (cddr expr)))))))))
+
+(define-syntax and
+ (er-macro-transformer
+ (lambda (expr rename compare)
+ (cond ((null? (cdr expr)))
+ ((null? (cddr expr)) (cadr expr))
+ (else (list (rename 'if) (cadr expr)
+ (cons (rename 'and) (cddr expr))
+ #f))))))
+
+(define-syntax quasiquote
+ (er-macro-transformer
+ (lambda (expr rename compare)
+ (define (qq x d)
+ (cond
+ ((pair? x)
+ (cond
+ ((compare (rename 'unquote) (car x))
+ (if (<= d 0)
+ (cadr x)
+ (list (rename 'list) (list (rename 'quote) 'unquote)
+ (qq (cadr x) (- d 1)))))
+ ((compare (rename 'unquote-splicing) (car x))
+ (if (<= d 0)
+ (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))
+ (list (rename 'list) (list (rename 'quote) 'unquote-splicing)
+ (qq (cadr x) (- d 1)))))
+ ((compare (rename 'quasiquote) (car x))
+ (list (rename 'list) (list (rename 'quote) 'quasiquote)
+ (qq (cadr x) (+ d 1))))
+ ((and (<= d 0) (pair? (car x))
+ (compare (rename 'unquote-splicing) (caar x)))
+ (if (null? (cdr x))
+ (cadr (car x))
+ (list (rename 'append) (cadr (car x)) (qq (cdr x) d))))
+ (else
+ (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)))))
+ ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d)))
+ ((if (symbol? x) #t (null? x)) (list (rename 'quote) x))
+ (else x)))
+ (qq (cadr expr) 0))))
+
+(define-syntax letrec
+ (er-macro-transformer
+ (lambda (expr rename compare)
+ ((lambda (defs)
+ `((,(rename 'lambda) () ,@defs ,@(cddr expr))))
+ (map (lambda (x) (cons (rename 'define) x)) (cadr expr))))))
+
+(define-syntax let
+ (er-macro-transformer
+ (lambda (expr rename compare)
+ (if (null? (cdr expr)) (error "empty let" expr))
+ (if (null? (cddr expr)) (error "no let body" expr))
+ ((lambda (bindings)
+ (if (list? bindings) #f (error "bad let bindings"))
+ (if (every (lambda (x)
+ (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f))
+ bindings)
+ ((lambda (vars vals)
+ (if (identifier? (cadr expr))
+ `((,(rename 'lambda) ,vars
+ (,(rename 'letrec) ((,(cadr expr)
+ (,(rename 'lambda) ,vars
+ ,@(cdr (cddr expr)))))
+ (,(cadr expr) ,@vars)))
+ ,@vals)
+ `((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals)))
+ (map car bindings)
+ (map cadr bindings))
+ (error "bad let syntax" expr)))
+ (if (identifier? (cadr expr)) (car (cddr expr)) (cadr expr))))))
+
+(define-syntax let*
+ (er-macro-transformer
+ (lambda (expr rename compare)
+ (if (null? (cdr expr)) (error "empty let*" expr))
+ (if (null? (cddr expr)) (error "no let* body" expr))
+ (if (null? (cadr expr))
+ `(,(rename 'let) () ,@(cddr expr))
+ (if (if (list? (cadr expr))
+ (every
+ (lambda (x)
+ (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f))
+ (cadr expr))
+ #f)
+ `(,(rename 'let) (,(caar (cdr expr)))
+ (,(rename 'let*) ,(cdar (cdr expr)) ,@(cddr expr)))
+ (error "bad let* syntax"))))))
+
+(define-syntax case
+ (er-macro-transformer
+ (lambda (expr rename compare)
+ (define (body exprs)
+ (cond
+ ((null? exprs)
+ (rename 'tmp))
+ ((compare (rename '=>) (car exprs))
+ `(,(cadr exprs) ,(rename 'tmp)))
+ (else
+ `(,(rename 'begin) ,@exprs))))
+ (define (clause ls)
+ (cond
+ ((null? ls) #f)
+ ((compare (rename 'else) (caar ls))
+ (body (cdar ls)))
+ ((and (pair? (car (car ls))) (null? (cdr (car (car ls)))))
+ `(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp)
+ (,(rename 'quote) ,(car (caar ls))))
+ ,(body (cdar ls))
+ ,(clause (cdr ls))))
+ (else
+ `(,(rename 'if) (,(rename 'memv) ,(rename 'tmp)
+ (,(rename 'quote) ,(caar ls)))
+ ,(body (cdar ls))
+ ,(clause (cdr ls))))))
+ `(let ((,(rename 'tmp) ,(cadr expr)))
+ ,(clause (cddr expr))))))
+
+(define-syntax do
+ (er-macro-transformer
+ (lambda (expr rename compare)
+ (let* ((body
+ `(,(rename 'begin)
+ ,@(cdr (cddr expr))
+ (,(rename 'lp)
+ ,@(map (lambda (x) (if (pair? (cddr x)) (car (cddr x)) (car x)))
+ (cadr expr)))))
+ (check (car (cddr expr)))
+ (wrap
+ (if (null? (cdr check))
+ `(,(rename 'let) ((,(rename 'tmp) ,(car check)))
+ (,(rename 'if) ,(rename 'tmp)
+ ,(rename 'tmp)
+ ,body))
+ `(,(rename 'if) ,(car check)
+ (,(rename 'begin) ,@(cdr check))
+ ,body))))
+ `(,(rename 'let) ,(rename 'lp)
+ ,(map (lambda (x) (list (car x) (cadr x))) (cadr expr))
+ ,wrap)))))
+
+(define-syntax define-auxiliary-syntax
+ (er-macro-transformer
+ (lambda (expr rename compare)
+ `(,(rename 'define-syntax) ,(cadr expr)
+ (,(rename 'er-macro-transformer)
+ (,(rename 'lambda) (expr rename compare)
+ (,(rename 'error) "invalid use of auxiliary syntax" ',(cadr expr))))))))
+
+(define-auxiliary-syntax _)
+(define-auxiliary-syntax =>)
+(define-auxiliary-syntax ...)
+(define-auxiliary-syntax else)
+(define-auxiliary-syntax unquote)
+(define-auxiliary-syntax unquote-splicing)
+
+(define-syntax syntax-rules
+ (er-macro-transformer
+ (lambda (expr rename compare)
+ (let ((ellipsis-specified? (identifier? (cadr expr)))
+ (count 0)
+ (_er-macro-transformer (rename 'er-macro-transformer))
+ (_lambda (rename 'lambda)) (_let (rename 'let))
+ (_begin (rename 'begin)) (_if (rename 'if))
+ (_and (rename 'and)) (_or (rename 'or))
+ (_eq? (rename 'eq?)) (_equal? (rename 'equal?))
+ (_car (rename 'car)) (_cdr (rename 'cdr))
+ (_cons (rename 'cons)) (_pair? (rename 'pair?))
+ (_null? (rename 'null?)) (_expr (rename 'expr))
+ (_rename (rename 'rename)) (_compare (rename 'compare))
+ (_quote (rename 'syntax-quote)) (_apply (rename 'apply))
+ (_append (rename 'append)) (_map (rename 'map))
+ (_vector? (rename 'vector?)) (_list? (rename 'list?))
+ (_len (rename 'len)) (_length (rename 'length))
+ (_- (rename '-)) (_>= (rename '>=)) (_error (rename 'error))
+ (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i))
+ (_reverse (rename 'reverse))
+ (_vector->list (rename 'vector->list))
+ (_list->vector (rename 'list->vector))
+ (_cons3 (rename 'cons-source)))
+ (define ellipsis (rename (if ellipsis-specified? (cadr expr) '...)))
+ (define lits (if ellipsis-specified? (car (cddr expr)) (cadr expr)))
+ (define forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr)))
+ (define (next-symbol s)
+ (set! count (+ count 1))
+ (rename (string->symbol (string-append s (number->string count)))))
+ (define (expand-pattern pat tmpl)
+ (let lp ((p (cdr pat))
+ (x (list _cdr _expr))
+ (dim 0)
+ (vars '())
+ (k (lambda (vars)
+ (list _cons (expand-template tmpl vars) #f))))
+ (let ((v (next-symbol "v.")))
+ (list
+ _let (list (list v x))
+ (cond
+ ((identifier? p)
+ (if (any (lambda (l) (compare p l)) lits)
+ (list _and
+ (list _compare v (list _rename (list _quote p)))
+ (k vars))
+ (list _let (list (list p v)) (k (cons (cons p dim) vars)))))
+ ((ellipsis? p)
+ (cond
+ ((not (null? (cdr (cdr p))))
+ (cond
+ ((any (lambda (x) (and (identifier? x) (compare x ellipsis)))
+ (cddr p))
+ (error "multiple ellipses" p))
+ (else
+ (let ((len (length (cdr (cdr p))))
+ (_lp (next-symbol "lp.")))
+ `(,_let ((,_len (,_length ,v)))
+ (,_and (,_>= ,_len ,len)
+ (,_let ,_lp ((,_ls ,v)
+ (,_i (,_- ,_len ,len))
+ (,_res (,_quote ())))
+ (,_if (,_>= 0 ,_i)
+ ,(lp `(,(cddr p)
+ (,(car p) ,(car (cdr p))))
+ `(,_cons ,_ls
+ (,_cons (,_reverse ,_res)
+ (,_quote ())))
+ dim
+ vars
+ k)
+ (,_lp (,_cdr ,_ls)
+ (,_- ,_i 1)
+ (,_cons3 (,_car ,_ls)
+ ,_res
+ ,_ls))))))))))
+ ((identifier? (car p))
+ (list _and (list _list? v)
+ (list _let (list (list (car p) v))
+ (k (cons (cons (car p) (+ 1 dim)) vars)))))
+ (else
+ (let* ((w (next-symbol "w."))
+ (_lp (next-symbol "lp."))
+ (new-vars (all-vars (car p) (+ dim 1)))
+ (ls-vars (map (lambda (x)
+ (next-symbol
+ (string-append
+ (symbol->string
+ (identifier->symbol (car x)))
+ "-ls")))
+ new-vars))
+ (once
+ (lp (car p) (list _car w) (+ dim 1) '()
+ (lambda (_)
+ (cons
+ _lp
+ (cons
+ (list _cdr w)
+ (map (lambda (x l)
+ (list _cons (car x) l))
+ new-vars
+ ls-vars)))))))
+ (list
+ _let
+ _lp (cons (list w v)
+ (map (lambda (x) (list x (list _quote '()))) ls-vars))
+ (list _if (list _null? w)
+ (list _let (map (lambda (x l)
+ (list (car x) (list _reverse l)))
+ new-vars
+ ls-vars)
+ (k (append new-vars vars)))
+ (list _and (list _pair? w) once)))))))
+ ((pair? p)
+ (list _and (list _pair? v)
+ (lp (car p)
+ (list _car v)
+ dim
+ vars
+ (lambda (vars)
+ (lp (cdr p) (list _cdr v) dim vars k)))))
+ ((vector? p)
+ (list _and
+ (list _vector? v)
+ (lp (vector->list p) (list _vector->list v) dim vars k)))
+ ((null? p) (list _and (list _null? v) (k vars)))
+ (else (list _and (list _equal? v p) (k vars))))))))
+ (define (ellipsis-escape? x) (and (pair? x) (compare ellipsis (car x))))
+ (define (ellipsis? x)
+ (and (pair? x) (pair? (cdr x)) (compare ellipsis (cadr x))))
+ (define (ellipsis-depth x)
+ (if (ellipsis? x)
+ (+ 1 (ellipsis-depth (cdr x)))
+ 0))
+ (define (ellipsis-tail x)
+ (if (ellipsis? x)
+ (ellipsis-tail (cdr x))
+ (cdr x)))
+ (define (all-vars x dim)
+ (let lp ((x x) (dim dim) (vars '()))
+ (cond ((identifier? x)
+ (if (any (lambda (lit) (compare x lit)) lits)
+ vars
+ (cons (cons x dim) vars)))
+ ((ellipsis? x) (lp (car x) (+ dim 1) (lp (cddr x) dim vars)))
+ ((pair? x) (lp (car x) dim (lp (cdr x) dim vars)))
+ ((vector? x) (lp (vector->list x) dim vars))
+ (else vars))))
+ (define (free-vars x vars dim)
+ (let lp ((x x) (free '()))
+ (cond
+ ((identifier? x)
+ (if (and (not (memq x free))
+ (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim)))
+ (else #f)))
+ (cons x free)
+ free))
+ ((pair? x) (lp (car x) (lp (cdr x) free)))
+ ((vector? x) (lp (vector->list x) free))
+ (else free))))
+ (define (expand-template tmpl vars)
+ (let lp ((t tmpl) (dim 0))
+ (cond
+ ((identifier? t)
+ (cond
+ ((find (lambda (v) (compare t (car v))) vars)
+ => (lambda (cell)
+ (if (<= (cdr cell) dim)
+ t
+ (error "too few ...'s"))))
+ (else
+ (list _rename (list _quote t)))))
+ ((pair? t)
+ (cond
+ ((ellipsis-escape? t)
+ (list _quote
+ (if (pair? (cdr t))
+ (if (pair? (cddr t)) (cddr t) (cadr t))
+ (cdr t))))
+ ((ellipsis? t)
+ (let* ((depth (ellipsis-depth t))
+ (ell-dim (+ dim depth))
+ (ell-vars (free-vars (car t) vars ell-dim)))
+ (cond
+ ((null? ell-vars)
+ (error "too many ...'s"))
+ ((and (null? (cdr (cdr t))) (identifier? (car t)))
+ ;; shortcut for (var ...)
+ (lp (car t) depth))
+ (else
+ (let* ((once (lp (car t) ell-dim))
+ (nest (if (and (null? (cdr ell-vars))
+ (identifier? once)
+ (eq? once (car vars)))
+ once ;; shortcut
+ (cons _map
+ (cons (list _lambda ell-vars once)
+ ell-vars))))
+ (many (do ((d depth (- d 1))
+ (many nest
+ (list _apply _append many)))
+ ((= d 1) many))))
+ (if (null? (ellipsis-tail t))
+ many ;; shortcut
+ (list _append many (lp (ellipsis-tail t) dim))))))))
+ (else (list _cons3 (lp (car t) dim) (lp (cdr t) dim) (list _quote t)))))
+ ((vector? t) (list _list->vector (lp (vector->list t) dim)))
+ ((null? t) (list _quote '()))
+ (else t))))
+ (list
+ _er-macro-transformer
+ (list _lambda (list _expr _rename _compare)
+ (list
+ _car
+ (cons
+ _or
+ (append
+ (map
+ (lambda (clause) (expand-pattern (car clause) (cadr clause)))
+ forms)
+ (list
+ (list _cons
+ (list _error "no expansion for"
+ (list (rename 'strip-syntactic-closures) _expr))
+ #f)))))))))))
112 nova.scm
@@ -0,0 +1,112 @@
+;; Required by bind-variable!
+(define current-location-uid (make-parameter 0))
+(define (allocate-location environment name)
+ (if (not (syntactic-environment/parent environment))
+ name
+ (let ((uid (current-location-uid)))
+ (current-location-uid (+ uid 1))
+ uid)))
+(define (map* proc lst)
+ (let recur ((lst lst))
+ (cond ((pair? lst)
+ (cons (proc (car lst))
+ (recur (cdr lst))))
+ ((null? lst) '())
+ (else
+ (proc lst)))))
+(define (vector-map fn vec)
+ (let* ((len (vector-length vec))
+ (v (make-vector len)))
+ (let loop ((i 0))
+ (cond
+ ((< i len)
+ (vector-set! v
+ i
+ (fn (vector-ref vec i)))
+ (loop (+ 1 i)))))
+ v))
+(define (eval-no-hook expr)
+ (let ((hook ##expand-source))
+ (dynamic-wind
+ (lambda ()
+ (set! ##expand-source (lambda (src) src)))
+ (lambda ()
+ (eval expr))
+ (lambda ()
+ (set! ##expand-source hook)))))
+
+(include "expr.scm")
+(include "ast.scm")
+(include "denotation.scm")
+(include "environment.scm")
+(include "closure.scm")
+(include "classify.scm")
+(include "standard.scm")
+
+(define top-level-operations
+ (let ()
+ (define (global-bindings environment)
+ (syntactic-environment/data environment))
+ (define (set-global-bindings! environment bindings)
+ (set-syntactic-environment/data! environment bindings))
+ (make-syntactic-operations
+ (lambda (environment name) ;lookup
+ (cond ((assq name (global-bindings environment))
+ => cdr)
+ ((syntactic-closure? name)
+ (syntactic-lookup (syntactic-closure/environment name)
+ (syntactic-closure/form name)))
+ (else
+ #f)))
+ (lambda (environment name denotation) ;bind!
+ (set-global-bindings! environment
+ (cons (cons name denotation)
+ (global-bindings environment))))
+ (lambda (environment) ;seal!
+ (void))
+ (lambda (environment) ;disclose
+ environment ;ignore
+ `(TOPLEVEL ,(map car (global-bindings environment)))))))
+
+(define (make-top-level-environment)
+ (let ((environment
+ (make-syntactic-environment top-level-operations
+ #f
+ '())))
+ environment))
+
+
+;; Core forms
+(define core-form-environment
+ (make-top-level-environment))
+(apply-macrology (macrology/define) core-form-environment)
+(apply-macrology (macrology/set!) core-form-environment)
+(apply-macrology (macrology/begin) core-form-environment)
+(apply-macrology (macrology/lambda) core-form-environment)
+(apply-macrology (macrology/if) core-form-environment)
+(apply-macrology (macrology/quote) core-form-environment)
+(apply-macrology (macrology/syntax-quote) core-form-environment)
+(apply-macrology (macrology/define-syntax) core-form-environment)
+(apply-macrology (macrology/let-syntax) core-form-environment)
+(apply-macrology (macrology/letrec-syntax) core-form-environment)
+
+(define (hook expr)
+ (define ast #f)
+ (define source #f)
+ (define sexp #f)
+ (set! ast (classify expr core-form-environment))
+ ;(display "AST: ")
+ ;(pp ast)
+
+ (set! source (ast->expr ast))
+ ;(display "Source: ")
+ ;(pp source)
+
+ (set! sexp (expr-strip-meta source))
+ (display "Sexp: ")
+ (pp sexp)
+ source)
+(set! ##expand-source hook)
+
+;(ast->sexp (classify '((lambda (x) 4) '(1 2 3 4)) core-form-environment))
+
155 standard.scm
@@ -0,0 +1,155 @@
+;;; Core forms
+
+;; (set! var val) -> set ast
+(define (macrology/set!)
+ (make-macrology
+ (lambda (define-macro)
+ (define-macro 'set!
+ (lambda (expr use-env mac-env)
+ (receive-expr* (form meta) expr
+ (if (not (and (= (length form) 3)
+ (name? (expr*/form (cadr form)))))
+ (classify-error "bad set! syntax" form))
+ (make-set meta (classify (cadr form) use-env) (classify (caddr form) use-env))))))))
+
+;; (define var val) -> def ast
+(define (macrology/define)
+ (make-macrology
+ (lambda (define-macro)
+ (define-macro 'define
+ (lambda (expr use-env mac-env)
+ (receive-expr* (form meta) expr
+ (if (< (length form) 3)
+ (classify-error "bad define syntax" form))
+ (receive (name body)
+ (if (name? (expr*/form (cadr form)))
+ (values (cadr form) (caddr form))
+ (values (car (expr*/form (cadr form)))
+ `(,(close-syntax 'lambda mac-env)
+ ,(cdr (expr*/form (cadr form)))
+ ,@(cddr form))))
+ (bind-variable! (expr*/form name) use-env)
+ (make-def meta (classify name use-env) (delay (classify body use-env))))))))))
+
+;; (begin . body) -> seq ast
+(define (macrology/begin)
+ (make-macrology
+ (lambda (define-macro)
+ (define-macro 'begin
+ (lambda (expr use-env mac-env)
+ (receive-expr* (form meta) expr
+ (make-seq meta (classify* (cdr form) use-env))))))))
+
+;; (lambda params . body) -> lam ast
+(define (macrology/lambda)
+ (make-macrology
+ (lambda (define-macro)
+ (define-macro 'lambda
+ (lambda (expr use-env mac-env)
+ (receive-expr* (form meta) expr
+ (if (< (length form) 3)
+ (classify-error "bad lambda syntax" form))
+ (let ((env (syntactic-extend use-env)))
+ (make-lam meta
+ (map* (lambda (expr)
+ (receive-expr* (x _) expr
+ (if (not (name? x))
+ (classify-error "bad lambda param" form)
+ (bind-variable! x env))
+ (classify expr env)))
+ (expr*/form (cadr form)))
+ (classify* (cddr form) (syntactic-extend env))
+ env))))))))
+
+;; (if test succ fail) -> seq ast
+(define (macrology/if)
+ (make-macrology
+ (lambda (define-macro)
+ (define-macro 'if
+ (lambda (expr use-env mac-env)
+ (receive-expr* (form meta) expr
+ (let ((fail
+ (case (length form)
+ ((3) (make-lit #f (void)))
+ ((4) (classify (cadddr form) use-env))
+ (else
+ (classify-error "bad if syntax" form)))))
+ (make-cnd meta
+ (classify (cadr form) use-env)
+ (classify (caddr form) use-env)
+ fail))))))))
+
+;; (quote form) -> lit ast
+(define (macrology/quote)
+ (make-macrology
+ (lambda (define-macro)
+ (define-macro 'quote
+ (lambda (expr use-env mac-env)
+ (receive-expr* (form meta) expr
+ (if (not (= (length form) 2))
+ (classify-error "bad quote syntax" form))
+ (make-lit meta (syntax->datum (expr-strip-meta (cadr form))))))))))
+
+;; (syntax-quote form) -> lit ast
+(define (macrology/syntax-quote)
+ (make-macrology
+ (lambda (define-macro)
+ (define-macro 'syntax-quote
+ (lambda (expr use-env mac-env)
+ (receive-expr* (form meta) expr
+ (if (not (= (length form) 2))
+ (classify-error "bad quote syntax" form))
+ (make-lit meta (expr-strip-meta (cadr form)))))))))
+
+(define (bind-syntax name value bind-env eval-env)
+ (let* ((ast (classify value eval-env #t))
+ (mac (if (macro? ast)
+ ast
+ ;; Where the MAGIC happens
+ (make-macro eval-env (eval-no-hook (expr-strip-meta (ast->expr ast)))))))
+ (if (and (macro? mac) (procedure? (macro/procedure mac)))
+ (syntactic-bind! bind-env name mac)
+ (classify-error "non-procedure macro" mac))))
+
+(define (macrology/define-syntax)
+ (make-macrology
+ (lambda (define-macro)
+ (define-macro 'define-syntax
+ (lambda (expr use-env mac-env)
+ (receive-expr* (form meta) expr
+ (if (not (and (= (length form) 3)
+ (name? (expr*/form (cadr form)))))
+ (classify-error "bad define-syntax syntax " form))
+ (bind-syntax (expr*/form (cadr form)) (caddr form) use-env use-env)
+ (make-lit meta (void))))))))
+
+(define (let-syntax-helper expr mac-env bind-env eval-env)
+ (receive-expr* (form meta) expr
+ (if (not (>= (length form) 3))
+ (classify-error "bad let-syntax " form))
+ (map
+ (lambda (x)
+ (receive-expr* (form meta) x
+ (if (not (name? (expr*/form (car form))))
+ (classify-error "bad let-syntax name " form))
+ (bind-syntax (expr*/form (car form)) (cadr form) bind-env eval-env)))
+ (expr*/form (cadr form)))
+ (syntactic-seal! bind-env)
+ (let ((body `(,(close-syntax 'begin mac-env) ,@(cddr form))))
+ (classify body bind-env #f))))
+
+(define (macrology/let-syntax)
+ (make-macrology
+ (lambda (define-macro)
+ (define-macro 'let-syntax
+ (lambda (expr use-env mac-env)
+ (define splicing-env (syntactic-splicing-extend use-env))
+ (let-syntax-helper expr mac-env splicing-env use-env))))))
+
+(define (macrology/letrec-syntax)
+ (make-macrology
+ (lambda (define-macro)
+ (define-macro 'letrec-syntax
+ (lambda (expr use-env mac-env)
+ (define splicing-env (syntactic-splicing-extend use-env))
+ (let-syntax-helper expr mac-env splicing-env splicing-env))))))
524 tests/r5rs-tests.scm
@@ -0,0 +1,524 @@
+
+(define *tests-run* 0)
+(define *tests-passed* 0)
+
+(define-syntax test
+ (syntax-rules ()
+ ((test name expect expr)
+ (test expect expr))
+ ((test expect expr)
+ (begin
+ (set! *tests-run* (+ *tests-run* 1))
+ (let ((str (call-with-output-string
+ '()
+ (lambda (out)
+ (write *tests-run*)
+ (display ". ")
+ (display 'expr out))))
+ (res expr))
+ (display str)
+ (write-char #\space)
+ (display (make-string (max 0 (- 72 (string-length str))) #\.))
+ (cond
+ ((equal? res expect)
+ (set! *tests-passed* (+ *tests-passed* 1))
+ (display " [PASS]\n"))
+ (else
+ (display " [FAIL]\n")
+ (display " expected ") (write expect)
+ (display " but got ") (write res) (newline))))))))
+
+(define-syntax test-assert
+ (syntax-rules ()
+ ((test-assert expr) (test #t expr))))
+
+(define (test-begin . name)
+ #f)
+
+(define (test-end)
+ (write *tests-passed*)
+ (display " out of ")
+ (write *tests-run*)
+ (display " passed (")
+ (write (* (/ *tests-passed* *tests-run*) 100))
+ (display "%)")
+ (newline))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test-begin "r5rs")
+
+(test 8 ((lambda (x) (+ x x)) 4))
+
+(test '(3 4 5 6) ((lambda x x) 3 4 5 6))
+
+(test '(5 6) ((lambda (x y . z) z) 3 4 5 6))
+
+(test 'yes (if (> 3 2) 'yes 'no))
+
+(test 'no (if (> 2 3) 'yes 'no))
+
+(test 1 (if (> 3 2) (- 3 2) (+ 3 2)))
+
+(test 'greater (cond ((> 3 2) 'greater) ((< 3 2) 'less)))
+
+(test 'equal (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal)))
+
+(test 'composite (case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite)))
+
+(test 'consonant
+ (case (car '(c d))
+ ((a e i o u) 'vowel)
+ ((w y) 'semivowel)
+ (else 'consonant)))
+
+(test #t (and (= 2 2) (> 2 1)))
+
+(test #f (and (= 2 2) (< 2 1)))
+
+(test '(f g) (and 1 2 'c '(f g)))
+
+(test #t (and))
+
+(test #t (or (= 2 2) (> 2 1)))
+
+(test #t (or (= 2 2) (< 2 1)))
+
+(test '(b c) (or (memq 'b '(a b c)) (/ 3 0)))
+
+(test 6 (let ((x 2) (y 3)) (* x y)))
+
+(test 35 (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
+
+(test 70 (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
+
+(test -2 (let ()
+ (define x 2)
+ (define f (lambda () (- x)))
+ (f)))
+
+(define let*-def 1)
+(let* () (define let*-def 2) #f)
+(test 1 let*-def)
+
+(test '#(0 1 2 3 4)
+ (do ((vec (make-vector 5))
+ (i 0 (+ i 1)))
+ ((= i 5) vec)
+ (vector-set! vec i i)))
+
+(test 25
+ (let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x)
+ sum))))
+
+(test '((6 1 3) (-5 -2))
+ (let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '()))
+ (cond
+ ((null? numbers)
+ (list nonneg neg))
+ ((>= (car numbers) 0)
+ (loop (cdr numbers) (cons (car numbers) nonneg) neg))
+ ((< (car numbers) 0)
+ (loop (cdr numbers) nonneg (cons (car numbers) neg))))))
+
+(test '(list 3 4) `(list ,(+ 1 2) 4))
+
+(test '(list a 'a) (let ((name 'a)) `(list ,name ',name)))
+
+(test '(a 3 4 5 6 b)
+ `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
+
+(test '(10 5 4 16 9 8)
+ `(10 5 ,(expt 2 2) ,@(map (lambda (n) (expt n 2)) '(4 3)) 8))
+
+(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+ `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
+
+(test '(a `(b ,x ,'y d) e)
+ (let ((name1 'x)
+ (name2 'y))
+ `(a `(b ,,name1 ,',name2 d) e)))
+
+(test '(list 3 4)
+ (quasiquote (list (unquote (+ 1 2)) 4)))
+
+(test #t (eqv? 'a 'a))
+
+(test #f (eqv? 'a 'b))
+
+(test #t (eqv? '() '()))
+
+(test #f (eqv? (cons 1 2) (cons 1 2)))
+
+(test #f (eqv? (lambda () 1) (lambda () 2)))
+
+(test #t (let ((p (lambda (x) x))) (eqv? p p)))
+
+(test #t (eq? 'a 'a))
+
+(test #f (eq? (list 'a) (list 'a)))
+
+(test #t (eq? '() '()))
+
+(test #t (eq? car car))
+
+(test #t (let ((x '(a))) (eq? x x)))
+
+(test #t (let ((p (lambda (x) x))) (eq? p p)))
+
+(test #t (equal? 'a 'a))
+
+(test #t (equal? '(a) '(a)))
+
+(test #t (equal? '(a (b) c) '(a (b) c)))
+
+(test #t (equal? "abc" "abc"))
+
+(test #f (equal? "abc" "abcd"))
+
+(test #f (equal? "a" "b"))
+
+(test #t (equal? 2 2))
+
+;;(test #f (eqv? 2 2.0))
+
+;;(test #f (equal? 2.0 2))
+
+(test #t (equal? (make-vector 5 'a) (make-vector 5 'a)))
+
+(test 4 (max 3 4))
+
+;;(test 4 (max 3.9 4))
+
+(test 7 (+ 3 4))
+
+(test 3 (+ 3))
+
+(test 0 (+))
+
+(test 4 (* 4))
+
+(test 1 (*))
+
+(test -1 (- 3 4))
+
+(test -6 (- 3 4 5))
+
+(test -3 (- 3))
+
+(test -1.0 (- 3.0 4))
+
+(test 7 (abs -7))
+
+(test 1 (modulo 13 4))
+
+(test 1 (remainder 13 4))
+
+(test 3 (modulo -13 4))
+
+(test -1 (remainder -13 4))
+
+(test -3 (modulo 13 -4))
+
+(test 1 (remainder 13 -4))
+
+(test -1 (modulo -13 -4))
+
+(test -1 (remainder -13 -4))
+
+(test 4 (gcd 32 -36))
+
+(test 288 (lcm 32 -36))
+
+(test 100 (string->number "100"))
+
+(test 256 (string->number "100" 16))
+
+(test 127 (string->number "177" 8))
+
+(test 5 (string->number "101" 2))
+
+(test 100.0 (string->number "1e2"))
+
+(test "100" (number->string 100))
+
+(test "100" (number->string 256 16))
+
+(test "ff" (number->string 255 16))
+
+(test "177" (number->string 127 8))
+
+(test "101" (number->string 5 2))
+
+(test #f (not 3))
+
+(test #f (not (list 3)))
+
+(test #f (not '()))
+
+(test #f (not (list)))
+
+(test #f (not '()))
+
+(test #f (boolean? 0))
+
+(test #f (boolean? '()))
+
+(test #t (pair? '(a . b)))
+
+(test #t (pair? '(a b c)))
+
+(test '(a) (cons 'a '()))
+
+(test '((a) b c d) (cons '(a) '(b c d)))
+
+(test '("a" b c) (cons "a" '(b c)))
+
+(test '(a . 3) (cons 'a 3))
+
+(test '((a b) . c) (cons '(a b) 'c))
+
+(test 'a (car '(a b c)))
+
+(test '(a) (car '((a) b c d)))
+
+(test 1 (car '(1 . 2)))
+
+(test '(b c d) (cdr '((a) b c d)))
+
+(test 2 (cdr '(1 . 2)))
+
+(test #t (list? '(a b c)))
+
+(test #t (list? '()))
+
+(test #f (list? '(a . b)))
+
+(test #f
+ (let ((x (list 'a)))
+ (set-cdr! x x)
+ (list? x)))
+
+(test '(a 7 c) (list 'a (+ 3 4) 'c))
+
+(test '() (list))
+
+(test 3 (length '(a b c)))
+
+(test 3 (length '(a (b) (c d e))))
+
+(test 0 (length '()))
+
+(test '(x y) (append '(x) '(y)))
+
+(test '(a b c d) (append '(a) '(b c d)))
+
+(test '(a (b) (c)) (append '(a (b)) '((c))))
+
+(test '(a b c . d) (append '(a b) '(c . d)))
+
+(test 'a (append '() 'a))
+
+(test '(c b a) (reverse '(a b c)))
+
+(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
+
+(test 'c (list-ref '(a b c d) 2))
+
+(test '(a b c) (memq 'a '(a b c)))
+
+(test '(b c) (memq 'b '(a b c)))
+
+(test #f (memq 'a '(b c d)))
+
+(test #f (memq (list 'a) '(b (a) c)))
+
+(test '((a) c) (member (list 'a) '(b (a) c)))
+
+(test '(101 102) (memv 101 '(100 101 102)))
+
+(test #f (assq (list 'a) '(((a)) ((b)) ((c)))))
+
+(test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
+
+(test '(5 7) (assv 5 '((2 3) (5 7) (11 13))))
+
+(test #t (symbol? 'foo))
+
+(test #t (symbol? (car '(a b))))
+
+(test #f (symbol? "bar"))
+
+(test #t (symbol? 'nil))
+
+(test #f (symbol? '()))
+
+(test "flying-fish" (symbol->string 'flying-fish))
+
+(test "Martin" (symbol->string 'Martin))
+
+(test "Malvina" (symbol->string (string->symbol "Malvina")))
+
+(test #t (string? "a"))
+
+(test #f (string? 'a))
+
+(test 0 (string-length ""))
+
+(test 3 (string-length "abc"))
+
+(test #\a (string-ref "abc" 0))
+
+(test #\c (string-ref "abc" 2))
+
+(test #t (string=? "a" (string #\a)))
+
+(test #f (string=? "a" (string #\b)))
+
+(test #t (string<? "a" "aa"))
+
+(test #f (string<? "aa" "a"))
+
+(test #f (string<? "a" "a"))
+
+(test #t (string<=? "a" "aa"))
+
+(test #t (string<=? "a" "a"))
+
+(test #t (string=? "a" (make-string 1 #\a)))
+
+(test #f (string=? "a" (make-string 1 #\b)))
+
+(test "" (substring "abc" 0 0))
+
+(test "a" (substring "abc" 0 1))
+
+(test "bc" (substring "abc" 1 3))
+
+(test "abc" (string-append "abc" ""))
+
+(test "abc" (string-append "" "abc"))
+
+(test "abc" (string-append "a" "bc"))
+
+(test '#(0 ("Sue" "Sue") "Anna")
+ (let ((vec (vector 0 '(2 2 2 2) "Anna")))
+ (vector-set! vec 1 '("Sue" "Sue"))
+ vec))
+
+(test '(dah dah didah) (vector->list '#(dah dah didah)))
+
+(test '#(dididit dah) (list->vector '(dididit dah)))
+
+(test #t (procedure? car))
+
+(test #f (procedure? 'car))
+
+(test #t (procedure? (lambda (x) (* x x))))
+
+(test #f (procedure? '(lambda (x) (* x x))))
+
+(test #t (call-with-current-continuation procedure?))
+
+(test 7 (call-with-current-continuation (lambda (k) (+ 2 5))))
+
+(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3)))))
+
+(test 7 (apply + (list 3 4)))
+
+(test '(b e h) (map cadr '((a b) (d e) (g h))))
+
+(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5)))
+
+(test '(5 7 9) (map + '(1 2 3) '(4 5 6)))
+
+(test '#(0 1 4 9 16)
+ (let ((v (make-vector 5)))
+ (for-each
+ (lambda (i) (vector-set! v i (* i i)))
+ '(0 1 2 3 4))
+ v))
+
+(test 3 (force (delay (+ 1 2))))
+
+(test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p))))
+
+(test 'ok (let ((else 1)) (cond (else 'ok) (#t 'bad))))
+
+(test 'ok (let ((=> 1)) (cond (#t => 'ok))))
+
+(test '(,foo) (let ((unquote 1)) `(,foo)))
+
+(test '(,@foo) (let ((unquote-splicing 1)) `(,@foo)))
+
+(test 'ok
+ (let ((... 2))
+ (let-syntax ((s (syntax-rules ()
+ ((_ x ...) 'bad)
+ ((_ . r) 'ok))))
+ (s a b c))))
+
+(test 'ok (let ()
+ (let-syntax ()
+ (define internal-def 'ok))
+ internal-def))
+
+(test 'ok (let ()
+ (letrec-syntax ()
+ (define internal-def 'ok))
+ internal-def))
+
+(test '(2 1)
+ ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (list x y))))))
+
+(test '(2 2)
+ ((lambda () (let ((x 1)) (set! x 2) (let ((y x)) (list x y))))))
+
+(test '(1 2)
+ ((lambda () (let ((x 1)) (let ((y x)) (set! y 2) (list x y))))))
+
+(test '(2 3)
+ ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (set! y 3) (list x y))))))
+
+(test '(a b c)
+ (let* ((path '())
+ (add (lambda (s) (set! path (cons s path)))))
+ (dynamic-wind (lambda () (add 'a)) (lambda () (add 'b)) (lambda () (add 'c)))
+ (reverse path)))
+
+(test '(connect talk1 disconnect connect talk2 disconnect)
+ (let ((path '())
+ (c #f))
+ (let ((add (lambda (s)
+ (set! path (cons s path)))))
+ (dynamic-wind
+ (lambda () (add 'connect))
+ (lambda ()
+ (add (call-with-current-continuation
+ (lambda (c0)
+ (set! c c0)
+ 'talk1))))
+ (lambda () (add 'disconnect)))
+ (if (< (length path) 4)
+ (c 'talk2)
+ (reverse path)))))
+
+(test 2 (let-syntax
+ ((foo (syntax-rules @@@ ()
+ ((foo ... args @@@)
+ (args @@@ ...)))))
+ (foo 3 - 5)))
+
+(test '(5 4 1 2 3)
+ (let-syntax
+ ((foo (syntax-rules ()
+ ((foo args ... penultimate ultimate)
+ (list ultimate penultimate args ...)))))
+ (foo 1 2 3 4 5)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test-end)

0 comments on commit 030fbd9

Please sign in to comment.