diff --git a/bootstrap.rkt b/bootstrap.rkt new file mode 100644 index 00000000..f48873b0 --- /dev/null +++ b/bootstrap.rkt @@ -0,0 +1,476 @@ +#lang racket + +(require (rename-in racket [syntax-case racket-syntax-case])) +(require racket/pretty) + +; Problem: bootstrapping can be difficult. When we don't yet have convenient +; macro-defining macros like fancy-syntax-case, it can be inconvenient to write +; complex macros such as fancy-syntax-case. +; +; Solution: instead of manually defining Klister's fancy-syntax-case using +; Klister's more primitive raw-syntax-case, we write some Racket code which +; expands to the code we would have written manually. This is easier, because +; Racket does have convenient syntax-manipulating macros like match, +; quasiquote, and racket-syntax-case. + +; (generate-syntax-case 'my-macro 'stx (list 'keyword) +; (list +; (list '() +; 'rhs1) +; (list '((,a ,b) (,c ,d)) +; 'rhs2) +; (list '(keyword ,tail ...) +; '(> (length tail) 2) +; 'rhs3))) +; => +; '(let [failure-cc +; (lambda () +; (syntax-error '"my-macro call has invalid syntax" stx))] +; (let [failure-cc +; (lambda () +; (raw-syntax-case stx +; [(cons head tail) +; (if (identifier? head) +; (>>= (free-identifier=? head 'keyword) +; (lambda (same-identifier) +; (if same-identifier +; (if (> (length tail) 2) +; rhs3 +; (failure-cc)) +; (failure-cc)))) +; (failure-cc))] +; [_ (failure-cc)]))] +; (let [failure-cc +; (lambda () +; (raw-syntax-case stx +; [(cons ab cd-nil) +; (raw-syntax-case ab +; [(cons a b-nil) +; (...etc... rhs2)] +; [_ (failure-cc)])] +; [_ (failure-cc)]))] +; (let [failure-cc +; (lambda () +; (raw-syntax-case stx +; [() rhs1] +; [_ (failure-cc)]))] +; (failure-cc))))) +(define (generate-syntax-case macro-name stx-expr keywords cases) + (letrec ([stx-name (gensym 'stx-)] + [failure-cc-name (gensym 'failure-cc-)] + [generate-guard-rhs + (lambda (guard-rhs) + (match guard-rhs + [`(,guard ,rhs) + `(>>= ,guard + (lambda (guard-approves) + (if guard-approves ,rhs (,failure-cc-name))))] + [`(,rhs) + rhs]))] + [generate-case + (lambda (scrutinee-name case) + (match case + [(cons pat guard-rhs) + (match pat + [`() + `(raw-syntax-case ,scrutinee-name + [() ,(generate-guard-rhs guard-rhs)] + [_ (,failure-cc-name)])] + [`_ + (generate-guard-rhs guard-rhs)] + [keyword + #:when (and (symbol? keyword) + (member keyword keywords)) + `(if (identifier? ,scrutinee-name) + (>>= (free-identifier=? ,scrutinee-name ',keyword) + (lambda (same-identifier) + (if same-identifier + ,(generate-guard-rhs guard-rhs) + (,failure-cc-name)))) + (,failure-cc-name))] + [`(,'unquote ,x) + #:when (symbol? x) + `(let [,x ,scrutinee-name] + ,(generate-guard-rhs guard-rhs))] + [x + #:when (symbol? x) + (raise-arguments-error + 'generate-syntax-case + (string-append + "naked symbol " + (symbol->string x) + ": did you mean ," + (symbol->string x) + " or to add " + (symbol->string x) + " to the list of keywords?") + "symbol" x + "keywords" keywords)] + [`((,'unquote ,x) ,'...) + `(let [,x ,scrutinee-name] + ,(generate-guard-rhs guard-rhs))] + [`(,e ,'...) + (raise-arguments-error + 'generate-syntax-case + "the syntax for ellipsis is '(,x ...)" + "found" `(,e ...))] + [`(,pat-head ,@pat-tail) + (let ([head-name (gensym 'head-)] + [tail-name (gensym 'tail-)]) + `(raw-syntax-case ,scrutinee-name + [(cons ,head-name ,tail-name) + ,(generate-case head-name + (list pat-head + (generate-case tail-name + (cons pat-tail guard-rhs))))] + [_ (,failure-cc-name)]))])]))] + [generate-cases + (lambda (cases inner) + (match cases + ['() + inner] + [`(,case ,@cases) + (generate-cases cases + `(let [,failure-cc-name + (lambda () + ,(generate-case stx-name case))] + ,inner))]))]) + `(let [,stx-name ,stx-expr] + (let [,failure-cc-name + (lambda () + (syntax-error + ',(string-append + (symbol->string macro-name) + " call has invalid syntax") + ,stx-name))] + ,(generate-cases cases `(,failure-cc-name)))))) + +; `(1 ,(list 2 3) ,@(list 4 5) 6) +; => +; '(1 (2 3) 4 5 6) +; +; (generate-quasiquote +; '(1 +; ,'(2 3) +; ,'(4 5) ... +; 6) +; 'stx) +; => +; '(cons-list-syntax 1 +; (cons-list-syntax '(2 3) +; (append-list-syntax '(4 5) +; (cons-list-syntax 6 +; '() +; stx) +; stx) +; stx) +; stx) +; => +; '(1 (2 3) 4 5 6) +(define (generate-quasiquote pat stx-name) + (match pat + [`(,'unquote ,x) + x] + [`((,'unquote ,head) ,'... ,@tail) + `(append-list-syntax + ,head + ,(generate-quasiquote tail stx-name) + ,stx-name)] + [`(,head ,@tail) + `(cons-list-syntax + ,(generate-quasiquote head stx-name) + ,(generate-quasiquote tail stx-name) + ,stx-name)] + [x + `(quote ,x)])) + + +; (auto-splice +; (define-macros +; ([my-macro +; (lambda (stx) +; (generate-syntax-case my-macro stx (keyword) +; [() +; (pure ''nil)] +; [((,a ,b) (,c ,d)) +; (let [quadruple (generate-quasiquote (,a ,b ,c ,d) stx)] +; (pure (generate-quasiquote '(four-elements ,quadruple) stx)))] +; [(keyword ,tail ...) +; (pure (generate-quasiquote '(keyword-prefixed (,tail ...)) stx))]))]))) +; => +; `(define-macros +; ([my-macro +; (lambda (stx) +; ,(generate-syntax-case 'my-macro 'stx (list 'keyword) +; (list +; (list '() +; `(pure ''nil)) +; (list '((,a ,b) (,c ,d)) +; `(let [quadruple ,(generate-quasiquote '(,a ,b ,c ,d) 'stx)] +; (pure ,(generate-quasiquote ''(four-elements ,quadruple) 'stx)))) +; (list '(keyword ,tail ...) +; `(pure ,(generate-quasiquote ''(keyword-prefixed (,tail ...)) 'stx))))))])) +(define-syntax (auto-splice stx) + (racket-syntax-case stx (generate-quasiquote generate-syntax-case) + [(_ ()) + #''()] + [(_ (generate-quasiquote pat stx-name)) + #'(generate-quasiquote 'pat 'stx-name)] + [(_ (generate-syntax-case macro-name stx-expr (keyword ...) + [lhs rhs ...] ...)) + #'(generate-syntax-case 'macro-name 'stx-expr (list 'keyword ...) + (list + (list 'lhs + (auto-splice rhs) ...) + ...))] + [(_ (head tail ...)) + #'(cons (auto-splice head) + (auto-splice (tail ...)))] + [(_ x) + #''x])) + +(void + (call-with-output-file + "examples/dot-dot-dot.kl" + #:exists 'truncate + (lambda (out) + (parameterize ([current-output-port out] + [pretty-print-columns 40]) + (let ([newline + (lambda () + (pretty-print-newline out (pretty-print-columns)))] + [displayln + (lambda (s) + (pretty-display s #:newline? #t))] + [writeln + (lambda (v) + (pretty-write v #:newline? #t))]) + (displayln "#lang \"prelude.kl\"") + (displayln "-- GENERATED BY ../bootstrap.rkt, DO NOT EDIT") + + (map + (lambda (form) + (newline) + (writeln form)) + (list + '(import (rename "prelude.kl" + [syntax-case raw-syntax-case])) + '(import (rename (shift "prelude.kl" 1) + [syntax-case raw-syntax-case])) + '(import (shift "identifier.kl" 1)) + '(import (shift "list-syntax.kl" 1)) + '(import (shift "temporaries.kl" 1)) + + (auto-splice + (define-macros + ([fancy-unquote (lambda (stx) (syntax-error '"unquote used out of context" stx))] + [fancy-... (lambda (stx) (syntax-error '"... used out of context" stx))] + [fancy-_ (lambda (stx) (syntax-error '"_ used out of context" stx))] + [fancy-syntax-case + (flet [list-of-keywords? (xs) + (generate-syntax-case syntax-case xs () + [() + (pure (true))] + [(,x ,xs ...) + (pure (identifier? x)) + (list-of-keywords? xs)] + [_ + (pure (false))])] + (lambda (stx) + (generate-syntax-case syntax-case stx () + [(_ ,stx-expr (,keywords ...) ,cases ...) + (let [stx-name 'stx] + (>>= (list-of-keywords? keywords) + (lambda (keywords-are-keywords) + (if keywords-are-keywords + (flet [is-identifier-in-list? (identifier xs) + (generate-syntax-case syntax-case xs () + [() + (pure (false))] + [(,x ,xs ...) + (>>= (free-identifier=? identifier x) + (lambda (same-identifier) + (if same-identifier + (pure (true)) + (is-identifier-in-list? identifier xs))))])] + (let [keyword? + (lambda (keyword) + (is-identifier-in-list? keyword keywords))] + (flet [fancy-guard-rhs (guard-rhs) + (generate-syntax-case syntax-case guard-rhs () + [(,guard ,rhs) + (pure (generate-quasiquote + (>>= ,guard + (lambda (guard-approves) + (if guard-approves ,rhs (failure-cc)))) + stx))] + [(,rhs) + (pure rhs)])] + (flet [fancy-case (scrutinee-name case) + (generate-syntax-case syntax-case case () + [(,pat ,guard-rhs ...) + (>>= (fancy-guard-rhs guard-rhs) + (lambda (rhs) + (generate-syntax-case syntax-case pat (fancy-unquote fancy-... fancy-_) + [() + (pure (generate-quasiquote + (raw-syntax-case ,scrutinee-name + [() ,rhs] + [_ (failure-cc)]) + stx))] + [fancy-_ + (pure rhs)] + [,keyword + (pure (identifier? keyword)) + (>>= (keyword? keyword) + (lambda (is-keyword) + (if is-keyword + (pure (generate-quasiquote + (if (identifier? ,scrutinee-name) + (>>= (free-identifier=? ,scrutinee-name ',keyword) + (lambda (same-identifier) + (if same-identifier + ,rhs + (failure-cc)))) + (failure-cc)) + stx)) + (syntax-error (list-syntax + ('"syntax-case: naked symbol" + keyword + '"did you mean (unquote symbol)?" + '"did you mean to add the symbol to the keyword list?") + stx) + stx))))] + [(fancy-unquote ,x) + (if (identifier? x) + (pure (generate-quasiquote + (let [,x ,scrutinee-name] + ,rhs) + stx)) + (syntax-error (list-syntax + ('"syntax-case: the syntax for binding values is (unquote x), found" + pat + '"instead") + stx) + stx))] + [((fancy-unquote ,x) fancy-...) + (if (identifier? x) + (pure (generate-quasiquote + (let [,x ,scrutinee-name] + ,rhs) + stx)) + (syntax-error (list-syntax + ('"syntax-case: the syntax for binding lists is (,x ...), found" + pat + '"instead") + stx) + stx))] + [(,pat-head ,pat-tail ...) + (>>= (make-temporary 'tail) + (lambda (tail-name) + (>>= (fancy-case tail-name + (pair-list-syntax pat-tail rhs + stx)) + (lambda (rhs-tail) + (>>= (make-temporary 'head) + (lambda (head-name) + (>>= (fancy-case head-name + (pair-list-syntax pat-head rhs-tail + stx)) + (lambda (rhs-head) + (pure (generate-quasiquote + (raw-syntax-case ,scrutinee-name + [(cons ,head-name ,tail-name) + ,rhs-head] + [_ (failure-cc)]) + stx))))))))))] + [_ + (pure (generate-quasiquote + (failure-cc) + stx))])))])] + (flet [fancy-cases (cases inner-cases) + (generate-syntax-case syntax-case cases () + [() + (pure inner-cases)] + [(,case ,cases ...) + (>>= (fancy-case stx-name case) + (lambda (inner-case) + (fancy-cases cases + (generate-quasiquote + (let [failure-cc + (lambda () + ,inner-case)] + ,inner-cases) + stx))))])] + (>>= (fancy-cases cases + (generate-quasiquote + (failure-cc) + stx)) + (lambda (outer-cases) + (pure (generate-quasiquote + (let [,stx-name ,stx-expr] + (let [failure-cc + (lambda () + (syntax-error (list-syntax + ('"syntax-case: the input" + ,stx-name + '"does not match any of the following patterns" + ',(map car cases)) + stx) + stx))] + ,outer-cases)) + stx))))))))) + (syntax-error (list-syntax + ('"syntax-case:" + keywords + '"does not look like a list of keywords." + '"did you forget a () between the input and the cases?") + stx))))))])))] + [fancy-quasiquote + (lambda (stx) + (generate-syntax-case fancy-quasiquote stx () + [(_ ,pat) + (let [stx-name (generate-quasiquote + ',(replace-loc pat 'here) + 'here)] + (flet [fancy-inside (pat) + (generate-syntax-case fancy-quasiquote pat (fancy-unquote fancy-...) + [(fancy-unquote ,x) + (pure x)] + [((fancy-unquote ,head) fancy-... ,tail ...) + (>>= (fancy-inside tail) + (lambda (inside-tail) + (pure (generate-quasiquote + (append-list-syntax + ,head + ,inside-tail + ,stx-name) + stx))))] + [(,head ,tail ...) + (>>= (fancy-inside head) + (lambda (inside-head) + (>>= (fancy-inside tail) + (lambda (inside-tail) + (pure (generate-quasiquote + (cons-list-syntax + ,inside-head + ,inside-tail + ,stx-name) + stx))))))] + [,x + (pure (pair-list-syntax + 'quote + x + stx))])] + (fancy-inside pat)))]))]))) + + '(export (rename ([fancy-syntax-case syntax-case] + [fancy-quasiquote quasiquote] + [fancy-unquote unquote] + [fancy-... ...] + [fancy-_ _]) + fancy-syntax-case + fancy-quasiquote + fancy-unquote + fancy-... + fancy-_))))))))) diff --git a/bootstrap/README.md b/bootstrap/README.md new file mode 100644 index 00000000..a4bacd1c --- /dev/null +++ b/bootstrap/README.md @@ -0,0 +1,77 @@ +# bootstrapping + +This file explains why we use Racket to generate some Klister code in order to +bootstrap our library of useful macros. + + +## the problem + +The Klister `#kernel` provides a `syntax-case` macro, which I'll call +`raw-syntax-case` in this file. `raw-syntax-case` is minimalist: it only +supports shallow patterns. The idea is that deep patterns can and should be +implemented as a library, as a macro which I'll call `fancy-syntax-case`. + +We must define `fancy-syntax-case` as a macro which expands to a number of calls +to `raw-syntax-case`. Because `fancy-syntax-case` is not yet defined, that macro +definition will need to pattern-match on its input using `raw-syntax-case`. +That's a bummer, because that makes the macro definition long and hard to read. + + (define-syntax (fancy-syntax-case stx) + (raw-syntax-case stx + [(cons _ scrutinee-keywords-cases) + (raw-syntax-case scrutinee-keywords-cases + [(cons scrutinee keywords-cases) + (raw-syntax-case keywords-cases + [(cons keywords cases) + ...etc...])])])) + +I would prefer to write that macro definition using `fancy-syntax-case` itself! +That would make the code much shorter and more readable. + + (define-syntax (fancy-syntax-case stx) + (fancy-syntax-case stx + [(_ ,scrutinee (,(keywords ... )) ,(cases ...)) + ...etc...])) + +That sounds impossible, but there is a way! + + +## the solution + +The trick is to write the short +readable definition that we want to write and to convert it into the long +unreadable definition. Writing this transformation using Klister would again +require using `raw-syntax-case`, so we use Racket instead. + +We thus want to write a Racket program which expands `fancy-syntax-case` calls +into a number of calls to `raw-syntax-case`. But wait, we already have a program +which does that, it's the short readable definition we just wrote! Rather than +reimplement this Klister program in Racket, let's automatically translate this +program to Racket via a Racket `#lang`. Since the program assumes that +`fancy-syntax-case` already exists, this `#lang` must be a version of Klister in +which `fancy-syntax-case` is builtin. Thankfully, Racket's `syntax-case` (which +I will call `racket-syntax-case`) is already quite fancy, so we only need to +translate `fancy-syntax-case` calls into `racket-syntax-case` calls. We can do +this by writing a Racket macro. + +The overall picture is that we used to have one daunting task: + +1. Use `raw-syntax-case` to expand `fancy-syntax-case` into a number of calls + to `raw-syntax-case`. + +And we now have two easier tasks: + +1. Use `fancy-syntax-case` to expand `fancy-syntax-case` into a number of calls + to `raw-syntax-case`. +2. Use `racket-syntax-case` to expand `fancy-syntax-case` into a call to + `racket-syntax-case`. + + +# the scope + +The above argument also applies to `quasiquote`, which is also very useful when +defining other macros. By defining both `fancy-syntax-case` and +`fancy-quasiquote` at the same time using the above technique, we get to use +both `fancy-syntax-case` and `fancy-quasiquote` when defining both macros. This +is thus a technique which becomes more useful as we define more macros +simulaneously. We may thus add more macros to the list in the future. diff --git a/examples/bool.kl b/examples/bool.kl index 5eaf5afc..ad755095 100644 --- a/examples/bool.kl +++ b/examples/bool.kl @@ -1,7 +1,7 @@ #lang "prelude.kl" (import (shift "prelude.kl" 1)) -(import (shift "quasiquote.kl" 1)) +(import (shift "dot-dot-dot.kl" 1)) (define not (lambda (b) @@ -16,24 +16,18 @@ (if x (true) y))) (define-macros - ((and (lambda (stx) - (syntax-case stx - ((cons _ args) - (syntax-case args - (() - (pure '(true))) - ((cons x xs) - (pure `(binary-and ,x - ,(cons-list-syntax 'and xs stx))))))))) - (or (lambda (stx) - (syntax-case stx - ((cons _ args) - (syntax-case args - (() - (pure '(false))) - ((cons x xs) - (pure `(binary-or ,x - ,(cons-list-syntax 'or xs stx))))))))))) + ([and (lambda (stx) + (syntax-case stx () + [(_) + (pure '(true))] + [(_ ,x ,xs ...) + (pure `(binary-and ,x (and ,xs ...)))]))] + [or (lambda (stx) + (syntax-case stx () + [(_) + (pure '(false))] + [(_ ,x ,xs ...) + (pure `(binary-or ,x (or ,xs ...)))]))])) (example (binary-and (false) (false))) (example (binary-and (false) (true))) diff --git a/examples/datatype-macro.kl b/examples/datatype-macro.kl index 2915e833..7b02a174 100644 --- a/examples/datatype-macro.kl +++ b/examples/datatype-macro.kl @@ -3,7 +3,7 @@ (import (shift "prelude.kl" 1)) (import (shift "lispy-do.kl" 1)) (import (shift "let.kl" 1)) -(import (shift "quasiquote.kl" 1)) +(import (shift "dot-dot-dot.kl" 1)) (import (shift (only "list-syntax.kl" map) 1)) @@ -24,13 +24,12 @@ (define-macros ([list (lambda (stx) - (syntax-case stx - [(cons _ more) - (syntax-case more - [() - (pure (replace-loc more '(nil)))] - [(cons x xs) - (pure (quasiquote/loc more (:: ,x ,(cons-list-syntax 'list xs xs))))])]))])) + (syntax-case stx () + [(_) + (pure (replace-loc stx '(nil)))] + [(_ ,x ,xs ...) + (pure (replace-loc stx + `(:: ,x (list ,xs ...))))]))])) (example (reverse (:: 1 (:: 2 (:: 3 (nil)))))) @@ -42,9 +41,10 @@ (define-macros ([head (lambda (stx) - (syntax-case stx - [(list (_ x)) - (pure (quasiquote/loc stx (:: ,x xs)))]))])) + (syntax-case stx () + [(_ ,x) + (pure (replace-loc stx + `(:: ,x xs)))]))])) (example (case (reverse null) [null 'a])) diff --git a/examples/define-syntax-rule.golden b/examples/define-syntax-rule.golden index 5f4306b1..34973b48 100644 --- a/examples/define-syntax-rule.golden +++ b/examples/define-syntax-rule.golden @@ -1 +1 @@ -#[define-syntax-rule.kl:46.33-46.36] : Syntax +#[define-syntax-rule.kl:42.33-42.36] : Syntax diff --git a/examples/define-syntax-rule.kl b/examples/define-syntax-rule.kl index 58ad7d8e..d6649f81 100644 --- a/examples/define-syntax-rule.kl +++ b/examples/define-syntax-rule.kl @@ -1,44 +1,40 @@ #lang "prelude.kl" +(import (rename (shift "prelude.kl" 1) [syntax-case raw-syntax-case])) (import (shift "prelude.kl" 1)) (import (shift "do.kl" 1)) (import (shift "list-syntax.kl" 1)) -(import (shift "quasiquote.kl" 1)) +(import (shift "dot-dot-dot.kl" 1)) (import (shift "syntax.kl" 1)) (define-macros - ((define-macro + ([define-macro (lambda (stx) - (syntax-case stx - ((list (_ pattern body)) - (syntax-case pattern - ((cons macro-name args) - (pure `(define-macros - ((,macro-name (lambda (stx) - (syntax-case stx - ((list ,pattern) - ,body))))))))))))))) + (syntax-case stx () + [(_ (,macro-name ,args ...) ,body) + (pure `(define-macros + ([,macro-name + (lambda (stx) + (raw-syntax-case stx + [(list (_ ,args ...)) + ,body]))])))]))])) (define-macros - ((define-syntax-rule + ([define-syntax-rule (lambda (stx) - (syntax-case stx - ((list (_ pattern template)) - (syntax-case pattern - ((cons macro-name args) - (do (unquoted-template <- (foldlM (lambda (t arg) - (replace-identifier - arg - (list-syntax ('unquote arg) stx) - t)) - template - args)) - (quasiquoted-template <- (pure (list-syntax ('quasiquote unquoted-template) stx))) - (pure `(define-macros - ((,macro-name (lambda (stx) - (syntax-case stx - ((list ,pattern) - (pure ,quasiquoted-template))))))))))))))))) + (syntax-case stx () + [(_ (,macro-name ,args ...) ,template) + (do (unquoted-template <- (foldlM (lambda (t arg) + (replace-identifier arg `(,'unquote ,arg) t)) + template + args)) + (quasiquoted-template <- (pure `(,'quasiquote ,unquoted-template))) + (pure `(define-macros + ([,macro-name + (lambda (stx) + (raw-syntax-case stx + [(list (_ ,args ...)) + (pure ,quasiquoted-template)]))]))))]))])) (define-syntax-rule (lambda2 x y body) (lambda (x y) body)) diff --git a/examples/do-keywords.golden b/examples/do-keywords.golden new file mode 100644 index 00000000..e69de29b diff --git a/examples/do-keywords.kl b/examples/do-keywords.kl new file mode 100644 index 00000000..79ebf4b3 --- /dev/null +++ b/examples/do-keywords.kl @@ -0,0 +1,8 @@ +#lang "prelude.kl" + +(import (shift "prelude.kl" 1)) + +(define-macros + ([<- (lambda (stx) (syntax-error (quote "<- used out of context") stx))])) + +(export <-) diff --git a/examples/do.kl b/examples/do.kl index 97f2ef9b..970b45af 100644 --- a/examples/do.kl +++ b/examples/do.kl @@ -1,8 +1,9 @@ #lang "prelude.kl" (import (shift "prelude.kl" 1)) -(import (shift "quasiquote.kl" 1)) -(import (shift "let.kl" 1)) +(import (shift "dot-dot-dot.kl" 1)) +(import (shift "do-keywords.kl" 1)) +(import "do-keywords.kl") (define-macros -- (do (x <- foo) @@ -14,27 +15,17 @@ -- (>>= (bar x) (lambda (_) -- (>>= (baz x) (lambda (y) -- (quux x y))))))) - ((<- - (lambda (stx) - (syntax-error (quote "<- used out of context") stx))) - (do (lambda (stx) - (syntax-case stx - ((cons _ all-actions) - (syntax-case all-actions - ((list (last-action)) - (pure last-action)) - ((cons first-action actions) - (let ((otherwise (pure `(>>= ,first-action (lambda (_) - ,(cons-list-syntax 'do actions stx)))))) - (syntax-case first-action - ((list (var <-? action)) - (>>= (free-identifier=? '<- <-?) - (lambda (isArrow) - (if isArrow - (pure `(>>= ,action (lambda (,var) - ,(cons-list-syntax 'do actions stx)))) - otherwise)))) - (_ - otherwise))))))))))) + ([do (lambda (stx) + (syntax-case stx (<-) + [(_ ,last-action) + (pure last-action)] + [(_ (,var <- ,action) ,actions ...) + (pure `(>>= ,action + (lambda (,var) + (do ,actions ...))))] + [(_ ,action ,actions ...) + (pure `(>>= ,action + (lambda (_) + (do ,actions ...))))]))])) (export <- do) diff --git a/examples/dot-dot-dot-test-keywords.golden b/examples/dot-dot-dot-test-keywords.golden new file mode 100644 index 00000000..e69de29b diff --git a/examples/dot-dot-dot-test-keywords.kl b/examples/dot-dot-dot-test-keywords.kl new file mode 100644 index 00000000..db42cc05 --- /dev/null +++ b/examples/dot-dot-dot-test-keywords.kl @@ -0,0 +1,8 @@ +#lang "prelude.kl" + +(import (shift "prelude.kl" 1)) + +(define-macros + ([keyword (lambda (stx) (syntax-error '"keyword used out of context" stx))])) + +(export keyword) diff --git a/examples/dot-dot-dot-test.golden b/examples/dot-dot-dot-test.golden new file mode 100644 index 00000000..f298fe40 --- /dev/null +++ b/examples/dot-dot-dot-test.golden @@ -0,0 +1,5 @@ +#[dot-dot-dot-test.kl:17.17-17.31]<(1 2 3 4)> : Syntax +#[dot-dot-dot-test.kl:20.17-20.75] + <(keyword-identifier-prefixed bar baz end-of-list)> : Syntax +#[dot-dot-dot-test.kl:22.17-22.58]<(keyword-prefixed 3 4 end-of-list)> : Syntax +#[dot-dot-dot-test.kl:24.17-24.52]<(ordinary-list foo bar baz end-of-list)> : Syntax diff --git a/examples/dot-dot-dot-test.kl b/examples/dot-dot-dot-test.kl new file mode 100644 index 00000000..8a255585 --- /dev/null +++ b/examples/dot-dot-dot-test.kl @@ -0,0 +1,29 @@ +#lang "prelude.kl" + +(import (rename (shift "prelude.kl" 1) + [syntax-case raw-syntax-case] + [unquote raw-unquote] + [... raw-...])) +(import "dot-dot-dot-test-keywords.kl") +(import (shift "dot-dot-dot-test-keywords.kl" 1)) +(import (shift "dot-dot-dot.kl" 1)) +(import (shift "identifier.kl" 1)) + +(define-macros + ([my-macro + (lambda (stx) + (syntax-case stx (keyword) + [(_ ((,a ,b) (,c ,d))) + (pure `'(,a ,b ,c ,d))] + [(_ (keyword ,head ,tail ...)) + (pure (identifier? head)) + (pure `'(keyword-identifier-prefixed ,head ,tail ... end-of-list))] + [(_ (keyword ,tail ...)) + (pure `'(keyword-prefixed ,tail ... end-of-list))] + [(_ (,e ...)) + (pure `'(ordinary-list ,e ... end-of-list))]))])) + +(example (my-macro ((1 2) (3 4)))) +(example (my-macro (keyword bar baz))) +(example (my-macro (keyword 3 4))) +(example (my-macro (foo bar baz))) diff --git a/examples/dot-dot-dot.golden b/examples/dot-dot-dot.golden new file mode 100644 index 00000000..e69de29b diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl new file mode 100644 index 00000000..6b127061 --- /dev/null +++ b/examples/dot-dot-dot.kl @@ -0,0 +1,1070 @@ +#lang "prelude.kl" +-- GENERATED BY ../bootstrap.rkt, DO NOT EDIT + +(import (rename "prelude.kl" + (syntax-case + raw-syntax-case))) + +(import (rename (shift "prelude.kl" 1) + (syntax-case + raw-syntax-case))) + +(import (shift "identifier.kl" 1)) + +(import (shift "list-syntax.kl" 1)) + +(import (shift "temporaries.kl" 1)) + +(define-macros + ((fancy-unquote + (lambda (stx) + (syntax-error + '"unquote used out of context" + stx))) + (fancy-... + (lambda (stx) + (syntax-error + '"... used out of context" + stx))) + (fancy-_ + (lambda (stx) + (syntax-error + '"_ used out of context" + stx))) + (fancy-syntax-case + (flet + (list-of-keywords? + (xs) + (let (stx-158 xs) + (let (failure-cc-159 + (lambda () + (syntax-error + '"syntax-case call has invalid syntax" + stx-158))) + (let (failure-cc-159 + (lambda () + (pure (false)))) + (let (failure-cc-159 + (lambda () + (raw-syntax-case + stx-158 + ((cons + head-160 + tail-161) + (let (x head-160) + (let (xs + tail-161) + (>>= + (pure + (identifier? + x)) + (lambda (guard-approves) + (if guard-approves + (list-of-keywords? + xs) + (failure-cc-159))))))) + (_ + (failure-cc-159))))) + (let (failure-cc-159 + (lambda () + (raw-syntax-case + stx-158 + (() (pure (true))) + (_ + (failure-cc-159))))) + (failure-cc-159))))))) + (lambda (stx) + (let (stx-198 stx) + (let (failure-cc-199 + (lambda () + (syntax-error + '"syntax-case call has invalid syntax" + stx-198))) + (let (failure-cc-199 + (lambda () + (raw-syntax-case + stx-198 + ((cons + head-200 + tail-201) + (raw-syntax-case + tail-201 + ((cons + head-202 + tail-203) + (let (stx-expr + head-202) + (raw-syntax-case + tail-203 + ((cons + head-204 + tail-205) + (let (keywords + head-204) + (let (cases + tail-205) + (let (stx-name + 'stx) + (>>= + (list-of-keywords? + keywords) + (lambda (keywords-are-keywords) + (if keywords-are-keywords + (flet + (is-identifier-in-list? + (identifier + xs) + (let (stx-162 + xs) + (let (failure-cc-163 + (lambda () + (syntax-error + '"syntax-case call has invalid syntax" + stx-162))) + (let (failure-cc-163 + (lambda () + (raw-syntax-case + stx-162 + ((cons + head-164 + tail-165) + (let (x + head-164) + (let (xs + tail-165) + (>>= + (free-identifier=? + identifier + x) + (lambda (same-identifier) + (if same-identifier + (pure + (true)) + (is-identifier-in-list? + identifier + xs))))))) + (_ + (failure-cc-163))))) + (let (failure-cc-163 + (lambda () + (raw-syntax-case + stx-162 + (() + (pure + (false))) + (_ + (failure-cc-163))))) + (failure-cc-163)))))) + (let (keyword? + (lambda (keyword) + (is-identifier-in-list? + keyword + keywords))) + (flet + (fancy-guard-rhs + (guard-rhs) + (let (stx-166 + guard-rhs) + (let (failure-cc-167 + (lambda () + (syntax-error + '"syntax-case call has invalid syntax" + stx-166))) + (let (failure-cc-167 + (lambda () + (raw-syntax-case + stx-166 + ((cons + head-172 + tail-173) + (let (rhs + head-172) + (raw-syntax-case + tail-173 + (() + (pure + rhs)) + (_ + (failure-cc-167))))) + (_ + (failure-cc-167))))) + (let (failure-cc-167 + (lambda () + (raw-syntax-case + stx-166 + ((cons + head-168 + tail-169) + (let (guard + head-168) + (raw-syntax-case + tail-169 + ((cons + head-170 + tail-171) + (let (rhs + head-170) + (raw-syntax-case + tail-171 + (() + (pure + (cons-list-syntax + '>>= + (cons-list-syntax + guard + (cons-list-syntax + (cons-list-syntax + 'lambda + (cons-list-syntax + (cons-list-syntax + 'guard-approves + '() + stx) + (cons-list-syntax + (cons-list-syntax + 'if + (cons-list-syntax + 'guard-approves + (cons-list-syntax + rhs + (cons-list-syntax + (cons-list-syntax + 'failure-cc + '() + stx) + '() + stx) + stx) + stx) + stx) + '() + stx) + stx) + stx) + '() + stx) + stx) + stx))) + (_ + (failure-cc-167))))) + (_ + (failure-cc-167))))) + (_ + (failure-cc-167))))) + (failure-cc-167)))))) + (flet + (fancy-case + (scrutinee-name + case) + (let (stx-190 + case) + (let (failure-cc-191 + (lambda () + (syntax-error + '"syntax-case call has invalid syntax" + stx-190))) + (let (failure-cc-191 + (lambda () + (raw-syntax-case + stx-190 + ((cons + head-192 + tail-193) + (let (pat + head-192) + (let (guard-rhs + tail-193) + (>>= + (fancy-guard-rhs + guard-rhs) + (lambda (rhs) + (let (stx-174 + pat) + (let (failure-cc-175 + (lambda () + (syntax-error + '"syntax-case call has invalid syntax" + stx-174))) + (let (failure-cc-175 + (lambda () + (pure + (cons-list-syntax + 'failure-cc + '() + stx)))) + (let (failure-cc-175 + (lambda () + (raw-syntax-case + stx-174 + ((cons + head-188 + tail-189) + (let (pat-head + head-188) + (let (pat-tail + tail-189) + (>>= + (make-temporary + 'tail) + (lambda (tail-name) + (>>= + (fancy-case + tail-name + (pair-list-syntax + pat-tail + rhs + stx)) + (lambda (rhs-tail) + (>>= + (make-temporary + 'head) + (lambda (head-name) + (>>= + (fancy-case + head-name + (pair-list-syntax + pat-head + rhs-tail + stx)) + (lambda (rhs-head) + (pure + (cons-list-syntax + 'raw-syntax-case + (cons-list-syntax + scrutinee-name + (cons-list-syntax + (cons-list-syntax + (cons-list-syntax + 'cons + (cons-list-syntax + head-name + (cons-list-syntax + tail-name + '() + stx) + stx) + stx) + (cons-list-syntax + rhs-head + '() + stx) + stx) + (cons-list-syntax + (cons-list-syntax + '_ + (cons-list-syntax + (cons-list-syntax + 'failure-cc + '() + stx) + '() + stx) + stx) + '() + stx) + stx) + stx) + stx))))))))))))) + (_ + (failure-cc-175))))) + (let (failure-cc-175 + (lambda () + (raw-syntax-case + stx-174 + ((cons + head-180 + tail-181) + (raw-syntax-case + head-180 + ((cons + head-184 + tail-185) + (if (identifier? + head-184) + (>>= + (free-identifier=? + head-184 + 'fancy-unquote) + (lambda (same-identifier) + (if same-identifier + (raw-syntax-case + tail-185 + ((cons + head-186 + tail-187) + (let (x + head-186) + (raw-syntax-case + tail-187 + (() + (raw-syntax-case + tail-181 + ((cons + head-182 + tail-183) + (if (identifier? + head-182) + (>>= + (free-identifier=? + head-182 + 'fancy-...) + (lambda (same-identifier) + (if same-identifier + (raw-syntax-case + tail-183 + (() + (if (identifier? + x) + (pure + (cons-list-syntax + 'let + (cons-list-syntax + (cons-list-syntax + x + (cons-list-syntax + scrutinee-name + '() + stx) + stx) + (cons-list-syntax + rhs + '() + stx) + stx) + stx)) + (syntax-error + (list-syntax + ('"syntax-case: the syntax for binding lists is (,x ...), found" + pat + '"instead") + stx) + stx))) + (_ + (failure-cc-175))) + (failure-cc-175)))) + (failure-cc-175))) + (_ + (failure-cc-175)))) + (_ + (failure-cc-175))))) + (_ + (failure-cc-175))) + (failure-cc-175)))) + (failure-cc-175))) + (_ + (failure-cc-175)))) + (_ + (failure-cc-175))))) + (let (failure-cc-175 + (lambda () + (raw-syntax-case + stx-174 + ((cons + head-176 + tail-177) + (if (identifier? + head-176) + (>>= + (free-identifier=? + head-176 + 'fancy-unquote) + (lambda (same-identifier) + (if same-identifier + (raw-syntax-case + tail-177 + ((cons + head-178 + tail-179) + (let (x + head-178) + (raw-syntax-case + tail-179 + (() + (if (identifier? + x) + (pure + (cons-list-syntax + 'let + (cons-list-syntax + (cons-list-syntax + x + (cons-list-syntax + scrutinee-name + '() + stx) + stx) + (cons-list-syntax + rhs + '() + stx) + stx) + stx)) + (syntax-error + (list-syntax + ('"syntax-case: the syntax for binding values is (unquote x), found" + pat + '"instead") + stx) + stx))) + (_ + (failure-cc-175))))) + (_ + (failure-cc-175))) + (failure-cc-175)))) + (failure-cc-175))) + (_ + (failure-cc-175))))) + (let (failure-cc-175 + (lambda () + (let (keyword + stx-174) + (>>= + (pure + (identifier? + keyword)) + (lambda (guard-approves) + (if guard-approves + (>>= + (keyword? + keyword) + (lambda (is-keyword) + (if is-keyword + (pure + (cons-list-syntax + 'if + (cons-list-syntax + (cons-list-syntax + 'identifier? + (cons-list-syntax + scrutinee-name + '() + stx) + stx) + (cons-list-syntax + (cons-list-syntax + '>>= + (cons-list-syntax + (cons-list-syntax + 'free-identifier=? + (cons-list-syntax + scrutinee-name + (cons-list-syntax + (cons-list-syntax + 'quote + (cons-list-syntax + keyword + '() + stx) + stx) + '() + stx) + stx) + stx) + (cons-list-syntax + (cons-list-syntax + 'lambda + (cons-list-syntax + (cons-list-syntax + 'same-identifier + '() + stx) + (cons-list-syntax + (cons-list-syntax + 'if + (cons-list-syntax + 'same-identifier + (cons-list-syntax + rhs + (cons-list-syntax + (cons-list-syntax + 'failure-cc + '() + stx) + '() + stx) + stx) + stx) + stx) + '() + stx) + stx) + stx) + '() + stx) + stx) + stx) + (cons-list-syntax + (cons-list-syntax + 'failure-cc + '() + stx) + '() + stx) + stx) + stx) + stx)) + (syntax-error + (list-syntax + ('"syntax-case: naked symbol" + keyword + '"did you mean (unquote symbol)?" + '"did you mean to add the symbol to the keyword list?") + stx) + stx)))) + (failure-cc-175))))))) + (let (failure-cc-175 + (lambda () + (if (identifier? + stx-174) + (>>= + (free-identifier=? + stx-174 + 'fancy-_) + (lambda (same-identifier) + (if same-identifier + (pure + rhs) + (failure-cc-175)))) + (failure-cc-175)))) + (let (failure-cc-175 + (lambda () + (raw-syntax-case + stx-174 + (() + (pure + (cons-list-syntax + 'raw-syntax-case + (cons-list-syntax + scrutinee-name + (cons-list-syntax + (cons-list-syntax + '() + (cons-list-syntax + rhs + '() + stx) + stx) + (cons-list-syntax + (cons-list-syntax + '_ + (cons-list-syntax + (cons-list-syntax + 'failure-cc + '() + stx) + '() + stx) + stx) + '() + stx) + stx) + stx) + stx))) + (_ + (failure-cc-175))))) + (failure-cc-175))))))))))))))) + (_ + (failure-cc-191))))) + (failure-cc-191))))) + (flet + (fancy-cases + (cases + inner-cases) + (let (stx-194 + cases) + (let (failure-cc-195 + (lambda () + (syntax-error + '"syntax-case call has invalid syntax" + stx-194))) + (let (failure-cc-195 + (lambda () + (raw-syntax-case + stx-194 + ((cons + head-196 + tail-197) + (let (case + head-196) + (let (cases + tail-197) + (>>= + (fancy-case + stx-name + case) + (lambda (inner-case) + (fancy-cases + cases + (cons-list-syntax + 'let + (cons-list-syntax + (cons-list-syntax + 'failure-cc + (cons-list-syntax + (cons-list-syntax + 'lambda + (cons-list-syntax + '() + (cons-list-syntax + inner-case + '() + stx) + stx) + stx) + '() + stx) + stx) + (cons-list-syntax + inner-cases + '() + stx) + stx) + stx))))))) + (_ + (failure-cc-195))))) + (let (failure-cc-195 + (lambda () + (raw-syntax-case + stx-194 + (() + (pure + inner-cases)) + (_ + (failure-cc-195))))) + (failure-cc-195)))))) + (>>= + (fancy-cases + cases + (cons-list-syntax + 'failure-cc + '() + stx)) + (lambda (outer-cases) + (pure + (cons-list-syntax + 'let + (cons-list-syntax + (cons-list-syntax + stx-name + (cons-list-syntax + stx-expr + '() + stx) + stx) + (cons-list-syntax + (cons-list-syntax + 'let + (cons-list-syntax + (cons-list-syntax + 'failure-cc + (cons-list-syntax + (cons-list-syntax + 'lambda + (cons-list-syntax + '() + (cons-list-syntax + (cons-list-syntax + 'syntax-error + (cons-list-syntax + (cons-list-syntax + 'list-syntax + (cons-list-syntax + (cons-list-syntax + (cons-list-syntax + 'quote + (cons-list-syntax + '"syntax-case: the input" + '() + stx) + stx) + (cons-list-syntax + stx-name + (cons-list-syntax + (cons-list-syntax + 'quote + (cons-list-syntax + '"does not match any of the following patterns" + '() + stx) + stx) + (cons-list-syntax + (cons-list-syntax + 'quote + (cons-list-syntax + (map + car + cases) + '() + stx) + stx) + '() + stx) + stx) + stx) + stx) + (cons-list-syntax + 'stx + '() + stx) + stx) + stx) + (cons-list-syntax + 'stx + '() + stx) + stx) + stx) + '() + stx) + stx) + stx) + '() + stx) + stx) + (cons-list-syntax + outer-cases + '() + stx) + stx) + stx) + '() + stx) + stx) + stx))))))))) + (syntax-error + (list-syntax + ('"syntax-case:" + keywords + '"does not look like a list of keywords." + '"did you forget a () between the input and the cases?") + stx))))))))) + (_ + (failure-cc-199))))) + (_ + (failure-cc-199)))) + (_ + (failure-cc-199))))) + (failure-cc-199))))))) + (fancy-quasiquote + (lambda (stx) + (let (stx-222 stx) + (let (failure-cc-223 + (lambda () + (syntax-error + '"fancy-quasiquote call has invalid syntax" + stx-222))) + (let (failure-cc-223 + (lambda () + (raw-syntax-case + stx-222 + ((cons + head-224 + tail-225) + (raw-syntax-case + tail-225 + ((cons + head-226 + tail-227) + (let (pat head-226) + (raw-syntax-case + tail-227 + (() + (let (stx-name + (cons-list-syntax + 'quote + (cons-list-syntax + (replace-loc + pat + 'here) + '() + 'here) + 'here)) + (flet + (fancy-inside + (pat) + (let (stx-206 + pat) + (let (failure-cc-207 + (lambda () + (syntax-error + '"fancy-quasiquote call has invalid syntax" + stx-206))) + (let (failure-cc-207 + (lambda () + (let (x + stx-206) + (pure + (pair-list-syntax + 'quote + x + stx))))) + (let (failure-cc-207 + (lambda () + (raw-syntax-case + stx-206 + ((cons + head-220 + tail-221) + (let (head + head-220) + (let (tail + tail-221) + (>>= + (fancy-inside + head) + (lambda (inside-head) + (>>= + (fancy-inside + tail) + (lambda (inside-tail) + (pure + (cons-list-syntax + 'cons-list-syntax + (cons-list-syntax + inside-head + (cons-list-syntax + inside-tail + (cons-list-syntax + stx-name + '() + stx) + stx) + stx) + stx))))))))) + (_ + (failure-cc-207))))) + (let (failure-cc-207 + (lambda () + (raw-syntax-case + stx-206 + ((cons + head-212 + tail-213) + (raw-syntax-case + head-212 + ((cons + head-216 + tail-217) + (if (identifier? + head-216) + (>>= + (free-identifier=? + head-216 + 'fancy-unquote) + (lambda (same-identifier) + (if same-identifier + (raw-syntax-case + tail-217 + ((cons + head-218 + tail-219) + (let (head + head-218) + (raw-syntax-case + tail-219 + (() + (raw-syntax-case + tail-213 + ((cons + head-214 + tail-215) + (if (identifier? + head-214) + (>>= + (free-identifier=? + head-214 + 'fancy-...) + (lambda (same-identifier) + (if same-identifier + (let (tail + tail-215) + (>>= + (fancy-inside + tail) + (lambda (inside-tail) + (pure + (cons-list-syntax + 'append-list-syntax + (cons-list-syntax + head + (cons-list-syntax + inside-tail + (cons-list-syntax + stx-name + '() + stx) + stx) + stx) + stx))))) + (failure-cc-207)))) + (failure-cc-207))) + (_ + (failure-cc-207)))) + (_ + (failure-cc-207))))) + (_ + (failure-cc-207))) + (failure-cc-207)))) + (failure-cc-207))) + (_ + (failure-cc-207)))) + (_ + (failure-cc-207))))) + (let (failure-cc-207 + (lambda () + (raw-syntax-case + stx-206 + ((cons + head-208 + tail-209) + (if (identifier? + head-208) + (>>= + (free-identifier=? + head-208 + 'fancy-unquote) + (lambda (same-identifier) + (if same-identifier + (raw-syntax-case + tail-209 + ((cons + head-210 + tail-211) + (let (x + head-210) + (raw-syntax-case + tail-211 + (() + (pure + x)) + (_ + (failure-cc-207))))) + (_ + (failure-cc-207))) + (failure-cc-207)))) + (failure-cc-207))) + (_ + (failure-cc-207))))) + (failure-cc-207)))))))) + (fancy-inside + pat)))) + (_ + (failure-cc-223))))) + (_ + (failure-cc-223)))) + (_ + (failure-cc-223))))) + (failure-cc-223)))))))) + +(export (rename ((fancy-syntax-case + syntax-case) + (fancy-quasiquote + quasiquote) + (fancy-unquote unquote) + (fancy-... ...) + (fancy-_ _)) + fancy-syntax-case + fancy-quasiquote + fancy-unquote + fancy-... + fancy-_)) diff --git a/examples/free-identifier-case.kl b/examples/free-identifier-case.kl index 07a8a750..6c118ed6 100644 --- a/examples/free-identifier-case.kl +++ b/examples/free-identifier-case.kl @@ -2,48 +2,31 @@ (import "let.kl") (import (shift "prelude.kl" 1)) -(import (shift "quasiquote.kl" 1)) - -(meta - (define identifier? - (lambda (x) - (syntax-case x - [(ident x) (true)] - [_ (false)])))) +(import (shift "identifier.kl" 1)) +(import (shift "dot-dot-dot.kl" 1)) (define-macros ([free-identifier-case (lambda (stx) - (syntax-case stx - [(cons _ body) - (syntax-case body - [(cons scrut cases) - (pure - (quasiquote/loc stx - (let (x ,scrut) (free-identifier-case-aux x ,cases))))])]))] + (syntax-case stx () + [(_ ,scrut ,cases ...) + (pure (replace-loc stx + `(let (x ,scrut) (free-identifier-case-aux x ,cases ...))))]))] [free-identifier-case-aux (lambda (stx) - (syntax-case stx - [(list (_ scrut cases)) - (syntax-case cases - [() (pure '(syntax-error '"Nothing matched"))] - [(cons c cs) - (syntax-case c - [(list (test val)) - (syntax-case test - [(list (e x)) - (>>= (free-identifier=? e 'else) - (lambda (eq) - (if eq - (pure (quasiquote/loc c (let (,x ,scrut) ,val))) - (syntax-error test))))] - [(ident id) - (pure - (quasiquote/loc c - (>>= (free-identifier=? ,scrut ',id) - (lambda (eq) - (if eq - ,val - (free-identifier-case-aux ,scrut ,cs))))))])])])]))])) + (syntax-case stx (else) + [(_ ,scrut) + (pure '(syntax-error '"Nothing matched"))] + [(_ ,scrut ((else ,x) ,val)) + (pure (replace-loc x + `(let [,x ,scrut] ,val)))] + [(_ ,scrut (,id ,val) ,cs ...) + (pure (identifier? id)) + (pure (replace-loc val + `(>>= (free-identifier=? ,scrut ',id) + (lambda (eq) + (if eq + ,val + (free-identifier-case-aux ,scrut ,cs ...))))))]))])) (export free-identifier-case) diff --git a/examples/identifier.golden b/examples/identifier.golden new file mode 100644 index 00000000..e69de29b diff --git a/examples/identifier.kl b/examples/identifier.kl new file mode 100644 index 00000000..58bf9af5 --- /dev/null +++ b/examples/identifier.kl @@ -0,0 +1,9 @@ +#lang "prelude.kl" + +(define identifier? + (lambda (x) + (syntax-case x + [(ident x) (true)] + [_ (false)]))) + +(export identifier?) diff --git a/examples/list-syntax.golden b/examples/list-syntax.golden index e2c0b68d..e65081f3 100644 --- a/examples/list-syntax.golden +++ b/examples/list-syntax.golden @@ -1,5 +1,7 @@ -#[list-syntax.kl:70.17-70.18]<1> : Syntax -#[list-syntax.kl:71.16-71.23]<(2 3)> : Syntax -#[list-syntax.kl:72.20-72.39]<(x y z)> : Syntax -#[list-syntax.kl:77.18-78.17]<((f x) (f y) (f z))> : Syntax -#[list-syntax.kl:81.18-82.17]<(z y x)> : Syntax +#[list-syntax.kl:86.35-86.38]<(1 2)> : Syntax +#[list-syntax.kl:90.13-90.16]<(1 2 3 4 5 6)> : Syntax +#[list-syntax.kl:91.17-91.18]<1> : Syntax +#[list-syntax.kl:92.16-92.23]<(2 3)> : Syntax +#[list-syntax.kl:93.20-93.39]<(x y z)> : Syntax +#[list-syntax.kl:98.18-99.17]<((f x) (f y) (f z))> : Syntax +#[list-syntax.kl:102.18-103.17]<(z y x)> : Syntax diff --git a/examples/list-syntax.kl b/examples/list-syntax.kl index 5404a337..419e6e3b 100644 --- a/examples/list-syntax.kl +++ b/examples/list-syntax.kl @@ -3,6 +3,22 @@ (import "defun.kl") +(defun pair-list-syntax (head tail stx) + (cons-list-syntax head + (cons-list-syntax tail + '() + stx) + stx)) + +(defun append-list-syntax (list tail stx) + (syntax-case list + [() + tail] + [(cons car cdr) + (cons-list-syntax car + (append-list-syntax cdr tail stx) + stx)])) + (define car (lambda (stx) (syntax-case stx @@ -67,6 +83,11 @@ (lambda (a2) (foldlM f a2 as)))))) +(example (pair-list-syntax '1 '2 'stx)) +(example (append-list-syntax + '(1 2 3) + '(4 5 6) + 'stx)) (example (car '(1 2 3))) (example (cdr '(1 2 3))) (example (map car '((x 1) (y 2) (z 3)))) @@ -84,4 +105,4 @@ -- foldrM and foldlM can't be tested here because we'd need to define a macro -- but foldrM and foldlM are only available at phase 0. -(export car cdr map foldr foldl foldrM foldlM) +(export pair-list-syntax append-list-syntax car cdr map foldr foldl foldrM foldlM) diff --git a/examples/mcond.kl b/examples/mcond.kl index f854ce5d..a718a2f7 100644 --- a/examples/mcond.kl +++ b/examples/mcond.kl @@ -1,23 +1,20 @@ #lang "prelude.kl" (import (shift "prelude.kl" 1)) -(import (shift "quasiquote.kl" 1)) +(import (shift "dot-dot-dot.kl" 1)) (define-macros ([mcond (lambda (stx) - (syntax-case stx - [(cons mc cases) - (syntax-case cases - [() - (pure `(syntax-error ,(replace-loc mc ''"No more cases")))] - [(cons c cs) - (syntax-case c - [(list (condition result)) - (pure - (quasiquote/loc c - (>>= ,condition - (lambda (x) - (if x ,result ,(cons-list-syntax mc cs stx))))))])])]))])) + (syntax-case stx () + [(,mc) + (pure `(syntax-error ,(replace-loc mc ''"No more cases")))] + [(,mc (,condition ,result) ,cs ...) + (pure (replace-loc condition + `(>>= ,condition + (lambda (x) + (if x + ,result + (,mc ,cs ...))))))]))])) (export mcond) diff --git a/examples/pmatch.golden b/examples/pmatch.golden index 1f7724dc..e3b7f6cb 100644 --- a/examples/pmatch.golden +++ b/examples/pmatch.golden @@ -1,12 +1,12 @@ -#[pmatch.kl:103.32-103.33] : Syntax -#[pmatch.kl:104.36-104.37] : Syntax -#[pmatch.kl:105.29-105.30] : Syntax -#[pmatch.kl:106.48-106.49] : Syntax +#[pmatch.kl:83.32-83.33] : Syntax +#[pmatch.kl:84.36-84.37] : Syntax +#[pmatch.kl:85.29-85.30] : Syntax +#[pmatch.kl:86.48-86.49] : Syntax (zero) : Nat (zero) : Nat (zero) : Nat (zero) : Nat (add1 (zero)) : Nat -(:: (pair #[pmatch.kl:131.34-131.35]<1> 1) - (:: (pair #[pmatch.kl:131.50-131.51]<2> 2) - (:: (pair #[pmatch.kl:131.66-131.67]<3> 3) (nil)))) : (List (Pair Syntax Integer)) +(:: (pair #[pmatch.kl:111.34-111.35]<1> 1) + (:: (pair #[pmatch.kl:111.50-111.51]<2> 2) + (:: (pair #[pmatch.kl:111.66-111.67]<3> 3) (nil)))) : (List (Pair Syntax Integer)) diff --git a/examples/pmatch.kl b/examples/pmatch.kl index d79584a1..631d1270 100644 --- a/examples/pmatch.kl +++ b/examples/pmatch.kl @@ -5,7 +5,8 @@ (import (shift "prelude.kl" 1)) -(import (shift "quasiquote.kl" 1)) +(import (shift "identifier.kl" 1)) +(import (shift "dot-dot-dot.kl" 1)) (import (shift "defun.kl" 1)) (import (shift "lispy-do.kl" 1)) (import (shift "free-identifier-case.kl" 1)) @@ -13,11 +14,6 @@ (import (shift "pair-datatype.kl" 1)) (import (shift "list-datatype.kl" 1)) -(meta - (define identifier? - (lambda (stx) - (syntax-case stx [(ident x) (true)] [_ (false)])))) - (meta (datatype (Maybe A) (nothing) @@ -25,25 +21,13 @@ (meta (defun syntax->list (stx) - (syntax-case stx - [() (nil)] - [(cons x xs) (:: x (syntax->list xs))]))) - -(meta - (define else-case - (lambda (stx) - (syntax-case stx - [(list (e x)) - (if (identifier? e) - (free-identifier-case e - [else (pure (just x))] - [(else other) (pure (nothing))]) - (pure (nothing)))] - [(ident e) - (free-identifier-case e - [else (pure (just 'else-x))] - [(else other) (pure (nothing))])] - [_ (pure (nothing))])))) + (syntax-case stx () + [() + (pure (nil))] + [(,x ,xs ...) + (>>= (syntax->list xs) + (lambda (list) + (pure (:: x list))))]))) (meta (defun list->syntax (stx-lst stx) @@ -54,47 +38,43 @@ (define-macros ([pmatch (lambda (stx) - (syntax-case stx - [(cons _ more) - (syntax-case more - [(cons scrut pats) - (pure `(let (x ,scrut) (pmatch-aux ,scrut x ,pats)))])]))] + (syntax-case stx () + [(_ ,scrut ,pats ...) + (pure `(let [x ,scrut] (pmatch-aux ,scrut x ,pats ...)))]))] [pmatch-aux (lambda (stx) - (syntax-case stx - [(list (_ scrut tgt pats)) - (syntax-case pats - [() (pure `(error ',scrut))] - [(cons c cs) - (syntax-case c - [(list (pat rhs)) - (>>= (else-case pat) - (lambda (e) - (case e - [(just x) (pure `(let (,x ,tgt) ,rhs))] - [(nothing) - (pure `(let (kf (lambda (_) (pmatch-aux ,scrut ,tgt ,cs))) - (ppat ,tgt ,pat ,rhs (kf 'hi))))])))])])]))] + (syntax-case stx (else) + [(_ ,scrut ,tgt) + (pure `(error ',scrut))] + [(_ ,scrut ,tgt (else ,rhs) ,cs ...) + (pure rhs)] + [(_ ,scrut ,tgt ((else ,x) ,rhs) ,cs ...) + (pure `(let [,x ,tgt] + ,rhs))] + [(_ ,scrut ,tgt (,pat ,rhs) ,cs ...) + (pure `(let (kf (lambda (_) (pmatch-aux ,scrut ,tgt ,cs ...))) + (ppat ,tgt ,pat ,rhs (kf 'hi))))]))] [ppat (lambda (stx) - (syntax-case stx - [(list (_ tgt pat ks kf)) - (syntax-case pat - [(ident x) - (pure `(let (,x ,tgt) ,ks))] - [(cons what args) - (>>= (make-temporaries (syntax->list args)) - (lambda (temps) - (let (temp-names (map fst temps)) - (flet (combine (stxs) - (case stxs - [(nil) ks] - [(:: id-and-stx rest) - `(ppat ,(fst id-and-stx) ,(snd id-and-stx) ,(combine rest) ,kf)])) - (pure `(case ,tgt - [,(cons-list-syntax what (list->syntax temp-names pat) pat) - ,(combine temps)] - [(else other) ,kf]))))))])]))])) + (syntax-case stx () + [(_ ,tgt ,x ,ks ,kf) + (pure (identifier? x)) + (pure `(let [,x ,tgt] ,ks))] + [(_ ,tgt (,what ,args ...) ,ks ,kf) + (>>= (syntax->list args) + (lambda (arg-list) + (>>= (make-temporaries arg-list) + (lambda (temps) + (let (temp-names (map fst temps)) + (flet (combine (stxs) + (case stxs + [(nil) ks] + [(:: id-and-stx rest) + `(ppat ,(fst id-and-stx) ,(snd id-and-stx) ,(combine rest) ,kf)])) + (pure `(case ,tgt + [,(cons-list-syntax what (list->syntax temp-names args) args) + ,(combine temps)] + [(else other) ,kf]))))))))]))])) diff --git a/examples/which-problem.kl b/examples/which-problem.kl index 4733a937..68ed1bf9 100644 --- a/examples/which-problem.kl +++ b/examples/which-problem.kl @@ -1,8 +1,8 @@ #lang "prelude.kl" (import (shift "prelude.kl" 1)) -(import (shift "quasiquote.kl" 1)) -(import "quasiquote.kl") +(import (shift "dot-dot-dot.kl" 1)) +(import "dot-dot-dot.kl") (import "define-syntax-rule.kl") @@ -37,12 +37,10 @@ (define-macros ([llet (lambda (stx) - (syntax-case stx - [(list (_ binding body)) - (syntax-case binding - [(list (name def)) - (pure (quasiquote/loc stx - ((lambda (,name) ,body) ,def)))])]))])) + (syntax-case stx () + [(_ (,name ,def) ,body) + (pure (replace-loc stx + `((lambda (,name) ,body) ,def)))]))])) (example (llet (x (mega-const unit)) (the (-> Bool Bool Bool Bool Unit) x)))