diff options
| -rw-r--r-- | csc/hash-map-test.csc | 10 | ||||
| -rw-r--r-- | csc/hash-map.csc | 31 | ||||
| -rw-r--r-- | csc/ir1.csc | 4 | ||||
| -rw-r--r-- | csc/macros-test.csc | 12 | ||||
| -rw-r--r-- | csc/macros.csc | 452 | ||||
| -rw-r--r-- | csc/match.csc | 66 |
6 files changed, 414 insertions, 161 deletions
diff --git a/csc/hash-map-test.csc b/csc/hash-map-test.csc index 3e26570..f346e1e 100644 --- a/csc/hash-map-test.csc +++ b/csc/hash-map-test.csc @@ -83,3 +83,13 @@ (test lookup-notfound (assert-raises key-not-found-error? (lookup (alist->map hash-symbol cmp-symbols '((a . 1) (b . 2) (c . 3))) 'd))) + + +(test merge + (assert-equal + (sort-alist '((a . 1) (b . 2) (c . 3) (d . 4))) + (sort-alist + (map->alist + (merge + (alist->map hash-symbol cmp-symbols '((a . 1) (b . 2))) + (alist->map hash-symbol cmp-symbols '((c . 3) (d . 4)))))))) diff --git a/csc/hash-map.csc b/csc/hash-map.csc index 2862e84..81ed770 100644 --- a/csc/hash-map.csc +++ b/csc/hash-map.csc @@ -1,16 +1,18 @@ (define-library (csc hash-map) (export alist->map - hash-bytevector - map->alist for-each + hash-bytevector insert + key-not-found-error? lookup + make-map + map->alist map? - key-not-found-error? - make-map) + merge) (import (scheme base) - (only (csc format) sprintf)) + (only (csc format) sprintf) + (only (csc match) match)) (begin @@ -255,4 +257,21 @@ (hash 0)) (if (>= i (bytevector-length b)) hash - (loop (+ 1 i) (+ (* hash #x100) (bytevector-u8-ref b i)))))))) + (loop (+ 1 i) (+ (* hash #x100) (bytevector-u8-ref b i)))))) + + + (define (merge2 m1 m2) + (let ((m1 m1)) + (for-each + (lambda (k v) + (set! m1 (insert m1 k v))) + m2) + m1)) + + + (define (merge m . m*) + (let loop ((m* m*) + (m m)) + (match m* + ('() m) + ((head . tail) (loop tail (merge2 m head)))))))) diff --git a/csc/ir1.csc b/csc/ir1.csc index 53dacc1..1365891 100644 --- a/csc/ir1.csc +++ b/csc/ir1.csc @@ -186,8 +186,8 @@ ; 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. + ; expression, representing the next clause to try. If alternate is nil, an + ; error is signaled. (define-record-type <lambda-case> (make-lambda-case arguments rest gensyms body alternate) lambda-case? diff --git a/csc/macros-test.csc b/csc/macros-test.csc new file mode 100644 index 0000000..007b881 --- /dev/null +++ b/csc/macros-test.csc @@ -0,0 +1,12 @@ +(import (scheme base) + (only (csc ir1) make-constant) + (only (csc testing) + assert-equal + test) + (csc macros)) + + +(test builtin-quote + (assert-equal + (make-constant '(test 1 2 3)) + (expand '(quote (test 1 2 3)) test-environment))) diff --git a/csc/macros.csc b/csc/macros.csc index a41a4a7..d8903eb 100644 --- a/csc/macros.csc +++ b/csc/macros.csc @@ -3,20 +3,31 @@ expand test-environment) (import (scheme base) - (only (csc gensym) gensym) + (only (csc format) sprintf) + (only (csc gensym) + gensym + gensym=?) (only (csc hash-map) alist->map hash-bytevector insert key-not-found-error? - lookup) + lookup + merge) (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-lambda-case + make-library-ref) (only (csc list) revappend) - (only (csc match) match)) + (only (csc match) match) + (only (csc strings) join)) (begin @@ -37,9 +48,9 @@ (raise (make-macro-syntax-error message irritants))) - ; symbols is a map with symbols as keys, and the values can be one of: + ; symbols is a map with identifiers as keys, and the values can be one of: ; - <lexical-ref>, - ; - <module-ref>, + ; - <library-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 @@ -50,135 +61,368 @@ (define-record-type <environment> (make-environment symbols library) environment? - (symbols environment-symbols) + (symbols environment-substitutions) (library environment-library)) - (define (with-binding environment symbol binding) - (make-environment (insert (environment-symbols environment) symbol binding) (environment-library environment))) + (define (with-binding environment identifier binding) + (make-environment (insert (environment-substitutions environment) identifier binding) (environment-library environment))) - (define (expand-procedure-call procedure arguments environment) - (let*-values (((expanded-procedure environment) (expand procedure environment)) - ((expanded-arguments environment) + (define-record-type <syntax-object> + (make-syntax-object expression environment marks) + syntax-object? + (expression syntax-object-expression) + (environment syntax-object-environment) + (marks syntax-object-marks)) + + + (define (wrap-syntax expression environment) + (if (syntax-object? expression) + expression + (make-syntax-object expression environment '()))) + + + (define (identifier? s) + (or (symbol? s) + (and (syntax-object? s) + (symbol? (syntax-object-expression s))))) + + + (define (marks s) + (if (syntax-object? s) + (syntax-object-marks s) + '())) + + + (define (marks=? m1 m2) + (and + (= (length m1) (length m2)) + (let loop ((m1 m1) + (m2 m2)) + (if (null? m1) + #t + (and (= (car m1) (car m2)) (loop (cdr m1) (cdr m2))))))) + + + (define (identifier-name s) + (if (syntax-object? s) + (syntax-object-expression s) + s)) + + + (define (bound-identifier=? s1 s2) + (and (symbol=? (identifier-name s1) (identifier-name s2)) + (marks=? (marks s1) (marks s2)))) + + + (define (binding=? b1 b2) + (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 (macro-transformer? b1) + (macro-transformer? b2) + (eq? (transformer-function b1) (transformer-function b2))))) + + + ; free-identifier=? only works on wrapped syntax objects. + (define (free-identifier=? s1 s2) + (let ((s1-binding (guard (e ((key-not-found-error? e) #f)) + (lookup (environment-substitutions (syntax-object-environment s1)) s1))) + (s2-binding (guard (e ((key-not-found-error? e) #f)) + (lookup (environment-substitutions (syntax-object-environment s2)) s2)))) + (or (and (not s1-binding) (not s2-binding)) + (binding=? s1-binding s2-binding)))) + + + (define *next-mark* 0) + + + (define (new-mark) + (let ((m *next-mark*)) + (set! *next-mark* (+ 1 *next-mark*)) + m)) + + + (define (add-mark mark expression) + (make-syntax-object + (syntax-object-expression expression) + (syntax-object-environment expression) + (if (and (pair? (syntax-object-marks expression)) + (not (car (syntax-object-marks expression)))) ; Anti-mark. + (cdr (syntax-object-marks expression)) + (cons mark (syntax-object-marks expression))))) + + + (define (add-marks marks expression) + (let loop ((marks marks) + (expression expression)) + (match marks + ('() expression) + ((mark . marks) + (loop marks (add-mark mark expression)))))) + + + (define (anti-mark expression) + (add-mark #f expression)) + + + (define (decorate marks expression environment) + (add-marks marks (wrap-syntax expression environment))) + + + (define (with-wrap expression parent) + (decorate (marks parent) expression (syntax-object-environment parent))) + + + (define (syntax-map f expr) + (with-wrap (f (syntax->expression expr)) expr)) + + + (define-record-type <syntax-case-no-match> + (make-syntax-case-no-match) + syntax-case-no-match?) + + + (define-syntax syntax-case-match-pattern + (syntax-rules (_ when) + ((syntax-case-match-pattern x pattern (when condition) result result* ...) + (syntax-case-match-pattern x pattern + (if condition + (begin result result* ...) + (raise (make-syntax-case-no-match))))) + ((syntax-case-match-pattern x _ result result* ...) + (begin result result* ...)) + ((syntax-case-match-pattern x '() result result* ...) + (if (null? (syntax->expression x)) + (begin result result* ...) + (raise (make-syntax-case-no-match)))) + ((syntax-case-match-pattern x (pattern) result result* ...) + (if (= 1 (length (syntax->expression x))) + (syntax-case-match-pattern (syntax-map car x) pattern result result* ...) + (raise (make-syntax-case-no-match)))) + ((syntax-case-match-pattern x (pattern . rest) result result* ...) + (let ((y x)) + (if (pair? (syntax->expression y)) + (syntax-case-match-pattern (syntax-map car y) pattern + (syntax-case-match-pattern (syntax-map cdr y) rest result result* ...))))) + ((syntax-case-match-pattern x ident result result* ...) + (let ((ident x)) result result* ...)))) + + + ; Yes, I just defined syntax-case in terms of syntax-rules. + ; Are we sure this won't create a black hole? + (define-syntax syntax-case + (syntax-rules () + ((syntax-case x (arm ...)) + (guard (e ((syntax-case-no-match? e) (if #f #f))) + (syntax-case-match-pattern x arm ...))) + ((syntax-case x (arm ...) clause clause* ...) + (let ((y x)) + (guard (e ((syntax-case-no-match? e) + (syntax-case y clause clause* ...))) + (syntax-case-match-pattern y arm ...)))))) + + + (define (expand-procedure-call procedure arguments) + (let-values (((expanded-procedure environment) (expand-syntax-object procedure)) + ((expanded-arguments) (let loop ((arguments arguments) - (environment environment) (expanded-arguments '())) - (match arguments - ('() (values (reverse expanded-arguments) environment)) + (syntax-case arguments + ('() (reverse expanded-arguments)) ((argument . rest) - (let-values (((expanded-argument environment) (expand argument environment))) - (loop - rest - environment - (cons expanded-argument expanded-arguments)))) + (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)))))) (make-call expanded-procedure expanded-arguments))) + ; From R6RS: + ; Each time the expander encounters a macro use, it applies an antimark to + ; the input form, invokes the associated transformer, then applies a fresh + ; mark to the output. + ; + ; In cute scheme, macros compile themselves, and syntax-rules is therefore + ; responsible for applying a mark to an expanded expression before + ; expanding it with expand-syntax-object. + (define (expand-macro-use transformer syntax) + ((transformer-function transformer) (anti-mark syntax))) + + + (define (expand-syntax-object syntax) + (syntax-case syntax + ('() (raise-syntax-error "nil by itself is an error (did you mean to use quote?)" syntax)) + ((macro-name . tail) (when (identifier? macro-name)) + (let ((macro-body + (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" macro-name))) + (lookup (environment-substitutions (syntax-object-environment macro-name)) macro-name)))) + (if (macro-transformer? macro-body) + (expand-macro-use macro-body syntax) + (values (expand-procedure-call macro-name tail) (syntax-object-environment syntax))))) + ((procedure . arguments) + (values (expand-procedure-call procedure arguments) (syntax-object-environment syntax))) + (_ (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))))) + (_ (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))) + (_ (raise-syntax-error "unexpected expression type" syntax)))) + + ; 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)))) + (expand-syntax-object (wrap-syntax expression environment))) (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)))))) + (lambda (syntax) + (syntax-case syntax + ((_ datum) (values (make-constant (syntax->expression datum)) (syntax-object-environment syntax))) + (_ (raise-syntax-error "invalid form for quote" syntax)))))) - (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 (syntax->expression s) + (if (syntax-object? s) + (syntax-object-expression s) + s)) - #;(define builtin-syntax-rules - (make-macro-transformer - (lambda (expression environment) - (match expression)))) + (define (matches-literals literals object) + (unless (list? (syntax->expression literals)) + (raise-syntax-error "invalid form in literals, expecting list" literals)) + (let ((literal-identifiers + (map + (lambda (lit) (with-wrap lit literals)) + (syntax->expression literals)))) + (let loop ((literal-identifiers literal-identifiers)) + (match literal-identifiers + ('() #f) + ((lit . literals) + (or (free-identifier=? lit object) + (loop literals))))))) - (define (hash-symbol s) - (hash-bytevector (string->utf8 (symbol->string s)))) + (define (identifier-uuid i) + ; Join marks by ( because symbols aren't allowed to have ( in the name. + (sprintf "{}({}" (apply join "(" (map number->string (marks i))) (identifier-name i))) - (define (symbol<? s1 s2) - (string<? (symbol->string s1) (symbol->string s2))) + (define (hash-identifier i) + (hash-bytevector (string->utf8 (identifier-uuid i)))) + + + (define (cmp-identifier i1 i2) + (cond + ((string<? (identifier-uuid i1) (identifier-uuid i2)) -1) + ((string=? (identifier-uuid i1) (identifier-uuid i2)) 0) + (else 1))) + + + (define (alist->substitutions l) + (alist->map hash-identifier cmp-identifier l)) + + + (define (is-underscore expression) + (free-identifier=? + expression + (wrap-syntax '_ (make-environment (alist->substitutions (list (cons '_ (make-library-ref '(csc builtins) '_ #t)))) '())))) + + + (define (pattern-bindings pattern literals object) + (syntax-case pattern + (lit (when (and (free-identifier=? object lit) + (matches-literals literals object))) + (alist->substitutions '())) + (underscore (when (is-underscore underscore)) + (alist->substitutions '())) + (ident (when (identifier? ident)) + (alist->substitutions (list (cons ident object)))) + ('() + (syntax-case object + ('() (alist->substitutions '())) + (_ #f))) + ((p . p*) + (syntax-case object + ((e . e*) + (merge (pattern-bindings p literals e) + (pattern-bindings p* literals e*))) + (_ #f))) + (constant + (if (equal? constant (syntax->expression object)) + (alist->substitutions '()) + #f)))) + + + (define (expand-template substitutions template) + (syntax-case template + ('() (with-wrap '() template)) + ((head . tail) + (with-wrap + (cons (expand-template substitutions head) + (expand-template substitutions tail)) + template)) + (ident (when (identifier? ident)) + (guard (e ((key-not-found-error? e) template)) + (lookup substitutions template))) + (_ template))) + + + (define (syntax-match literals all-rules object) + (let loop ((rules all-rules)) + (syntax-case rules + ('() (raise-syntax-error "form did not match any patterns in syntax-rules" object (map car all-rules))) + ((((_ . pattern) template) . tail) + (let ((bindings (pattern-bindings pattern literals (with-wrap (cdr (syntax->expression object)) object)))) + (if bindings + ; Each time the expander encounters a macro use, + ; it applies an antimark to the input form, + ; invokes the associated transformer, + ; then applies a fresh mark to the output. + ; + ; We also call expand-syntax-object immediately, + ; since macros are allowed to be recursive -- rose + (expand-syntax-object (add-mark (new-mark) (expand-template bindings template))) + (loop tail)))) + (_ (raise-syntax-error "unexpected form in syntax-rules" all-rules))))) + + + (define builtin-syntax-rules + (make-macro-transformer + (lambda (syntax-rules-form) + (syntax-case syntax-rules-form + ((_ literals . rules) + (values + (make-macro-transformer + (lambda (input-form) + (syntax-match literals rules input-form))) + (syntax-object-environment syntax-rules-form))) + (_ (raise-syntax-error "unexpected form in syntax-rules" syntax-rules-form)))))) (define test-environment (make-environment - (alist->map - hash-symbol - symbol<? - (list - (cons 'quote builtin-quote) - (cons 'lambda builtin-lambda))) + (alist->substitutions + (list (cons 'syntax-rules builtin-syntax-rules) + (cons 'quote builtin-quote) + (cons '_ (make-library-ref '(csc builtins) '_ #t)))) '())))) diff --git a/csc/match.csc b/csc/match.csc index 86efab7..5b85f09 100644 --- a/csc/match.csc +++ b/csc/match.csc @@ -4,41 +4,6 @@ (begin - (define-syntax matches? - (syntax-rules (_ !) - ((matches? x _) #t) - ((matches? x '()) - (null? x)) - ((matches? x (! constant)) - (equal? x constant)) - ((matches? x (pattern)) - (and (= 1 (length x)) - (matches? (car x) pattern))) - ((matches? x (pattern1 . pattern2)) - (and (pair? x) - (matches? (car x) pattern1) - (matches? (cdr x) pattern2))) - ((matches? x identifier) #t))) - - - (define-syntax bind-pattern - (syntax-rules (_ !) - ((bind-pattern x _ result result* ...) - (begin result result* ...)) - ((bind-pattern x '() result result* ...) - (begin result result* ...)) - ((bind-pattern x (! constant) result result* ...) - (begin result result* ...)) - ((bind-pattern x (pattern) result result* ...) - (bind-pattern (car x) pattern result result* ...)) - ((bind-pattern x (pattern1 . pattern2) result result* ...) - (bind-pattern (car x) pattern1 - (bind-pattern (cdr x) pattern2 result result* ...))) - ((bind-pattern x identifier result result* ...) - (let ((identifier x)) - result result* ...)))) - - (define-record-type <no-match> (make-no-match) no-match?) @@ -62,25 +27,28 @@ (begin result result* ...) (raise (make-no-match)))) ((match-pattern x (pattern) result result* ...) - (if (= 1 (length x)) - (match-pattern (car x) pattern result result* ...) - (raise (make-no-match)))) + (let ((y x)) + (if (= 1 (length y)) + (match-pattern (car y) pattern result result* ...) + (raise (make-no-match))))) ((match-pattern x (pattern . rest) result result* ...) - (if (pair? x) - (match-pattern (car x) pattern - (match-pattern (cdr x) rest result result* ...)) - (raise (make-no-match)))) + (let ((y x)) + (if (pair? y) + (match-pattern (car y) pattern + (match-pattern (cdr y) rest result result* ...)) + (raise (make-no-match))))) ((match-pattern x identifier result result* ...) (let ((identifier x)) result result* ...)))) (define-syntax match - (syntax-rules (when) - ((match x (pattern result result* ...)) + (syntax-rules () + ((match x (arm ...)) (guard (e ((no-match? e) (if #f #f))) - (match-pattern x pattern result result* ...))) - ((match x (pattern result result* ...) clause clause* ...) - (guard (e ((no-match? e) - (match x clause clause* ...))) - (match-pattern x pattern result result* ...))))))) + (match-pattern x arm ...))) + ((match x (arm ...) clause clause* ...) + (let ((y x)) + (guard (e ((no-match? e) + (match y clause clause* ...))) + (match-pattern y arm ...)))))))) |