diff options
| -rw-r--r-- | csc/ir1.csc | 77 | ||||
| -rw-r--r-- | csc/ir2.csc | 34 | ||||
| -rw-r--r-- | csc/macros-test.csc | 96 | ||||
| -rw-r--r-- | csc/macros.csc | 148 |
4 files changed, 171 insertions, 184 deletions
diff --git a/csc/ir1.csc b/csc/ir1.csc index 334f870..3826c34 100644 --- a/csc/ir1.csc +++ b/csc/ir1.csc @@ -10,6 +10,7 @@ if-test if? import? + ir1=? lambda-body lambda-case-alternate lambda-case-arguments @@ -41,6 +42,7 @@ make-lexical-set make-sequence make-toplevel-define + make-toplevel-ref make-void sequence-head sequence-tail @@ -48,8 +50,11 @@ toplevel-define-expression toplevel-define-name toplevel-define? + toplevel-ref-name + toplevel-ref? void?) - (import (scheme base)) + (import (scheme base) + (only (csc loop) loop return)) (begin ; This library defines the intermediate representation IR1. An expression ; in IR1 has one of the following forms (plagiarized from Guile's @@ -82,6 +87,14 @@ (gensym lexical-ref-gensym)) + ; <toplevel-ref> name + ; A free reference to a top level variable. + (define-record-type <toplevel-ref> + (make-toplevel-ref name) + toplevel-ref? + (name toplevel-ref-name)) + + ; <lexical-set> name gensym expression ; Sets a lexically-bound variable. (define-record-type <lexical-set> @@ -175,4 +188,64 @@ (names letrec-names) (gensyms letrec-gensyms) (values letrec-values) - (expression letrec-expression)))) + (expression letrec-expression)) + + + (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 (toplevel-ref? x) (toplevel-ref? y)) + (symbol=? (toplevel-ref-name x) (toplevel-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 (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)) + (= (length (call-arguments x)) (length (call-arguments y))) + (loop for x-arg in (call-arguments x) + for y-arg in (call-arguments y) + unless (ir1=? x-arg y-arg) + return #f + finally (return #t)))) + ((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)) + (= (length (letrec-values x)) (length (letrec-values y))) + (loop for x-val in (letrec-values x) + for y-val in (letrec-values y) + unless (ir1=? x-val y-val) return #f + finally (return #t)) + (ir1=? (letrec-expression x) (letrec-expression y)))) + ((and (ir1=? x x) (ir1=? y y)) + #f) + (else (error "One or more arguments has a type unknown to ir1=?" x y)))))) diff --git a/csc/ir2.csc b/csc/ir2.csc index 1542f1e..0c37d6c 100644 --- a/csc/ir2.csc +++ b/csc/ir2.csc @@ -10,8 +10,6 @@ make-lambda-case ; Re-exports from IR1. - lambda? - make-lambda call-arguments call-procedure call? @@ -21,22 +19,14 @@ if-consequent if-test if? - 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? + lambda? make-call make-constant make-if - make-library-ref - make-library-set + make-lambda make-sequence make-toplevel-define + make-toplevel-ref make-void sequence-head sequence-tail @@ -44,6 +34,8 @@ toplevel-define-expression toplevel-define-name toplevel-define? + toplevel-ref-name + toplevel-ref? void?) (import (scheme base) (only (csc ir1) @@ -58,21 +50,10 @@ if? lambda-body lambda? - 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 make-lambda - make-library-ref - make-library-set make-sequence make-toplevel-define make-void @@ -88,6 +69,11 @@ ; It's CPS time bitch. + ; <variable> + (define-record-type <variable> + (make-variable k var + + ; <closure-ref> idx ; Reference to a variable by index in the closure. (define-record-type <closure-ref> diff --git a/csc/macros-test.csc b/csc/macros-test.csc index 6529e58..4bdc3f1 100644 --- a/csc/macros-test.csc +++ b/csc/macros-test.csc @@ -7,16 +7,8 @@ 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 + ir1=? void?) (only (csc testing) assert-equal @@ -24,69 +16,14 @@ (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 + (assert-equal ir1=? (make-constant '(test 1 2 3)) (expand '(quote (test 1 2 3)) builtins-environment))) (test builtin-syntax-rules-literal - (assert-equal + (assert-equal ir1=? (make-constant 1) (expand '(builtin-let-syntax @@ -101,7 +38,7 @@ (test builtin-syntax-rules-underscore - (assert-equal + (assert-equal ir1=? (make-constant 0) (expand '(builtin-let-syntax @@ -113,7 +50,7 @@ (test builtin-syntax-rules-substitution - (assert-equal + (assert-equal ir1=? (make-constant 5) (expand '(builtin-let-syntax @@ -125,7 +62,7 @@ (test builtin-syntax-rules-nil - (assert-equal + (assert-equal ir1=? (make-constant 1) (expand '(builtin-let-syntax @@ -138,7 +75,7 @@ (test builtin-syntax-rules-improper-list - (assert-equal + (assert-equal ir1=? (make-constant 1) (expand '(builtin-let-syntax @@ -150,7 +87,7 @@ (test builtin-syntax-rules-quoted - (assert-equal + (assert-equal ir1=? (make-constant 'a) (expand '(builtin-let-syntax @@ -162,7 +99,7 @@ (test builtin-syntax-rules-constant - (assert-equal + (assert-equal ir1=? (make-constant 2) (expand '(builtin-let-syntax @@ -176,7 +113,7 @@ (test builtin-syntax-rules-ellipsis - (assert-equal + (assert-equal ir1=? (make-constant 5) (expand '(builtin-let-syntax @@ -188,7 +125,7 @@ (test builtin-syntax-rules-ellipsis-improper - (assert-equal + (assert-equal ir1=? (make-constant 5) (expand '(builtin-let-syntax @@ -200,7 +137,7 @@ (test builtin-syntax-rules-ellipsis-zip - (assert-equal + (assert-equal ir1=? (make-constant '((1 . 3) (2 . 4))) (expand '(builtin-let-syntax @@ -213,7 +150,7 @@ (test builtin-syntax-rules-ellipsis-nested - (assert-equal + (assert-equal ir1=? (make-constant '(1 2 3 4 5)) (expand '(builtin-let-syntax @@ -226,7 +163,7 @@ (test builtin-syntax-rules-ellipsis-custom - (assert-equal + (assert-equal ir1=? (make-constant 5) (expand '(builtin-let-syntax @@ -235,8 +172,3 @@ ((foo x :::) (x :::)))) (foo quote 5)) builtins-environment))) - - -(test builtin-lambda-simple - (assert-equal - (make-lambda diff --git a/csc/macros.csc b/csc/macros.csc index e59973b..08c5fd2 100644 --- a/csc/macros.csc +++ b/csc/macros.csc @@ -1,6 +1,7 @@ (define-library (csc macros) (export expand + program->ir1 macro-syntax-error? builtins-environment) (import (scheme base) @@ -20,14 +21,13 @@ (only (csc ir1) lexical-ref-gensym lexical-ref? - library-ref-library - library-ref-name - library-ref? make-call make-constant make-lambda make-lambda-case - make-library-ref + make-letrec + make-sequence + make-toplevel-ref make-void sequence-head sequence-tail @@ -35,6 +35,8 @@ toplevel-define-expression toplevel-define-name toplevel-define? + toplevel-ref-name + toplevel-ref? void?) (only (csc list) revappend @@ -71,20 +73,15 @@ ; symbols is a map with identifiers as keys, and the values can be one of: ; - <lexical-ref>, - ; - <library-ref>, + ; - <toplevel-ref>, ; - or <macro-transformer>. ; The first two correspond to variables bound lexically or from a module, ; and the third represents a macro transformer bound in the ; current context. - ; - ; library holds information about what library toplevel defines will define - ; into. A value of nil means the main program. The special value 'lambda - ; means define should emit a <lambda-define> object. (define-record-type <environment> - (make-environment symbols library) + (make-environment symbols) environment? - (symbols environment-substitutions) - (library environment-library)) + (symbols environment-substitutions)) (define-record-type <syntax-object> @@ -117,7 +114,7 @@ (let ((environment (syntax-object-environment syntax))) (make-syntax-object (syntax->expression syntax) - (make-environment (insert (environment-substitutions environment) identifier binding) (environment-library environment)) + (make-environment (insert (environment-substitutions environment) identifier binding)) (marks syntax)))) @@ -152,10 +149,9 @@ (or (and (lexical-ref? b1) (lexical-ref? b2) (gensym=? (lexical-ref-gensym b1) (lexical-ref-gensym b2))) - (and (library-ref? b1) - (library-ref? b2) - (equal? (library-ref-library b1) (library-ref-library b2)) - (symbol=? (library-ref-name b1) (library-ref-name b2))) + (and (toplevel-ref? b1) + (toplevel-ref? b2) + (symbol=? (toplevel-ref-name b1) (toplevel-ref-name b2))) (and (macro-transformer? b1) (macro-transformer? b2) (eq? (transformer-function b1) (transformer-function b2))))) @@ -266,18 +262,18 @@ (define (expand-procedure-call procedure arguments) - (let-values (((expanded-procedure environment) (expand-syntax-object procedure)) - ((expanded-arguments) - (let loop ((arguments arguments) - (expanded-arguments '())) - (syntax-case arguments - ('() (reverse expanded-arguments)) - ((argument . rest) - (let-values (((expanded-argument environment) (expand-syntax-object argument))) - (loop - rest - (cons expanded-argument expanded-arguments)))) - (_ (raise-syntax-error "arguments to a procedure call must be a list" procedure arguments)))))) + (let ((expanded-procedure (expand-syntax-object procedure)) + (expanded-arguments + (let loop ((arguments arguments) + (expanded-arguments '())) + (syntax-case arguments + ('() (reverse expanded-arguments)) + ((argument . rest) + (let ((expanded-argument (expand-syntax-object argument))) + (loop + rest + (cons expanded-argument expanded-arguments)))) + (_ (raise-syntax-error "arguments to a procedure call must be a list" procedure arguments)))))) (make-call expanded-procedure expanded-arguments))) @@ -299,23 +295,23 @@ (let ((macro-body (resolve-identifier macro-name))) (if (macro-transformer? macro-body) ((transformer-function macro-body) syntax) - (values (expand-procedure-call macro-name tail) (syntax-object-environment syntax))))) + (expand-procedure-call macro-name tail)))) ((procedure . arguments) - (values (expand-procedure-call procedure arguments) (syntax-object-environment syntax))) + (expand-procedure-call procedure arguments)) (_ (when (identifier? syntax)) (let ((binding (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" syntax))) (lookup (environment-substitutions (syntax-object-environment syntax)) syntax)))) (if (macro-transformer? binding) (raise-syntax-error "macro is not allowed in this context" syntax) - (values binding (syntax-object-environment syntax))))) + binding))) (_ (when (let ((expr (syntax->expression syntax))) (or (boolean? expr) (char? expr) (number? expr) (string? expr) (vector? expr)))) - (values (make-constant (syntax->expression syntax)) (syntax-object-environment syntax))) + (make-constant (syntax->expression syntax))) (_ (raise-syntax-error "unexpected expression type" (clean-syntax syntax))))) @@ -337,7 +333,7 @@ (make-macro-transformer (lambda (syntax) (syntax-case syntax - ((_ datum) (values (make-constant (clean-syntax datum)) (syntax-object-environment syntax))) + ((_ datum) (make-constant (clean-syntax datum))) (_ (raise-syntax-error "invalid form for quote" (clean-syntax syntax))))))) @@ -387,8 +383,7 @@ '_ (make-environment (alist->substitutions - (list (cons '_ (make-library-ref '(csc builtins) '_ #t)))) - '()))))) + (list (cons '_ (make-toplevel-ref '_))))))))) (define (syntax-improper-list-length l) @@ -604,23 +599,20 @@ (make-environment (alist->substitutions (list (cons '_ - (make-library-ref '(csc builtins) '_ #t)))) - '()))) + (make-toplevel-ref '_))))))) (define builtin-syntax-rules (make-macro-transformer (lambda (syntax-rules-form) - (values - (make-macro-transformer - (lambda (input-form) - (syntax-case syntax-rules-form - ((_ ellipsis literals . rules) (when (identifier? ellipsis)) - (syntax-match ellipsis literals rules input-form)) - ((_ literals . rules) - (syntax-match default-ellipsis literals rules input-form)) - (_ (raise-syntax-error "unexpected form in syntax-rules" syntax-rules-form))))) - (syntax-object-environment syntax-rules-form))))) + (make-macro-transformer + (lambda (input-form) + (syntax-case syntax-rules-form + ((_ ellipsis literals . rules) (when (identifier? ellipsis)) + (syntax-match ellipsis literals rules input-form)) + ((_ literals . rules) + (syntax-match default-ellipsis literals rules input-form)) + (_ (raise-syntax-error "unexpected form in syntax-rules" syntax-rules-form)))))))) (define builtin-let-syntax @@ -628,11 +620,9 @@ (lambda (x) (syntax-case x ((_ (ident transformer-form) body-form) (when (identifier? ident)) - (let*-values (((transformer environment) (expand-syntax-object transformer-form)) - ((body environment) (expand-syntax-object (with-binding ident transformer body-form)))) - (values - body - (syntax-object-environment x)))) + (let* ((transformer (expand-syntax-object transformer-form)) + (body (expand-syntax-object (with-binding ident transformer body-form)))) + body)) (_ (raise-syntax-error "unexpected for in let-syntax")))))) @@ -648,17 +638,9 @@ (_ (raise-syntax-error "unexpected form in case-lambda" formals)))) - (define-record-type <lambda-define> - (make-lambda-define name gensym expression) - lambda-define? - (name lambda-define-name) - (gensym lambda-define-gensym) - (expression lambda-define-expression)) - - (define (collect-defines acc body) (cond - ((lambda-define? body) + ((toplevel-define? body) (values (cons body acc) (make-void))) @@ -678,9 +660,9 @@ (define (fix-lambda-body body) (define-values (defines rest) (collect-defines '() body)) (define-values (names gensyms vals) (loop for def in defines - collect (lambda-define-name def) into names - collect (lambda-define-gensym def) into gensyms - collect (lambda-define-expression def) into vals + collect (toplevel-define-name def) into names + collect (gensym) into gensyms + collect (toplevel-define-expression def) into vals finally (return (values names gensyms vals)))) (make-letrec #t @@ -690,13 +672,6 @@ rest)) - (define (with-library lib expr) - (make-syntax-object - (syntax->expression expr) - (make-environment (environment-symbols (syntax-object-environment expr)) lib) - (marks expr))) - - (define (case-lambda-helper form) (syntax-case form ('() '()) @@ -710,7 +685,7 @@ (if rest (cons rest args) args)) - (fix-lambda-body (expand-syntax-object (with-library 'lambda body))) + (fix-lambda-body (expand-syntax-object body)) (case-lambda-helper clauses)))) (_ (raise-syntax-error "unexpected form in case-lambda" form)))) @@ -728,7 +703,28 @@ (make-environment (alist->substitutions (list (cons 'syntax-rules builtin-syntax-rules) - (cons '_ (make-library-ref '(csc builtins) '_ #t)) + (cons '_ (make-toplevel-ref '_)) (cons 'quote builtin-quote) - (cons 'builtin-let-syntax builtin-let-syntax))) - '())))) + (cons 'case-lambda builtin-case-lambda) + (cons 'builtin-let-syntax builtin-let-syntax))))) + + + (define (expand-body environment body) + (loop for expr in body + for expanded-expr = (expand expr environment) + for res = expanded-expr then (make-sequence res expanded-expr) + finally (return res) + if (toplevel-define? expanded-expr) + do (set! environment (insert environment (toplevel-define-name expanded-expr) (toplevel-define-expression expanded-expr))))) + + + ; A Scheme program consists of one or more import declarations + ; followed by a sequence of expressions and definitions. + ; -- R7RS + (define (program->ir1 program) + (loop for expr in program + for body on program + do (match expr + ; Add this line to make yourself feel better. + ((! ('import ('csc 'builtins))) '()) + (_ (return (expand-body builtins-environment body)))))))) |