diff options
| -rw-r--r-- | gensym.csc | 25 | ||||
| -rw-r--r-- | ir1.csc | 213 | ||||
| -rw-r--r-- | macros.csc | 184 |
3 files changed, 422 insertions, 0 deletions
diff --git a/gensym.csc b/gensym.csc new file mode 100644 index 0000000..a7c30c5 --- /dev/null +++ b/gensym.csc @@ -0,0 +1,25 @@ +(define-library (csc gensym) + (export + gensym + gensym=?) + (import (scheme base)) + (begin + + + (define-record-type <gensym> + (make-gensym id) + gensym? + (id gensym-id)) + + + (define (gensym=? s1 s2) + (= (gensym-id s1) (gensym-id s2))) + + + (define *next-id* 0) + + + (define (gensym) + (let ((sym (make-gensym *next-id*))) + (set! *next-id* (+ 1 *next-id*)) + sym)))) @@ -0,0 +1,213 @@ +(define-library (csc ir1) + (export + call-arguments + call-procedure + call? + constant-expression + constant? + if-alternate + if-consequent + if-test + if? + lambda-body + lambda-case-alternate + lambda-case-arguments + lambda-case-body + lambda-case-gensyms + lambda-case-rest + lambda-case? + lambda? + letrec-expression + letrec-gensyms + letrec-in-order? + letrec-names + letrec-values + letrec? + lexical-ref-gensym + lexical-ref-name + lexical-ref? + lexical-set-expression + 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 + make-lambda + make-lambda-case + make-letrec + make-lexical-ref + make-lexical-set + make-library-ref + make-library-set + make-sequence + make-toplevel-define + make-void + sequence-head + sequence-tail + sequence? + toplevel-define-expression + toplevel-define-name + toplevel-define? + void?) + (import (scheme base)) + (begin + ; This library defines the intermediate representation IR1. An expression + ; in IR1 has one of the following forms (plagiarized from Guile's + ; Tree-IL). + + + ; <void> + ; An empty expression. In practice, equivalent to Scheme's (if #f #f). + (define-record-type <void> + (make-void) + void?) + + + ; <constant> expression + ; Constant is used to include literal constants in scheme code. + (define-record-type <constant> + (make-constant expression) + constant? + (expression constant-expression)) + + + ; <lexical-ref> name gensym + ; A reference to a lexically-bound variable. The name is the original name + ; of the variable in the source program. gensym is a unique identifier for + ; this variable. + (define-record-type <lexical-ref> + (make-lexical-ref name gensym) + lexical-ref? + (name lexical-ref-name) + (gensym lexical-ref-gensym)) + + + ; <lexical-set> name gensym expression + ; Sets a lexically-bound variable. + (define-record-type <lexical-set> + (make-lexical-set name gensym expression) + lexical-set? + (name lexical-set-name) + (gensym lexical-set-gensym) + (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> + (make-toplevel-define name expression) + toplevel-define? + (name toplevel-define-name) + (expression toplevel-define-expression)) + + + ; <if> test consequent alternate + ; A conditional. + (define-record-type <if> + (make-if test consequent alternate) + if? + (test if-test) + (consequent if-consequent) + (alternate if-alternate)) + + + ; <call> procedure arguments + ; A procedure call. The procedure and arguments are evaluated in an + ; unspecified order, and the resulting procedure is passed the + ; resulting arguments. + (define-record-type <call> + (make-call procedure arguments) + call? + (procedure call-procedure) + (arguments call-arguments)) + + + ; <sequence> head tail + ; Evaluate head, ignoring any result. Then tail is evaluated. + (define-record-type <sequence> + (make-sequence head tail) + sequence? + (head sequence-head) + (tail sequence-tail)) + + + ; <lambda> body + ; A closure. body is an expression of type <lambda-case>. + (define-record-type <lambda> + (make-lambda body) + lambda? + (body lambda-body)) + + + ; <lambda-case> arguments rest gensyms body alternate + ; One clause of a case-lambda. A lambda expression in Scheme is treated as + ; a case-lambda with one clause. + ; + ; arguments is a list of the procedures arguments, as symbols. rest is the + ; name of the rest argument, or #f. gensyms is a list of gensyms + ; corresponding to all arguments: first all of the normal arguments, then + ; the rest argument if any. + ; + ; body is the name of the clause. If the procedure is called with an + ; appropriate number of arguments, body is evaluated in tail position. + ; Otherwise if there is an alternate, it should be a <lambda-case> + ; expression, representing the next clause to try. If there is no + ; alternate, an error is signaled. + (define-record-type <lambda-case> + (make-lambda-case arguments rest gensyms body alternate) + lambda-case? + (arguments lambda-case-arguments) + (rest lambda-case-rest) + (gensyms lambda-case-gensyms) + (body lambda-case-body) + (alternate lambda-case-alternate)) + + + ; <letrec> in-order? names gensyms values expression + ; Lexical binding, like Scheme's letrec, or letrec* if in-order? is true. + ; names are the original binding names, gensyms are gensyms corresponding + ; to the names, and values are IR1 expressions for the values. expression + ; is a single IR1 expression. + (define-record-type <letrec> + (make-letrec in-order? names gensyms values expression) + letrec? + (in-order? letrec-in-order?) + (names letrec-names) + (gensyms letrec-gensyms) + (values letrec-values) + (expression letrec-expression)))) diff --git a/macros.csc b/macros.csc new file mode 100644 index 0000000..a41a4a7 --- /dev/null +++ b/macros.csc @@ -0,0 +1,184 @@ +(define-library (csc macros) + (export + expand + test-environment) + (import (scheme base) + (only (csc gensym) gensym) + (only (csc hash-map) + alist->map + hash-bytevector + insert + key-not-found-error? + lookup) + (only (csc ir1) + make-call + make-constant + make-lambda + make-lambda-case) + (only (csc list) revappend) + (only (csc match) match)) + (begin + + + (define-record-type <macro-transformer> + (make-macro-transformer transformer) + macro-transformer? + (transformer transformer-function)) + + + (define-record-type <macro-syntax-error> + (make-macro-syntax-error message irritants) + macro-syntax-error? + (message syntax-error-object-message) + (irritants syntax-error-object-irritants)) + + + (define (raise-syntax-error message . irritants) + (raise (make-macro-syntax-error message irritants))) + + + ; symbols is a map with symbols as keys, and the values can be one of: + ; - <lexical-ref>, + ; - <module-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 is the current library name being compiled. A nil library + ; corresponds to top level expressions. + (define-record-type <environment> + (make-environment symbols library) + environment? + (symbols environment-symbols) + (library environment-library)) + + + (define (with-binding environment symbol binding) + (make-environment (insert (environment-symbols environment) symbol binding) (environment-library environment))) + + + (define (expand-procedure-call procedure arguments environment) + (let*-values (((expanded-procedure environment) (expand procedure environment)) + ((expanded-arguments environment) + (let loop ((arguments arguments) + (environment environment) + (expanded-arguments '())) + (match arguments + ('() (values (reverse expanded-arguments) environment)) + ((argument . rest) + (let-values (((expanded-argument environment) (expand argument environment))) + (loop + rest + environment + (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))) + + + ; 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. + (define (expand expression environment) + (cond + ((null? expression) (raise-syntax-error "nil by itself is an error (did you mean to use quote?)" expression)) + ((and (pair? expression) + (symbol? (car expression))) + (let* ((macro-name (car expression)) + (macro-body + (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" macro-name))) + (lookup (environment-symbols environment) macro-name)))) + (if (macro-transformer? macro-body) + ((transformer-function macro-body) expression environment) + (expand-procedure-call macro-name (cdr expression) environment)))) + ((pair? expression) + (let ((procedure (car expression)) + (arguments (cdr expression))) + (expand-procedure-call procedure arguments environment))) + ((symbol? expression) + (let ((binding + (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" expression))) + (lookup (environment-symbols environment) expression)))) + (if (macro-transformer? binding) + (raise-syntax-error "macro is not allowed in this context" expression) + (values binding environment)))) + ((or (boolean? expression) + (bytevector? expression) + (char? expression) + (number? expression) + (string? expression) + (vector? expression)) + (values (make-constant expression) environment)) + (else (raise-syntax-error "unexpected expression type" expression)))) + + + (define builtin-quote + (make-macro-transformer + (lambda (expression environment) + (match expression + ((_ datum) (values (make-constant datum) environment)) + (_ (raise-syntax-error "invalid form for quote" expression)))))) + + + (define builtin-lambda + (make-macro-transformer + (lambda (expression environment) + (match expression + ((_ formals body) + (let loop ((formals formals) + (environment environment) + (argument-names '()) + (gensyms '())) + (match formals + ('() + (make-lambda + (make-lambda-case + (reverse argument-names) + #f + (reverse gensyms) + (expand body environment) + #f))) + ((variable . variables) (when (symbol? variable)) + (let ((sym (gensym))) + (loop + variables + (with-binding environment variable sym) + (cons variable argument-names) + (cons sym gensyms)))) + (variable (when (symbol? variable)) + (let ((sym (gensym))) + (make-lambda + (make-lambda-case + (reverse argument-names) + variable + (revappend gensyms (list sym)) + (expand body (with-binding environment variable sym)) + #f)))) + (_ (raise-syntax-error "invalid form for lambda arguments" expression))))) + (_ (raise-syntax-error "invalid form for lambda" expression)))))) + + + #;(define builtin-syntax-rules + (make-macro-transformer + (lambda (expression environment) + (match expression)))) + + + (define (hash-symbol s) + (hash-bytevector (string->utf8 (symbol->string s)))) + + + (define (symbol<? s1 s2) + (string<? (symbol->string s1) (symbol->string s2))) + + + (define test-environment + (make-environment + (alist->map + hash-symbol + symbol<? + (list + (cons 'quote builtin-quote) + (cons 'lambda builtin-lambda))) + '())))) |