diff options
Diffstat (limited to 'csc/macros.csc')
| -rw-r--r-- | csc/macros.csc | 184 |
1 files changed, 184 insertions, 0 deletions
diff --git a/csc/macros.csc b/csc/macros.csc new file mode 100644 index 0000000..a41a4a7 --- /dev/null +++ b/csc/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))) + '())))) |