diff options
| -rw-r--r-- | csc/compiler.csc | 89 | ||||
| -rw-r--r-- | csc/ir1.csc | 37 | ||||
| -rw-r--r-- | csc/macros-test.csc | 106 | ||||
| -rw-r--r-- | csc/macros.csc | 8 |
4 files changed, 186 insertions, 54 deletions
diff --git a/csc/compiler.csc b/csc/compiler.csc new file mode 100644 index 0000000..5486344 --- /dev/null +++ b/csc/compiler.csc @@ -0,0 +1,89 @@ +(define-library (csc compiler) + (import (scheme base) + (only (csc hash-map) + hash-bytevector + insert + key-not-found-error? + lookup + make-map + map-for-each + merge) + (only (csc ir1) + toplevel-define?) + (only (csc loop) + loop + return) + (only (csc macros) + builtins-environment + expand) + (only (csc match) match)) + (begin + + + (define (hash-symbol s) + (hash-bytevector (string->utf8 (symbol->string s)))) + + + (define (cmp-symbol s1 s2) + (string<? (symbol->string s1) (symbol->string s2))) + + + (define-record-type <syntax-error> + (make-syntax-error msg irritants) + syntax-error?) + + + (define (raise-syntax-error msg . irritants) + (raise (make-syntax-error msg irritants))) + + + (define (parse-import-set expr) + (match expr + (((! 'only) import-set . idents) + (loop with bindings = (parse-import-set import-set) + and new-bindings = (make-map hash-symbol cmp-symbol) + for ident in idents + do (set! new-bindings + (insert new-bindings + ident + (guard (e ((key-not-found-error? e) (raise-syntax-error "unknown symbol in `only' form" ident))) + (lookup bindings ident)))) + finally (return new-bindings))) + ((! '(csc builtins)) + builtins-environment) + (_ (raise-syntax-error "unknown or unsupported import set form" expr)))) + + + + (define (parse-import expr) + (match expr + (((! 'import) . import-sets) + (loop with bindings = (make-map hash-symbol cmp-symbol) + for import-set in import-sets + do (set! bindings + (merge bindings (parse-import-set import-set))) + finally (return bindings))) + (_ (raise-syntax-error "expected import form" expr)))) + + + (define-record-type <program> + (make-program imports body) + program? + (imports program-imports) + (body program-body)) + + + ; A Scheme program consists of one or more import declarations + ; followed by a sequence of expressions and definitions. + ; -- R7RS + (define (program->ir1 program) + (loop with bindings = (make-map hash-symbol cmp-symbol) + for body on program + for expr = (car body) + do (match expr + (((! 'import) . import-sets) + (set! bindings + (merge bindings (parse-import expr)))) + (_ (loop for expr in body + for expanded-expr = (expand expr bindings) + if (toplevel-define? expanded-expr) diff --git a/csc/ir1.csc b/csc/ir1.csc index 1365891..334f870 100644 --- a/csc/ir1.csc +++ b/csc/ir1.csc @@ -9,6 +9,7 @@ if-consequent if-test if? + import? lambda-body lambda-case-alternate lambda-case-arguments @@ -30,15 +31,6 @@ lexical-set-gensym lexical-set-name lexical-set? - library-ref-library - library-ref-name - library-ref-public? - library-ref? - library-set-expression - library-set-library - library-set-name - library-set-public? - library-set? make-call make-constant make-if @@ -47,8 +39,6 @@ make-letrec make-lexical-ref make-lexical-set - make-library-ref - make-library-set make-sequence make-toplevel-define make-void @@ -102,31 +92,6 @@ (expression lexical-set-expression)) - ; <library-ref> library name public? - ; A reference to a variable in a specific library. library should be the name - ; of the library, e.g. (scheme base). - ; - ; If public? is true, name will be looked up in library's public interface, - ; otherwise it will be looked up among the library's private bindings. - (define-record-type <library-ref> - (make-library-ref library name public?) - library-ref? - (library library-ref-library) - (name library-ref-name) - (public? library-ref-public?)) - - - ; <library-set> library name public? expression - ; Sets a variable in a specific library. - (define-record-type <library-set> - (make-library-set library name public? expression) - library-set? - (library library-set-library) - (name library-set-name) - (public? library-set-public?) - (expression library-set-expression)) - - ; <toplevel-define> name expression ; Defines a new variable in the current library. (define-record-type <toplevel-define> diff --git a/csc/macros-test.csc b/csc/macros-test.csc index 4cc8efa..6529e58 100644 --- a/csc/macros-test.csc +++ b/csc/macros-test.csc @@ -1,15 +1,88 @@ (import (scheme base) - (only (csc ir1) make-constant) + (only (csc ir1) + constant-expression + constant? + lexical-ref-name + lexical-ref? + lexical-set-expression + lexical-set-name + lexical-set? + library-ref-library + library-ref-name + library-ref-public? + library-ref? + library-set-expression + library-set-library + library-set-name + library-set-public? + library-set? + make-constant + void?) (only (csc testing) assert-equal test) (csc macros)) +(define (ir1= x y) + (cond + ((and (void? x) (void? y)) #t) + ((and (constant? x) (constant? y)) + (equal? (constant-expression x) (constant-expression y))) + ((and (lexical-ref? x) (lexical-ref? y)) + (symbol=? (lexical-ref-name x) (lexical-ref-name y))) + ((and (lexical-set? x) (lexical-set? y)) + (and + (symbol=? (lexical-set-name x) (lexical-set-name y)) + (ir1= (lexical-set-expression x) (lexical-set-expression y)))) + ((and (library-ref? x) (library-ref? y)) + (and + (equal? (library-ref-library x) (library-ref-library y)) + (symbol=? (library-ref-name x) (library-ref-name y)) + (boolean=? (library-ref-public? x) (library-ref-public? y)))) + ((and (library-set? x) (library-set? y)) + (and + (equal? (library-set-library x) (library-set-library y)) + (symbol=? (library-set-name x) (library-set-name y)) + (boolean=? (library-set-public? x) (library-set-public? y)) + (ir1=? (library-set-expression x) (library-set-expression y)))) + ((and (toplevel-define? x) (toplevel-define? y)) + (and + (symbol=? (toplevel-define-name x) (toplevel-define-name y)) + (ir1=? (toplevel-define-expression x) (toplevel-define-expression y)))) + ((and (if? x) (if? y)) + (and + (ir1=? (if-test x) (if-test y)) + (ir1=? (if-consequent x) (if-consequent y)) + (ir1=? (if-alternate x) (if-alternate y)))) + ((and (call? x) (call? y)) + (and + (ir1=? (call-procedure x) (call-procedure y)) + (apply (map ir1=? (call-arguments x) (call-arguments y)))) + ((and (sequence? x) (sequence? y)) + (and + (ir1=? (sequence-head x) (sequence-head y)) + (ir1=? (sequence-tail x) (sequence-tail y)))) + ((and (lambda? x) (lambda? y)) + (ir1=? (lambda-body x) (lambda-body y))) + ((and (lambda-case? x) (lambda-case? y)) + (and + (equal? (lambda-case-arguments x) (lambda-case-arguments y)) + (eq? (lambda-case-rest x) (lambda-case-rest y)) + (ir1=? (lambda-case-body x) (lambda-case-body y)) + (or (and (not (lambda-case-alternate x)) + (not (lambda-case-alternate y))) + (ir1= (lambda-case-alternate x) (lambda-case-alternate y))))) + ((and (letrec? x) (letrec? y)) + (and + (boolean=? (letrec-in-order? x) (letrec-in-order? y)) + (map symbol=? (letrec-names x) (letrec-names y)) + + (test builtin-quote (assert-equal (make-constant '(test 1 2 3)) - (expand '(quote (test 1 2 3)) test-environment))) + (expand '(quote (test 1 2 3)) builtins-environment))) (test builtin-syntax-rules-literal @@ -24,7 +97,7 @@ ((foo b) 1))) (foo b)) - test-environment))) + builtins-environment))) (test builtin-syntax-rules-underscore @@ -36,7 +109,7 @@ (syntax-rules () ((foo _) 0))) (foo ignored)) - test-environment))) + builtins-environment))) (test builtin-syntax-rules-substitution @@ -48,7 +121,7 @@ (syntax-rules () ((foo x) x))) (foo 5)) - test-environment))) + builtins-environment))) (test builtin-syntax-rules-nil @@ -61,7 +134,7 @@ ((foo x) 0) ((foo) 1))) (foo)) - test-environment))) + builtins-environment))) (test builtin-syntax-rules-improper-list @@ -73,7 +146,7 @@ (syntax-rules () ((foo a . b) a))) (foo 1 2 3)) - test-environment))) + builtins-environment))) (test builtin-syntax-rules-quoted @@ -85,7 +158,7 @@ (syntax-rules () ((foo x) (quote x)))) (foo a)) - test-environment))) + builtins-environment))) (test builtin-syntax-rules-constant @@ -99,7 +172,7 @@ ((foo "def") 1) ((foo "ghi") 2))) (foo "ghi")) - test-environment))) + builtins-environment))) (test builtin-syntax-rules-ellipsis @@ -111,7 +184,7 @@ (syntax-rules () ((foo x ...) (x ...)))) (foo quote 5)) - test-environment))) + builtins-environment))) (test builtin-syntax-rules-ellipsis-improper @@ -123,7 +196,7 @@ (syntax-rules () ((foo x ... . y) (x ... y)))) (foo quote . 5)) - test-environment))) + builtins-environment))) (test builtin-syntax-rules-ellipsis-zip @@ -136,7 +209,7 @@ ((zip (x ...) (y ...)) (quote ((x . y) ...))))) (zip (1 2) (3 4))) - test-environment))) + builtins-environment))) (test builtin-syntax-rules-ellipsis-nested @@ -149,7 +222,7 @@ ((append (x ...) ...) (quote (x ... ...))))) (append (1 2) (3 4) () (5))) - test-environment))) + builtins-environment))) (test builtin-syntax-rules-ellipsis-custom @@ -161,4 +234,9 @@ (syntax-rules ::: () ((foo x :::) (x :::)))) (foo quote 5)) - test-environment))) + builtins-environment))) + + +(test builtin-lambda-simple + (assert-equal + (make-lambda diff --git a/csc/macros.csc b/csc/macros.csc index df8bc73..e59973b 100644 --- a/csc/macros.csc +++ b/csc/macros.csc @@ -1,7 +1,8 @@ (define-library (csc macros) (export expand - test-environment) + macro-syntax-error? + builtins-environment) (import (scheme base) (only (csc assert) assert) (only (csc format) sprintf) @@ -320,8 +321,7 @@ ; expand can be thought of as a compiler from Scheme to IR1. Macros ; included in the environment can be used to extend the syntax. Returns an - ; IR1 expression and an environment which has been modified with any new - ; bindings introduced by the expression. + ; IR1 expression. (define (expand expression environment) (expand-syntax-object (wrap-syntax expression environment))) @@ -724,7 +724,7 @@ (_ (raise-syntax-error "unexpected form in case-lambda" x)))))) - (define test-environment + (define builtins-environment (make-environment (alist->substitutions (list (cons 'syntax-rules builtin-syntax-rules) |