From 348ce887e0d9731b63cdc5c8f1bedda2629b4eb3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Thu, 8 Oct 2020 23:58:32 -0400 Subject: [PATCH 01/35] use racket to bootstrap dot-dot-dot.kl --- bootstrap.rkt | 195 ++++++++++++++++++++++++++++++++++++++++ examples/dot-dot-dot.kl | 10 +++ 2 files changed, 205 insertions(+) create mode 100644 bootstrap.rkt create mode 100644 examples/dot-dot-dot.kl diff --git a/bootstrap.rkt b/bootstrap.rkt new file mode 100644 index 00000000..13fc2ac7 --- /dev/null +++ b/bootstrap.rkt @@ -0,0 +1,195 @@ +#lang racket + +(require (rename-in racket [define-syntax racket-define-syntax] + [syntax-case racket-syntax-case] + [... racket-...])) + +; 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 macro-defining macros like racket-syntax-case. +; +; But it's also a bit mind-bending because there are many different versions of +; syntax-case defined in terms of each other: +; * In the generated Klister code, fancy-syntax-case is defined using +; raw-syntax-case and expands to code which uses raw-syntax-case. +; * In this file, we generate that Klister code using +; intermediate-define-syntax2, because it's a lot more convenient to use than +; raw-syntax-case. +; * intermediate-define-syntax{1,2} are defined using racket-syntax-case, and +; expand to Klister code which uses raw-syntax-case. + +; (intermediate-define-syntax1 my-macro (foo bar) +; (lambda (raw-stx) +; (pure raw-stx))) +; => +; (raw-define-macros +; ([foo +; (lambda (raw-stx) +; (syntax-error '"foo used out of context" raw-stx))] +; [bar +; (lambda (raw-stx) +; (syntax-error '"bar used out of context" raw-stx))] +; [my-macro +; (lambda (raw-stx) +; (pure raw-stx))])) +(racket-define-syntax (intermediate-define-syntax1 intermediate-stx) + (racket-syntax-case intermediate-stx () + [(_ macro-name (literal-id racket-...) impl) + (let* ([error-message + (lambda (symbol) + (string-append (symbol->string symbol) + " used out of context"))] + [undefined-macro + (lambda (symbol) + #`[#,symbol + (lambda (raw-stx) + (syntax-error '#,(error-message symbol) raw-stx))])] + [symbols + (syntax->datum #'(literal-id racket-...))] + [undefined-macros + (map undefined-macro symbols)]) + #`'(raw-define-macros + (#,@undefined-macros + [macro-name impl])))])) + +; (intermediate-define-syntax2 my-macro (keyword) +; [() +; rhs1] +; [((a b) (c d)) +; rhs2] +; [(keyword tail intermediate-...) +; rhs3]) +; => +; (intermediate-define-syntax1 my-macro (keyword) +; (lambda (raw-stx) +; (let [failure-cc +; (lambda () +; (raw-syntax-case raw-stx))] +; (let [failure-cc +; (lambda () +; (raw-syntax-case raw-stx +; [(cons head tail) +; (>>= (free-identifier=? head 'keyword) +; (lambda (same-identifier) +; (if same-identifier +; rhs3 +; (failure-cc))))] +; [_ (failure-cc)]))] +; (let [failure-cc +; (lambda () +; (raw-syntax-case raw-stx +; [(cons ab cd-nil) +; (raw-syntax-case ab +; [(cons a b-nil) +; (... rhs2)] +; [_ (failure-cc)])] +; [_ (failure-cc)]))] +; (let [failure-cc +; (lambda () +; (raw-syntax-case raw-stx +; [() rhs1] +; [_ (failure-cc)]))] +; (failure-cc))))))) +(racket-define-syntax (intermediate-define-syntax2 intermediate-stx) + (racket-syntax-case intermediate-stx () + [(_ macro-name (intermediate-literal-id racket-...) + cases racket-...) + (letrec ([symbols + (syntax->datum #'(intermediate-literal-id racket-...))] + [intermediate-expand-case + (lambda (scrutinee-name intermediate-case-stx) + (racket-syntax-case intermediate-case-stx (intermediate-...) + [[() rhs] + #`(raw-syntax-case #,scrutinee-name + [() rhs] + [_ (failure-cc)])] + [[x rhs] + (and (identifier? #'x) + (member (syntax->datum #'x) symbols)) + #`(>>= (free-identifier=? #,scrutinee-name 'x) + (lambda (same-identifier) + (if same-identifier rhs (failure-cc))))] + [[x rhs] + (identifier? #'x) + #`(let [x #,scrutinee-name] + rhs)] + [[(x intermediate-...) rhs] + #`(let [x #,scrutinee-name] + rhs)] + [[(intermediate-head intermediate-tail racket-...) rhs] + (let ([head-name (gensym 'head-)] + [tail-name (gensym 'tail-)]) + #`(raw-syntax-case #,scrutinee-name + [(cons #,head-name #,tail-name) + #,(intermediate-expand-case head-name + #`[intermediate-head + #,(intermediate-expand-case tail-name + #`[(intermediate-tail racket-...) rhs])])] + [_ (failure-cc)]))]))] + [intermediate-expand-cases + (lambda (intermediate-cases-stx) + (racket-syntax-case intermediate-cases-stx (intermediate-...) + [() + #`(failure-cc)] + [(cases racket-... case) + #`(let [failure-cc + (lambda () + #,(intermediate-expand-case 'raw-stx #'case))] + #,(intermediate-expand-cases #'(cases racket-...)))]))]) + #`(intermediate-define-syntax1 macro-name (intermediate-literal-id racket-...) + (lambda (raw-stx) + (let [failure-cc + (lambda () (raw-syntax-case raw-stx))] + #,(intermediate-expand-cases #'(cases racket-...))))))])) + + +(void + (display-lines-to-file + (list + "#lang \"prelude.kl\"" + "-- GENERATED BY ../bootstrap.rkt, DO NOT EDIT") + "examples/dot-dot-dot.kl" + #:exists 'truncate) + + (map + (lambda (form) + (display-to-file + "\n" + "examples/dot-dot-dot.kl" + #:exists 'append) + (write-to-file + form + "examples/dot-dot-dot.kl" + #:exists 'append) + (display-to-file + "\n" + "examples/dot-dot-dot.kl" + #:exists 'append)) + (list + '(import (rename "prelude.kl" + [define-macros raw-define-macros])) + '(import (rename (shift "prelude.kl" 1) + [syntax-case raw-syntax-case])) + + (intermediate-define-syntax2 my-macro (keyword) + [(anything intermediate-...) + (pure ''nil)]) + ;[(_ ((a b) (c d))) + ; (pure (cons-list-syntax a + ; (cons-list-syntax b + ; (cons-list-syntax c + ; (cons-list-syntax d + ; '() + ; raw-stx) + ; raw-stx) + ; raw-stx) + ; raw-stx))] + ;[(_ (foo tail intermediate-...)) + ; (pure (cons-list-syntax 'quote tail raw-stx))]) + + '(example (my-macro))))) diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl new file mode 100644 index 00000000..5f0d3787 --- /dev/null +++ b/examples/dot-dot-dot.kl @@ -0,0 +1,10 @@ +#lang "prelude.kl" +-- GENERATED BY ../bootstrap.rkt, DO NOT EDIT + +(import (rename "prelude.kl" (define-macros raw-define-macros))) + +(import (rename (shift "prelude.kl" 1) (syntax-case raw-syntax-case))) + +(raw-define-macros ((keyword (lambda (raw-stx) (syntax-error (quote "keyword used out of context") raw-stx))) (my-macro (lambda (raw-stx) (let (failure-cc (lambda () (raw-syntax-case raw-stx))) (let (failure-cc (lambda () (let (anything raw-stx) (pure (quote (quote nil)))))) (failure-cc))))))) + +(example (my-macro)) From 6b2470d1cc5c6ba29f72d5399f44ef3493d24381 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Fri, 9 Oct 2020 00:26:20 -0400 Subject: [PATCH 02/35] pretty-print generated code --- bootstrap.rkt | 86 +++++++++++++++++++++-------------------- examples/dot-dot-dot.kl | 25 ++++++++++-- 2 files changed, 66 insertions(+), 45 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 13fc2ac7..62ed9049 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -3,6 +3,7 @@ (require (rename-in racket [define-syntax racket-define-syntax] [syntax-case racket-syntax-case] [... racket-...])) +(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 @@ -149,47 +150,48 @@ (void - (display-lines-to-file - (list - "#lang \"prelude.kl\"" - "-- GENERATED BY ../bootstrap.rkt, DO NOT EDIT") + (call-with-output-file "examples/dot-dot-dot.kl" - #:exists 'truncate) + #: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) - (display-to-file - "\n" - "examples/dot-dot-dot.kl" - #:exists 'append) - (write-to-file - form - "examples/dot-dot-dot.kl" - #:exists 'append) - (display-to-file - "\n" - "examples/dot-dot-dot.kl" - #:exists 'append)) - (list - '(import (rename "prelude.kl" - [define-macros raw-define-macros])) - '(import (rename (shift "prelude.kl" 1) - [syntax-case raw-syntax-case])) - - (intermediate-define-syntax2 my-macro (keyword) - [(anything intermediate-...) - (pure ''nil)]) - ;[(_ ((a b) (c d))) - ; (pure (cons-list-syntax a - ; (cons-list-syntax b - ; (cons-list-syntax c - ; (cons-list-syntax d - ; '() - ; raw-stx) - ; raw-stx) - ; raw-stx) - ; raw-stx))] - ;[(_ (foo tail intermediate-...)) - ; (pure (cons-list-syntax 'quote tail raw-stx))]) - - '(example (my-macro))))) + (map + (lambda (form) + (newline) + (writeln form)) + (list + '(import (rename "prelude.kl" + [define-macros raw-define-macros])) + '(import (rename (shift "prelude.kl" 1) + [syntax-case raw-syntax-case])) + + (intermediate-define-syntax2 my-macro (keyword) + [(anything intermediate-...) + (pure ''nil)]) + ;[(_ ((a b) (c d))) + ; (pure (cons-list-syntax a + ; (cons-list-syntax b + ; (cons-list-syntax c + ; (cons-list-syntax d + ; '() + ; raw-stx) + ; raw-stx) + ; raw-stx) + ; raw-stx))] + ;[(_ (foo tail intermediate-...)) + ; (pure (cons-list-syntax 'quote tail raw-stx))]) + + '(example (my-macro))))))))) diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index 5f0d3787..afd1a7b0 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -1,10 +1,29 @@ #lang "prelude.kl" -- GENERATED BY ../bootstrap.rkt, DO NOT EDIT -(import (rename "prelude.kl" (define-macros raw-define-macros))) +(import (rename "prelude.kl" + (define-macros + raw-define-macros))) -(import (rename (shift "prelude.kl" 1) (syntax-case raw-syntax-case))) +(import (rename (shift "prelude.kl" 1) + (syntax-case + raw-syntax-case))) -(raw-define-macros ((keyword (lambda (raw-stx) (syntax-error (quote "keyword used out of context") raw-stx))) (my-macro (lambda (raw-stx) (let (failure-cc (lambda () (raw-syntax-case raw-stx))) (let (failure-cc (lambda () (let (anything raw-stx) (pure (quote (quote nil)))))) (failure-cc))))))) +(raw-define-macros + ((keyword + (lambda (raw-stx) + (syntax-error + '"keyword used out of context" + raw-stx))) + (my-macro + (lambda (raw-stx) + (let (failure-cc + (lambda () + (raw-syntax-case raw-stx))) + (let (failure-cc + (lambda () + (let (anything raw-stx) + (pure ''nil)))) + (failure-cc))))))) (example (my-macro)) From f6fc855a327954aaeee0f60abfb764810db579bf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sat, 10 Oct 2020 11:25:08 -0400 Subject: [PATCH 03/35] generate error message if no case matches Turns out (raw-syntax-case stx), with zero cases to match on, does not fail at runtime with an error message complaining that stx doesn't match any of its (zero) cases, but instead fails at compile time because that's invalid syntax for raw-syntax-case. --- bootstrap.rkt | 9 +++++++-- examples/dot-dot-dot.kl | 4 +++- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 62ed9049..f1887129 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -70,7 +70,7 @@ ; (lambda (raw-stx) ; (let [failure-cc ; (lambda () -; (raw-syntax-case raw-stx))] +; (syntax-error '"my-macro call has invalid syntax" raw-stx))] ; (let [failure-cc ; (lambda () ; (raw-syntax-case raw-stx @@ -145,7 +145,12 @@ #`(intermediate-define-syntax1 macro-name (intermediate-literal-id racket-...) (lambda (raw-stx) (let [failure-cc - (lambda () (raw-syntax-case raw-stx))] + (lambda () + (syntax-error + '#,(string-append + (symbol->string (syntax->datum #'macro-name)) + " call has invalid syntax") + raw-stx))] #,(intermediate-expand-cases #'(cases racket-...))))))])) diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index afd1a7b0..9f566111 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -19,7 +19,9 @@ (lambda (raw-stx) (let (failure-cc (lambda () - (raw-syntax-case raw-stx))) + (syntax-error + '"my-macro call has invalid syntax" + raw-stx))) (let (failure-cc (lambda () (let (anything raw-stx) From c9e0cb8f1acd9f86a045566a22f83cff85d3976f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sat, 10 Oct 2020 11:34:24 -0400 Subject: [PATCH 04/35] longer test --- bootstrap.rkt | 39 ++++++---- examples/dot-dot-dot.kl | 154 ++++++++++++++++++++++++++++++++++++++-- 2 files changed, 174 insertions(+), 19 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index f1887129..312d895e 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -184,19 +184,28 @@ [syntax-case raw-syntax-case])) (intermediate-define-syntax2 my-macro (keyword) - [(anything intermediate-...) - (pure ''nil)]) - ;[(_ ((a b) (c d))) - ; (pure (cons-list-syntax a - ; (cons-list-syntax b - ; (cons-list-syntax c - ; (cons-list-syntax d - ; '() - ; raw-stx) - ; raw-stx) - ; raw-stx) - ; raw-stx))] - ;[(_ (foo tail intermediate-...)) - ; (pure (cons-list-syntax 'quote tail raw-stx))]) + [(_ ((a b) (c d))) + (let [stx (cons-list-syntax a + (cons-list-syntax b + (cons-list-syntax c + (cons-list-syntax d + '() + raw-stx) + raw-stx) + raw-stx) + raw-stx)] + (pure (cons-list-syntax 'quote + (cons-list-syntax stx + '() + raw-stx) + raw-stx)))] + [(_ (foo tail intermediate-...)) + (let [stx tail] + (pure (cons-list-syntax 'quote + (cons-list-syntax stx + '() + raw-stx) + raw-stx)))]) - '(example (my-macro))))))))) + '(example (my-macro ((1 2) (3 4)))) + '(example (my-macro (keyword foo bar)))))))))) diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index 9f566111..c65746fc 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -24,8 +24,154 @@ raw-stx))) (let (failure-cc (lambda () - (let (anything raw-stx) - (pure ''nil)))) - (failure-cc))))))) + (raw-syntax-case + raw-stx + ((cons + head-145 + tail-146) + (let (_ head-145) + (raw-syntax-case + tail-146 + ((cons + head-147 + tail-148) + (raw-syntax-case + head-147 + ((cons + head-149 + tail-150) + (let (foo + head-149) + (let (tail + tail-150) + (raw-syntax-case + tail-148 + (() + (let (stx + tail) + (pure + (cons-list-syntax + 'quote + (cons-list-syntax + stx + '() + raw-stx) + raw-stx)))) + (_ + (failure-cc)))))) + (_ (failure-cc)))) + (_ (failure-cc))))) + (_ (failure-cc))))) + (let (failure-cc + (lambda () + (raw-syntax-case + raw-stx + ((cons + head-151 + tail-152) + (let (_ head-151) + (raw-syntax-case + tail-152 + ((cons + head-153 + tail-154) + (raw-syntax-case + head-153 + ((cons + head-155 + tail-156) + (raw-syntax-case + head-155 + ((cons + head-163 + tail-164) + (let (a + head-163) + (raw-syntax-case + tail-164 + ((cons + head-165 + tail-166) + (let (b + head-165) + (raw-syntax-case + tail-166 + (() + (raw-syntax-case + tail-156 + ((cons + head-157 + tail-158) + (raw-syntax-case + head-157 + ((cons + head-159 + tail-160) + (let (c + head-159) + (raw-syntax-case + tail-160 + ((cons + head-161 + tail-162) + (let (d + head-161) + (raw-syntax-case + tail-162 + (() + (raw-syntax-case + tail-158 + (() + (raw-syntax-case + tail-154 + (() + (let (stx + (cons-list-syntax + a + (cons-list-syntax + b + (cons-list-syntax + c + (cons-list-syntax + d + '() + raw-stx) + raw-stx) + raw-stx) + raw-stx)) + (pure + (cons-list-syntax + 'quote + (cons-list-syntax + stx + '() + raw-stx) + raw-stx)))) + (_ + (failure-cc)))) + (_ + (failure-cc)))) + (_ + (failure-cc))))) + (_ + (failure-cc))))) + (_ + (failure-cc)))) + (_ + (failure-cc)))) + (_ + (failure-cc))))) + (_ + (failure-cc))))) + (_ + (failure-cc)))) + (_ + (failure-cc)))) + (_ + (failure-cc))))) + (_ (failure-cc))))) + (failure-cc)))))))) -(example (my-macro)) +(example (my-macro ((1 2) (3 4)))) + +(example (my-macro (keyword foo bar))) From dfc756f6c7975ed97d185e8ee5572c3606433f3d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sat, 10 Oct 2020 16:18:16 -0400 Subject: [PATCH 05/35] intermediate-quasiquote --- bootstrap.rkt | 124 +++++++++++++++++++++++++++++----- examples/dot-dot-dot.kl | 146 ++++++++++++++++++++++++++++------------ 2 files changed, 211 insertions(+), 59 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 312d895e..7f4fe478 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -16,28 +16,32 @@ ; ; But it's also a bit mind-bending because there are many different versions of ; syntax-case defined in terms of each other: +; ; * In the generated Klister code, fancy-syntax-case is defined using ; raw-syntax-case and expands to code which uses raw-syntax-case. -; * In this file, we generate that Klister code using -; intermediate-define-syntax2, because it's a lot more convenient to use than -; raw-syntax-case. +; * In this file, we generate that Klister code using intermediate-define-syntax2. ; * intermediate-define-syntax{1,2} are defined using racket-syntax-case, and ; expand to Klister code which uses raw-syntax-case. +; +; * In the generated Klister code, fancy-quasiquote is defined using +; raw-syntax-case and {append,cons,pair}-list-syntax. +; * In this file, we generate that Klister code using intermediate-quasiquote2. +; * intermediate-quasiquote{1,2} are defined using racket-syntax-case. ; (intermediate-define-syntax1 my-macro (foo bar) ; (lambda (raw-stx) ; (pure raw-stx))) ; => -; (raw-define-macros -; ([foo -; (lambda (raw-stx) -; (syntax-error '"foo used out of context" raw-stx))] -; [bar -; (lambda (raw-stx) -; (syntax-error '"bar used out of context" raw-stx))] -; [my-macro -; (lambda (raw-stx) -; (pure raw-stx))])) +; '(raw-define-macros +; ([foo +; (lambda (raw-stx) +; (syntax-error '"foo used out of context" raw-stx))] +; [bar +; (lambda (raw-stx) +; (syntax-error '"bar used out of context" raw-stx))] +; [my-macro +; (lambda (raw-stx) +; (pure raw-stx))])) (racket-define-syntax (intermediate-define-syntax1 intermediate-stx) (racket-syntax-case intermediate-stx () [(_ macro-name (literal-id racket-...) impl) @@ -153,6 +157,63 @@ raw-stx))] #,(intermediate-expand-cases #'(cases racket-...))))))])) +; `(1 ,(list 2 3) ,@(list 4 5) 6) +; => +; '(1 (2 3) 4 5 6) +; +; (intermediate-quasiquote1 +; (1 +; (intermediate-unquote '(2 3)) +; '(4 5) intermediate-... +; 6)) +; => +; '(cons-list-syntax 1 +; (cons-list-syntax '(2 3) +; (append-list-syntax '(4 5) +; (cons-list-syntax 6 +; '() +; raw-stx) +; raw-stx) +; raw-stx) +; raw-stx) +; => +; (1 (2 3) 4 5 6) +(define-syntax (intermediate-quasiquote1 intermediate-stx) + (racket-syntax-case intermediate-stx (intermediate-unquote intermediate-...) + [(_ ((intermediate-unquote head) tail racket-...)) + #'`(cons-list-syntax + head + ,(intermediate-quasiquote1 (tail racket-...)) + raw-stx)] + [(_ (head intermediate-... tail racket-...)) + #'`(append-list-syntax + head + ,(intermediate-quasiquote1 (tail racket-...)) + raw-stx)] + [(_ (head tail racket-...)) + #'`(cons-list-syntax + ,(intermediate-quasiquote1 head) + ,(intermediate-quasiquote1 (tail racket-...)) + raw-stx)] + [(_ x) + #'''x])) + +; (intermediate-quasiquote2 +; (1 +; (intermediate-unquote '(2 3)) +; '(4 5) intermediate-... +; 6)) +; => +; ... +; => +; '(1 (2 3) 4 5 6) +(define-syntax (intermediate-quasiquote2 intermediate-stx) + (racket-syntax-case intermediate-stx () + [(_ e) + #'`(pair-list-syntax 'quote + ,(intermediate-quasiquote1 e) + raw-stx)])) + (void (call-with-output-file @@ -180,9 +241,43 @@ (list '(import (rename "prelude.kl" [define-macros raw-define-macros])) + '(import (rename "prelude.kl" + [syntax-case raw-syntax-case])) '(import (rename (shift "prelude.kl" 1) [syntax-case raw-syntax-case])) - + + '(example (cons-list-syntax '1 '(2 3 4) 'raw-stx)) + + '(defun pair-list-syntax (head tail raw-stx) + (cons-list-syntax head + (cons-list-syntax tail + '() + raw-stx) + raw-stx)) + '(example (pair-list-syntax '1 '2 'raw-stx)) + + '(defun append-list-syntax (list tail raw-stx) + (raw-syntax-case list + [() + tail] + [(cons car cdr) + (cons-list-syntax car + (append-list-syntax cdr tail raw-stx) + raw-stx)])) + + '(example (append-list-syntax + '(1 2 3) + '(4 5 6) + 'raw-stx)) + + `(example + (let [raw-stx 'raw-stx] + ,(intermediate-quasiquote2 + (1 + (intermediate-unquote '(2 3)) + '(4 5) intermediate-... + 6)))) + (intermediate-define-syntax2 my-macro (keyword) [(_ ((a b) (c d))) (let [stx (cons-list-syntax a @@ -206,6 +301,5 @@ '() raw-stx) raw-stx)))]) - '(example (my-macro ((1 2) (3 4)))) '(example (my-macro (keyword foo bar)))))))))) diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index c65746fc..38f02732 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -5,10 +5,68 @@ (define-macros raw-define-macros))) +(import (rename "prelude.kl" + (syntax-case + raw-syntax-case))) + (import (rename (shift "prelude.kl" 1) (syntax-case raw-syntax-case))) +(example + (cons-list-syntax + '1 + '(2 3 4) + 'raw-stx)) + +(defun + pair-list-syntax + (head tail raw-stx) + (cons-list-syntax + head + (cons-list-syntax tail '() raw-stx) + raw-stx)) + +(example + (pair-list-syntax '1 '2 'raw-stx)) + +(defun + append-list-syntax + (list tail raw-stx) + (raw-syntax-case + list + (() tail) + ((cons car cdr) + (cons-list-syntax + car + (append-list-syntax + cdr + tail + raw-stx) + raw-stx)))) + +(example + (append-list-syntax + '(1 2 3) + '(4 5 6) + 'raw-stx)) + +(example + (let (raw-stx 'raw-stx) + (pair-list-syntax + 'quote + (cons-list-syntax + '1 + (cons-list-syntax + '(2 3) + (append-list-syntax + '(4 5) + (cons-list-syntax '6 '() raw-stx) + raw-stx) + raw-stx) + raw-stx) + raw-stx))) + (raw-define-macros ((keyword (lambda (raw-stx) @@ -27,25 +85,25 @@ (raw-syntax-case raw-stx ((cons - head-145 - tail-146) - (let (_ head-145) + head-155 + tail-156) + (let (_ head-155) (raw-syntax-case - tail-146 + tail-156 ((cons - head-147 - tail-148) + head-157 + tail-158) (raw-syntax-case - head-147 + head-157 ((cons - head-149 - tail-150) + head-159 + tail-160) (let (foo - head-149) + head-159) (let (tail - tail-150) + tail-160) (raw-syntax-case - tail-148 + tail-158 (() (let (stx tail) @@ -67,63 +125,63 @@ (raw-syntax-case raw-stx ((cons - head-151 - tail-152) - (let (_ head-151) + head-161 + tail-162) + (let (_ head-161) (raw-syntax-case - tail-152 + tail-162 ((cons - head-153 - tail-154) + head-163 + tail-164) (raw-syntax-case - head-153 + head-163 ((cons - head-155 - tail-156) + head-165 + tail-166) (raw-syntax-case - head-155 + head-165 ((cons - head-163 - tail-164) + head-173 + tail-174) (let (a - head-163) + head-173) (raw-syntax-case - tail-164 + tail-174 ((cons - head-165 - tail-166) + head-175 + tail-176) (let (b - head-165) + head-175) (raw-syntax-case - tail-166 + tail-176 (() (raw-syntax-case - tail-156 + tail-166 ((cons - head-157 - tail-158) + head-167 + tail-168) (raw-syntax-case - head-157 + head-167 ((cons - head-159 - tail-160) + head-169 + tail-170) (let (c - head-159) + head-169) (raw-syntax-case - tail-160 + tail-170 ((cons - head-161 - tail-162) + head-171 + tail-172) (let (d - head-161) + head-171) (raw-syntax-case - tail-162 + tail-172 (() (raw-syntax-case - tail-158 + tail-168 (() (raw-syntax-case - tail-154 + tail-164 (() (let (stx (cons-list-syntax From 4d001335cc8568844db3d03fc16687e932c4db35 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sat, 10 Oct 2020 16:18:46 -0400 Subject: [PATCH 06/35] dot-dot-dot.golden --- examples/dot-dot-dot.golden | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 examples/dot-dot-dot.golden diff --git a/examples/dot-dot-dot.golden b/examples/dot-dot-dot.golden new file mode 100644 index 00000000..38df6d45 --- /dev/null +++ b/examples/dot-dot-dot.golden @@ -0,0 +1,6 @@ +#[dot-dot-dot.kl:20.4-20.11]<(1 2 3 4)> : Syntax +#[dot-dot-dot.kl:31.27-31.34]<(1 2)> : Syntax +#[dot-dot-dot.kl:52.4-52.11]<(1 2 3 4 5 6)> : Syntax +#[dot-dot-dot.kl:55.17-55.24]<(quote (1 (2 3) 4 5 6))> : Syntax +#[dot-dot-dot.kl:233.10-233.34]<(1 2 3 4)> : Syntax +#[dot-dot-dot.kl:235.20-235.37]<(foo bar)> : Syntax From cbaa7a37c04fe4d4a2c3812ca2cf990f313698c0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sat, 10 Oct 2020 17:43:24 -0400 Subject: [PATCH 07/35] move {pair,append}-list-syntax to list-syntax.kl --- bootstrap.rkt | 27 +----------------------- examples/dot-dot-dot.golden | 9 +++----- examples/dot-dot-dot.kl | 42 +------------------------------------ examples/list-syntax.golden | 12 ++++++----- examples/list-syntax.kl | 23 +++++++++++++++++++- 5 files changed, 34 insertions(+), 79 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 7f4fe478..c3dde276 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -241,35 +241,10 @@ (list '(import (rename "prelude.kl" [define-macros raw-define-macros])) - '(import (rename "prelude.kl" - [syntax-case raw-syntax-case])) + '(import "list-syntax.kl") '(import (rename (shift "prelude.kl" 1) [syntax-case raw-syntax-case])) - '(example (cons-list-syntax '1 '(2 3 4) 'raw-stx)) - - '(defun pair-list-syntax (head tail raw-stx) - (cons-list-syntax head - (cons-list-syntax tail - '() - raw-stx) - raw-stx)) - '(example (pair-list-syntax '1 '2 'raw-stx)) - - '(defun append-list-syntax (list tail raw-stx) - (raw-syntax-case list - [() - tail] - [(cons car cdr) - (cons-list-syntax car - (append-list-syntax cdr tail raw-stx) - raw-stx)])) - - '(example (append-list-syntax - '(1 2 3) - '(4 5 6) - 'raw-stx)) - `(example (let [raw-stx 'raw-stx] ,(intermediate-quasiquote2 diff --git a/examples/dot-dot-dot.golden b/examples/dot-dot-dot.golden index 38df6d45..c83c604e 100644 --- a/examples/dot-dot-dot.golden +++ b/examples/dot-dot-dot.golden @@ -1,6 +1,3 @@ -#[dot-dot-dot.kl:20.4-20.11]<(1 2 3 4)> : Syntax -#[dot-dot-dot.kl:31.27-31.34]<(1 2)> : Syntax -#[dot-dot-dot.kl:52.4-52.11]<(1 2 3 4 5 6)> : Syntax -#[dot-dot-dot.kl:55.17-55.24]<(quote (1 (2 3) 4 5 6))> : Syntax -#[dot-dot-dot.kl:233.10-233.34]<(1 2 3 4)> : Syntax -#[dot-dot-dot.kl:235.20-235.37]<(foo bar)> : Syntax +#[dot-dot-dot.kl:15.17-15.24]<(quote (1 (2 3) 4 5 6))> : Syntax +#[dot-dot-dot.kl:193.10-193.34]<(1 2 3 4)> : Syntax +#[dot-dot-dot.kl:195.20-195.37]<(foo bar)> : Syntax diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index 38f02732..a9fff4b5 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -5,52 +5,12 @@ (define-macros raw-define-macros))) -(import (rename "prelude.kl" - (syntax-case - raw-syntax-case))) +(import "list-syntax.kl") (import (rename (shift "prelude.kl" 1) (syntax-case raw-syntax-case))) -(example - (cons-list-syntax - '1 - '(2 3 4) - 'raw-stx)) - -(defun - pair-list-syntax - (head tail raw-stx) - (cons-list-syntax - head - (cons-list-syntax tail '() raw-stx) - raw-stx)) - -(example - (pair-list-syntax '1 '2 'raw-stx)) - -(defun - append-list-syntax - (list tail raw-stx) - (raw-syntax-case - list - (() tail) - ((cons car cdr) - (cons-list-syntax - car - (append-list-syntax - cdr - tail - raw-stx) - raw-stx)))) - -(example - (append-list-syntax - '(1 2 3) - '(4 5 6) - 'raw-stx)) - (example (let (raw-stx 'raw-stx) (pair-list-syntax 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) From de8ec1c79ad72437b3eb0526f2a42e54a46687d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sat, 10 Oct 2020 17:53:40 -0400 Subject: [PATCH 08/35] simplify my-macro using intermediate-quasiquote --- bootstrap.rkt | 34 +++---------------- examples/dot-dot-dot.golden | 5 ++- examples/dot-dot-dot.kl | 66 +++++++++++-------------------------- 3 files changed, 26 insertions(+), 79 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index c3dde276..881892e3 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -58,7 +58,7 @@ (syntax->datum #'(literal-id racket-...))] [undefined-macros (map undefined-macro symbols)]) - #`'(raw-define-macros + #``(raw-define-macros (#,@undefined-macros [macro-name impl])))])) @@ -241,40 +241,14 @@ (list '(import (rename "prelude.kl" [define-macros raw-define-macros])) - '(import "list-syntax.kl") + '(import (shift "list-syntax.kl" 1)) '(import (rename (shift "prelude.kl" 1) [syntax-case raw-syntax-case])) - `(example - (let [raw-stx 'raw-stx] - ,(intermediate-quasiquote2 - (1 - (intermediate-unquote '(2 3)) - '(4 5) intermediate-... - 6)))) - (intermediate-define-syntax2 my-macro (keyword) [(_ ((a b) (c d))) - (let [stx (cons-list-syntax a - (cons-list-syntax b - (cons-list-syntax c - (cons-list-syntax d - '() - raw-stx) - raw-stx) - raw-stx) - raw-stx)] - (pure (cons-list-syntax 'quote - (cons-list-syntax stx - '() - raw-stx) - raw-stx)))] + (pure ,(intermediate-quasiquote2 (a b c d)))] [(_ (foo tail intermediate-...)) - (let [stx tail] - (pure (cons-list-syntax 'quote - (cons-list-syntax stx - '() - raw-stx) - raw-stx)))]) + (pure (pair-list-syntax 'quote tail raw-stx))]) '(example (my-macro ((1 2) (3 4)))) '(example (my-macro (keyword foo bar)))))))))) diff --git a/examples/dot-dot-dot.golden b/examples/dot-dot-dot.golden index c83c604e..5d1a69a2 100644 --- a/examples/dot-dot-dot.golden +++ b/examples/dot-dot-dot.golden @@ -1,3 +1,2 @@ -#[dot-dot-dot.kl:15.17-15.24]<(quote (1 (2 3) 4 5 6))> : Syntax -#[dot-dot-dot.kl:193.10-193.34]<(1 2 3 4)> : Syntax -#[dot-dot-dot.kl:195.20-195.37]<(foo bar)> : Syntax +#[dot-dot-dot.kl:167.10-167.34]<(a b c d)> : Syntax +#[dot-dot-dot.kl:169.20-169.37]<(foo bar)> : Syntax diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index a9fff4b5..647922a7 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -5,28 +5,12 @@ (define-macros raw-define-macros))) -(import "list-syntax.kl") +(import (shift "list-syntax.kl" 1)) (import (rename (shift "prelude.kl" 1) (syntax-case raw-syntax-case))) -(example - (let (raw-stx 'raw-stx) - (pair-list-syntax - 'quote - (cons-list-syntax - '1 - (cons-list-syntax - '(2 3) - (append-list-syntax - '(4 5) - (cons-list-syntax '6 '() raw-stx) - raw-stx) - raw-stx) - raw-stx) - raw-stx))) - (raw-define-macros ((keyword (lambda (raw-stx) @@ -65,16 +49,11 @@ (raw-syntax-case tail-158 (() - (let (stx - tail) - (pure - (cons-list-syntax - 'quote - (cons-list-syntax - stx - '() - raw-stx) - raw-stx)))) + (pure + (pair-list-syntax + 'quote + tail + raw-stx))) (_ (failure-cc)))))) (_ (failure-cc)))) @@ -143,28 +122,23 @@ (raw-syntax-case tail-164 (() - (let (stx - (cons-list-syntax - a - (cons-list-syntax - b - (cons-list-syntax - c - (cons-list-syntax - d - '() - raw-stx) - raw-stx) - raw-stx) - raw-stx)) - (pure + (pure + (pair-list-syntax + 'quote + (cons-list-syntax + 'a (cons-list-syntax - 'quote + 'b (cons-list-syntax - stx - '() + 'c + (cons-list-syntax + 'd + '() + raw-stx) raw-stx) - raw-stx)))) + raw-stx) + raw-stx) + raw-stx))) (_ (failure-cc)))) (_ From 5cfdc0e524d911ab03bac1c6cb4892ed990eed5d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sun, 11 Oct 2020 11:07:02 -0400 Subject: [PATCH 09/35] split define-syntax into define-keywords and syntax-case thus making is possible to define multiple macros which share the same keywords. --- bootstrap.rkt | 112 +++++++------- examples/dot-dot-dot.golden | 4 +- examples/dot-dot-dot.kl | 295 ++++++++++++++++++------------------ 3 files changed, 208 insertions(+), 203 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 881892e3..29c4fcc7 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -19,18 +19,16 @@ ; ; * In the generated Klister code, fancy-syntax-case is defined using ; raw-syntax-case and expands to code which uses raw-syntax-case. -; * In this file, we generate that Klister code using intermediate-define-syntax2. -; * intermediate-define-syntax{1,2} are defined using racket-syntax-case, and -; expand to Klister code which uses raw-syntax-case. +; * In this file, we generate that Klister code using intermediate-syntax-case. +; * intermediate-syntax-case is defined using racket-syntax-case, and expands +; to Klister code which uses raw-syntax-case. ; ; * In the generated Klister code, fancy-quasiquote is defined using ; raw-syntax-case and {append,cons,pair}-list-syntax. -; * In this file, we generate that Klister code using intermediate-quasiquote2. -; * intermediate-quasiquote{1,2} are defined using racket-syntax-case. +; * In this file, we generate that Klister code using intermediate-quasiquote. +; * intermediate-quasiquote is defined using racket-syntax-case. -; (intermediate-define-syntax1 my-macro (foo bar) -; (lambda (raw-stx) -; (pure raw-stx))) +; (intermediate-define-keywords (foo bar)) ; => ; '(raw-define-macros ; ([foo @@ -38,13 +36,10 @@ ; (syntax-error '"foo used out of context" raw-stx))] ; [bar ; (lambda (raw-stx) -; (syntax-error '"bar used out of context" raw-stx))] -; [my-macro -; (lambda (raw-stx) -; (pure raw-stx))])) -(racket-define-syntax (intermediate-define-syntax1 intermediate-stx) +; (syntax-error '"bar used out of context" raw-stx))])) +(racket-define-syntax (intermediate-define-keywords intermediate-stx) (racket-syntax-case intermediate-stx () - [(_ macro-name (literal-id racket-...) impl) + [(_ (keyword racket-...)) (let* ([error-message (lambda (symbol) (string-append (symbol->string symbol) @@ -55,14 +50,13 @@ (lambda (raw-stx) (syntax-error '#,(error-message symbol) raw-stx))])] [symbols - (syntax->datum #'(literal-id racket-...))] + (syntax->datum #'(keyword racket-...))] [undefined-macros (map undefined-macro symbols)]) #``(raw-define-macros - (#,@undefined-macros - [macro-name impl])))])) + (#,@undefined-macros)))])) -; (intermediate-define-syntax2 my-macro (keyword) +; (intermediate-syntax-case raw-stx (keyword) ; [() ; rhs1] ; [((a b) (c d)) @@ -70,42 +64,40 @@ ; [(keyword tail intermediate-...) ; rhs3]) ; => -; (intermediate-define-syntax1 my-macro (keyword) -; (lambda (raw-stx) +; (let [failure-cc +; (lambda () +; (syntax-error '"my-macro call has invalid syntax" raw-stx))] +; (let [failure-cc +; (lambda () +; (raw-syntax-case raw-stx +; [(cons head tail) +; (>>= (free-identifier=? head 'keyword) +; (lambda (same-identifier) +; (if same-identifier +; rhs3 +; (failure-cc))))] +; [_ (failure-cc)]))] ; (let [failure-cc ; (lambda () -; (syntax-error '"my-macro call has invalid syntax" raw-stx))] +; (raw-syntax-case raw-stx +; [(cons ab cd-nil) +; (raw-syntax-case ab +; [(cons a b-nil) +; (... rhs2)] +; [_ (failure-cc)])] +; [_ (failure-cc)]))] ; (let [failure-cc ; (lambda () ; (raw-syntax-case raw-stx -; [(cons head tail) -; (>>= (free-identifier=? head 'keyword) -; (lambda (same-identifier) -; (if same-identifier -; rhs3 -; (failure-cc))))] +; [() rhs1] ; [_ (failure-cc)]))] -; (let [failure-cc -; (lambda () -; (raw-syntax-case raw-stx -; [(cons ab cd-nil) -; (raw-syntax-case ab -; [(cons a b-nil) -; (... rhs2)] -; [_ (failure-cc)])] -; [_ (failure-cc)]))] -; (let [failure-cc -; (lambda () -; (raw-syntax-case raw-stx -; [() rhs1] -; [_ (failure-cc)]))] -; (failure-cc))))))) -(racket-define-syntax (intermediate-define-syntax2 intermediate-stx) +; (failure-cc))))) +(racket-define-syntax (intermediate-syntax-case intermediate-stx) (racket-syntax-case intermediate-stx () - [(_ macro-name (intermediate-literal-id racket-...) + [(_ raw-stx (keyword racket-...) cases racket-...) (letrec ([symbols - (syntax->datum #'(intermediate-literal-id racket-...))] + (syntax->datum #'(keyword racket-...))] [intermediate-expand-case (lambda (scrutinee-name intermediate-case-stx) (racket-syntax-case intermediate-case-stx (intermediate-...) @@ -146,16 +138,26 @@ (lambda () #,(intermediate-expand-case 'raw-stx #'case))] #,(intermediate-expand-cases #'(cases racket-...)))]))]) - #`(intermediate-define-syntax1 macro-name (intermediate-literal-id racket-...) - (lambda (raw-stx) - (let [failure-cc - (lambda () - (syntax-error - '#,(string-append - (symbol->string (syntax->datum #'macro-name)) - " call has invalid syntax") - raw-stx))] - #,(intermediate-expand-cases #'(cases racket-...))))))])) + #``(let [failure-cc + (lambda () + (syntax-error + '#,(string-append + (symbol->string (syntax->datum #'macro-name)) + " call has invalid syntax") + raw-stx))] + #,(intermediate-expand-cases #'(cases racket-...))))])) + +(define-syntax (intermediate-define-syntax2 intermediate-stx) + (syntax-case intermediate-stx () + [(_ macro-name (keyword racket-...) + case racket-...) + #'`(group + ,(intermediate-define-keywords (keyword racket-...)) + (define-macros + ([macro-name + (lambda (raw-stx) + ,(intermediate-syntax-case raw-stx (keyword racket-...) + case racket-...))])))])) ; `(1 ,(list 2 3) ,@(list 4 5) 6) ; => diff --git a/examples/dot-dot-dot.golden b/examples/dot-dot-dot.golden index 5d1a69a2..635fd625 100644 --- a/examples/dot-dot-dot.golden +++ b/examples/dot-dot-dot.golden @@ -1,2 +1,2 @@ -#[dot-dot-dot.kl:167.10-167.34]<(a b c d)> : Syntax -#[dot-dot-dot.kl:169.20-169.37]<(foo bar)> : Syntax +#[dot-dot-dot.kl:170.10-170.34]<(a b c d)> : Syntax +#[dot-dot-dot.kl:172.20-172.37]<(foo bar)> : Syntax diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index 647922a7..b9cec64b 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -11,158 +11,161 @@ (syntax-case raw-syntax-case))) -(raw-define-macros - ((keyword - (lambda (raw-stx) - (syntax-error - '"keyword used out of context" - raw-stx))) - (my-macro - (lambda (raw-stx) - (let (failure-cc - (lambda () - (syntax-error - '"my-macro call has invalid syntax" - raw-stx))) - (let (failure-cc - (lambda () - (raw-syntax-case - raw-stx - ((cons - head-155 - tail-156) - (let (_ head-155) - (raw-syntax-case - tail-156 - ((cons - head-157 - tail-158) - (raw-syntax-case - head-157 - ((cons - head-159 - tail-160) - (let (foo - head-159) - (let (tail - tail-160) - (raw-syntax-case - tail-158 - (() - (pure - (pair-list-syntax - 'quote - tail - raw-stx))) - (_ - (failure-cc)))))) - (_ (failure-cc)))) - (_ (failure-cc))))) - (_ (failure-cc))))) - (let (failure-cc - (lambda () - (raw-syntax-case - raw-stx - ((cons - head-161 - tail-162) - (let (_ head-161) - (raw-syntax-case - tail-162 - ((cons - head-163 - tail-164) - (raw-syntax-case - head-163 - ((cons - head-165 - tail-166) - (raw-syntax-case - head-165 - ((cons - head-173 - tail-174) - (let (a - head-173) - (raw-syntax-case - tail-174 - ((cons - head-175 - tail-176) - (let (b - head-175) - (raw-syntax-case - tail-176 - (() - (raw-syntax-case - tail-166 - ((cons - head-167 - tail-168) - (raw-syntax-case - head-167 - ((cons - head-169 - tail-170) - (let (c - head-169) - (raw-syntax-case - tail-170 - ((cons - head-171 - tail-172) - (let (d - head-171) - (raw-syntax-case - tail-172 - (() - (raw-syntax-case - tail-168 - (() - (raw-syntax-case - tail-164 - (() - (pure - (pair-list-syntax - 'quote - (cons-list-syntax - 'a +(group + (raw-define-macros + ((keyword + (lambda (raw-stx) + (syntax-error + '"keyword used out of context" + raw-stx))))) + (define-macros + ((my-macro + (lambda (raw-stx) + (let (failure-cc + (lambda () + (syntax-error + '"macro-name call has invalid syntax" + raw-stx))) + (let (failure-cc + (lambda () + (raw-syntax-case + raw-stx + ((cons + head-157 + tail-158) + (let (_ head-157) + (raw-syntax-case + tail-158 + ((cons + head-159 + tail-160) + (raw-syntax-case + head-159 + ((cons + head-161 + tail-162) + (let (foo + head-161) + (let (tail + tail-162) + (raw-syntax-case + tail-160 + (() + (pure + (pair-list-syntax + 'quote + tail + raw-stx))) + (_ + (failure-cc)))))) + (_ + (failure-cc)))) + (_ (failure-cc))))) + (_ (failure-cc))))) + (let (failure-cc + (lambda () + (raw-syntax-case + raw-stx + ((cons + head-163 + tail-164) + (let (_ head-163) + (raw-syntax-case + tail-164 + ((cons + head-165 + tail-166) + (raw-syntax-case + head-165 + ((cons + head-167 + tail-168) + (raw-syntax-case + head-167 + ((cons + head-175 + tail-176) + (let (a + head-175) + (raw-syntax-case + tail-176 + ((cons + head-177 + tail-178) + (let (b + head-177) + (raw-syntax-case + tail-178 + (() + (raw-syntax-case + tail-168 + ((cons + head-169 + tail-170) + (raw-syntax-case + head-169 + ((cons + head-171 + tail-172) + (let (c + head-171) + (raw-syntax-case + tail-172 + ((cons + head-173 + tail-174) + (let (d + head-173) + (raw-syntax-case + tail-174 + (() + (raw-syntax-case + tail-170 + (() + (raw-syntax-case + tail-166 + (() + (pure + (pair-list-syntax + 'quote (cons-list-syntax - 'b + 'a (cons-list-syntax - 'c + 'b (cons-list-syntax - 'd - '() + 'c + (cons-list-syntax + 'd + '() + raw-stx) raw-stx) raw-stx) raw-stx) - raw-stx) - raw-stx))) - (_ - (failure-cc)))) - (_ - (failure-cc)))) - (_ - (failure-cc))))) - (_ - (failure-cc))))) - (_ - (failure-cc)))) - (_ - (failure-cc)))) - (_ - (failure-cc))))) - (_ - (failure-cc))))) - (_ - (failure-cc)))) - (_ - (failure-cc)))) - (_ - (failure-cc))))) - (_ (failure-cc))))) - (failure-cc)))))))) + raw-stx))) + (_ + (failure-cc)))) + (_ + (failure-cc)))) + (_ + (failure-cc))))) + (_ + (failure-cc))))) + (_ + (failure-cc)))) + (_ + (failure-cc)))) + (_ + (failure-cc))))) + (_ + (failure-cc))))) + (_ + (failure-cc)))) + (_ + (failure-cc)))) + (_ + (failure-cc))))) + (_ (failure-cc))))) + (failure-cc))))))))) (example (my-macro ((1 2) (3 4)))) From 8a6eb69a814e1559cc970ac553bf7546c9b2dac9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sun, 11 Oct 2020 11:44:24 -0400 Subject: [PATCH 10/35] racket-syntax-case matches on a racket-stx not on an intermediate-stx. an intermediate-stx is a piece of Klister code, typically the variable name 'raw-stx, which the generated code will match on or copy its location. --- bootstrap.rkt | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 29c4fcc7..41b39ede 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -37,8 +37,8 @@ ; [bar ; (lambda (raw-stx) ; (syntax-error '"bar used out of context" raw-stx))])) -(racket-define-syntax (intermediate-define-keywords intermediate-stx) - (racket-syntax-case intermediate-stx () +(racket-define-syntax (intermediate-define-keywords racket-stx) + (racket-syntax-case racket-stx () [(_ (keyword racket-...)) (let* ([error-message (lambda (symbol) @@ -92,9 +92,9 @@ ; [() rhs1] ; [_ (failure-cc)]))] ; (failure-cc))))) -(racket-define-syntax (intermediate-syntax-case intermediate-stx) - (racket-syntax-case intermediate-stx () - [(_ raw-stx (keyword racket-...) +(racket-define-syntax (intermediate-syntax-case racket-stx) + (racket-syntax-case racket-stx () + [(_ intermediate-stx (keyword racket-...) cases racket-...) (letrec ([symbols (syntax->datum #'(keyword racket-...))] @@ -136,7 +136,7 @@ [(cases racket-... case) #`(let [failure-cc (lambda () - #,(intermediate-expand-case 'raw-stx #'case))] + #,(intermediate-expand-case #'intermediate-stx #'case))] #,(intermediate-expand-cases #'(cases racket-...)))]))]) #``(let [failure-cc (lambda () @@ -144,7 +144,7 @@ '#,(string-append (symbol->string (syntax->datum #'macro-name)) " call has invalid syntax") - raw-stx))] + intermediate-stx))] #,(intermediate-expand-cases #'(cases racket-...))))])) (define-syntax (intermediate-define-syntax2 intermediate-stx) @@ -180,8 +180,8 @@ ; raw-stx) ; => ; (1 (2 3) 4 5 6) -(define-syntax (intermediate-quasiquote1 intermediate-stx) - (racket-syntax-case intermediate-stx (intermediate-unquote intermediate-...) +(define-syntax (intermediate-quasiquote1 racket-stx) + (racket-syntax-case racket-stx (intermediate-unquote intermediate-...) [(_ ((intermediate-unquote head) tail racket-...)) #'`(cons-list-syntax head @@ -209,8 +209,8 @@ ; ... ; => ; '(1 (2 3) 4 5 6) -(define-syntax (intermediate-quasiquote2 intermediate-stx) - (racket-syntax-case intermediate-stx () +(define-syntax (intermediate-quasiquote2 racket-stx) + (racket-syntax-case racket-stx () [(_ e) #'`(pair-list-syntax 'quote ,(intermediate-quasiquote1 e) From f1d107adaacfca25a161c3ff3632a2b951a55497 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sun, 11 Oct 2020 11:57:32 -0400 Subject: [PATCH 11/35] no more raw-stx magic previously, intermediate-define-syntax was silently introducing a variable named raw-stx, and intermediate-quasiquote was silently assuming its existence. no more! it is now bound and passed along explicitly. --- bootstrap.rkt | 44 +++++++++++---------- examples/dot-dot-dot.kl | 88 ++++++++++++++++++++--------------------- 2 files changed, 67 insertions(+), 65 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 41b39ede..326497d3 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -149,14 +149,14 @@ (define-syntax (intermediate-define-syntax2 intermediate-stx) (syntax-case intermediate-stx () - [(_ macro-name (keyword racket-...) + [(_ (macro-name intermediate-stx) (keyword racket-...) case racket-...) #'`(group ,(intermediate-define-keywords (keyword racket-...)) (define-macros ([macro-name - (lambda (raw-stx) - ,(intermediate-syntax-case raw-stx (keyword racket-...) + (lambda (intermediate-stx) + ,(intermediate-syntax-case intermediate-stx (keyword racket-...) case racket-...))])))])) ; `(1 ,(list 2 3) ,@(list 4 5) 6) @@ -167,7 +167,8 @@ ; (1 ; (intermediate-unquote '(2 3)) ; '(4 5) intermediate-... -; 6)) +; 6) +; raw-stx) ; => ; '(cons-list-syntax 1 ; (cons-list-syntax '(2 3) @@ -182,39 +183,40 @@ ; (1 (2 3) 4 5 6) (define-syntax (intermediate-quasiquote1 racket-stx) (racket-syntax-case racket-stx (intermediate-unquote intermediate-...) - [(_ ((intermediate-unquote head) tail racket-...)) + [(_ ((intermediate-unquote head) tail racket-...) intermediate-stx) #'`(cons-list-syntax head - ,(intermediate-quasiquote1 (tail racket-...)) - raw-stx)] - [(_ (head intermediate-... tail racket-...)) + ,(intermediate-quasiquote1 (tail racket-...) intermediate-stx) + intermediate-stx)] + [(_ (head intermediate-... tail racket-...) intermediate-stx) #'`(append-list-syntax head - ,(intermediate-quasiquote1 (tail racket-...)) - raw-stx)] - [(_ (head tail racket-...)) + ,(intermediate-quasiquote1 (tail racket-...) intermediate-stx) + intermediate-stx)] + [(_ (head tail racket-...) intermediate-stx) #'`(cons-list-syntax - ,(intermediate-quasiquote1 head) - ,(intermediate-quasiquote1 (tail racket-...)) - raw-stx)] - [(_ x) + ,(intermediate-quasiquote1 head intermediate-stx) + ,(intermediate-quasiquote1 (tail racket-...) intermediate-stx) + intermediate-stx)] + [(_ x intermediate-stx) #'''x])) ; (intermediate-quasiquote2 ; (1 ; (intermediate-unquote '(2 3)) ; '(4 5) intermediate-... -; 6)) +; 6) +; raw-stx) ; => ; ... ; => ; '(1 (2 3) 4 5 6) (define-syntax (intermediate-quasiquote2 racket-stx) (racket-syntax-case racket-stx () - [(_ e) + [(_ e intermediate-stx) #'`(pair-list-syntax 'quote - ,(intermediate-quasiquote1 e) - raw-stx)])) + ,(intermediate-quasiquote1 e intermediate-stx) + intermediate-stx)])) (void @@ -247,9 +249,9 @@ '(import (rename (shift "prelude.kl" 1) [syntax-case raw-syntax-case])) - (intermediate-define-syntax2 my-macro (keyword) + (intermediate-define-syntax2 (my-macro raw-stx) (keyword) [(_ ((a b) (c d))) - (pure ,(intermediate-quasiquote2 (a b c d)))] + (pure ,(intermediate-quasiquote2 (a b c d) raw-stx))] [(_ (foo tail intermediate-...)) (pure (pair-list-syntax 'quote tail raw-stx))]) '(example (my-macro ((1 2) (3 4)))) diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index b9cec64b..7b7448cb 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -31,25 +31,25 @@ (raw-syntax-case raw-stx ((cons - head-157 - tail-158) - (let (_ head-157) + head-163 + tail-164) + (let (_ head-163) (raw-syntax-case - tail-158 + tail-164 ((cons - head-159 - tail-160) + head-165 + tail-166) (raw-syntax-case - head-159 + head-165 ((cons - head-161 - tail-162) + head-167 + tail-168) (let (foo - head-161) + head-167) (let (tail - tail-162) + tail-168) (raw-syntax-case - tail-160 + tail-166 (() (pure (pair-list-syntax @@ -67,63 +67,63 @@ (raw-syntax-case raw-stx ((cons - head-163 - tail-164) - (let (_ head-163) + head-169 + tail-170) + (let (_ head-169) (raw-syntax-case - tail-164 + tail-170 ((cons - head-165 - tail-166) + head-171 + tail-172) (raw-syntax-case - head-165 + head-171 ((cons - head-167 - tail-168) + head-173 + tail-174) (raw-syntax-case - head-167 + head-173 ((cons - head-175 - tail-176) + head-181 + tail-182) (let (a - head-175) + head-181) (raw-syntax-case - tail-176 + tail-182 ((cons - head-177 - tail-178) + head-183 + tail-184) (let (b - head-177) + head-183) (raw-syntax-case - tail-178 + tail-184 (() (raw-syntax-case - tail-168 + tail-174 ((cons - head-169 - tail-170) + head-175 + tail-176) (raw-syntax-case - head-169 + head-175 ((cons - head-171 - tail-172) + head-177 + tail-178) (let (c - head-171) + head-177) (raw-syntax-case - tail-172 + tail-178 ((cons - head-173 - tail-174) + head-179 + tail-180) (let (d - head-173) + head-179) (raw-syntax-case - tail-174 + tail-180 (() (raw-syntax-case - tail-170 + tail-176 (() (raw-syntax-case - tail-166 + tail-172 (() (pure (pair-list-syntax From 8ed35e1ae136817c4c48b15a222036772242c0da Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sun, 11 Oct 2020 12:40:02 -0400 Subject: [PATCH 12/35] no more , magic previously, intermediate-syntax-case was generating a `(...) expression, and thus right-hand-sides could use ,(...) expressions to splice some code. that was strange because those ,(...) were not lexically surrounded by `(...). Now each right-hand-side is a Racket expression, not a Klister expression, and must thus use `(...) itself it it wants to return a Klister expression. --- bootstrap.rkt | 114 +++++++++++++++++++++++++------------------------- 1 file changed, 58 insertions(+), 56 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 326497d3..60b62ae9 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -58,40 +58,40 @@ ; (intermediate-syntax-case raw-stx (keyword) ; [() -; rhs1] +; 'rhs1] ; [((a b) (c d)) -; rhs2] +; 'rhs2] ; [(keyword tail intermediate-...) -; rhs3]) +; 'rhs3]) ; => -; (let [failure-cc -; (lambda () -; (syntax-error '"my-macro call has invalid syntax" raw-stx))] -; (let [failure-cc -; (lambda () -; (raw-syntax-case raw-stx -; [(cons head tail) -; (>>= (free-identifier=? head 'keyword) -; (lambda (same-identifier) -; (if same-identifier -; rhs3 -; (failure-cc))))] -; [_ (failure-cc)]))] -; (let [failure-cc -; (lambda () -; (raw-syntax-case raw-stx -; [(cons ab cd-nil) -; (raw-syntax-case ab -; [(cons a b-nil) -; (... rhs2)] -; [_ (failure-cc)])] -; [_ (failure-cc)]))] -; (let [failure-cc -; (lambda () -; (raw-syntax-case raw-stx -; [() rhs1] -; [_ (failure-cc)]))] -; (failure-cc))))) +; '(let [failure-cc +; (lambda () +; (syntax-error '"my-macro call has invalid syntax" raw-stx))] +; (let [failure-cc +; (lambda () +; (raw-syntax-case raw-stx +; [(cons head tail) +; (>>= (free-identifier=? head 'keyword) +; (lambda (same-identifier) +; (if same-identifier +; rhs3 +; (failure-cc))))] +; [_ (failure-cc)]))] +; (let [failure-cc +; (lambda () +; (raw-syntax-case raw-stx +; [(cons ab cd-nil) +; (raw-syntax-case ab +; [(cons a b-nil) +; (... rhs2)] +; [_ (failure-cc)])] +; [_ (failure-cc)]))] +; (let [failure-cc +; (lambda () +; (raw-syntax-case raw-stx +; [() rhs1] +; [_ (failure-cc)]))] +; (failure-cc))))) (racket-define-syntax (intermediate-syntax-case racket-stx) (racket-syntax-case racket-stx () [(_ intermediate-stx (keyword racket-...) @@ -102,42 +102,44 @@ (lambda (scrutinee-name intermediate-case-stx) (racket-syntax-case intermediate-case-stx (intermediate-...) [[() rhs] - #`(raw-syntax-case #,scrutinee-name - [() rhs] - [_ (failure-cc)])] + #``(raw-syntax-case #,scrutinee-name + [() ,rhs] + [_ (failure-cc)])] [[x rhs] (and (identifier? #'x) (member (syntax->datum #'x) symbols)) - #`(>>= (free-identifier=? #,scrutinee-name 'x) - (lambda (same-identifier) - (if same-identifier rhs (failure-cc))))] + #``(>>= (free-identifier=? #,scrutinee-name 'x) + (lambda (same-identifier) + (if same-identifier + ,rhs + (failure-cc))))] [[x rhs] (identifier? #'x) - #`(let [x #,scrutinee-name] - rhs)] + #``(let [x #,scrutinee-name] + ,rhs)] [[(x intermediate-...) rhs] - #`(let [x #,scrutinee-name] - rhs)] + #``(let [x #,scrutinee-name] + ,rhs)] [[(intermediate-head intermediate-tail racket-...) rhs] (let ([head-name (gensym 'head-)] [tail-name (gensym 'tail-)]) - #`(raw-syntax-case #,scrutinee-name - [(cons #,head-name #,tail-name) - #,(intermediate-expand-case head-name - #`[intermediate-head - #,(intermediate-expand-case tail-name - #`[(intermediate-tail racket-...) rhs])])] - [_ (failure-cc)]))]))] + #``(raw-syntax-case #,scrutinee-name + [(cons #,head-name #,tail-name) + ,#,(intermediate-expand-case head-name + #`[intermediate-head + #,(intermediate-expand-case tail-name + #`[(intermediate-tail racket-...) rhs])])] + [_ (failure-cc)]))]))] [intermediate-expand-cases (lambda (intermediate-cases-stx) (racket-syntax-case intermediate-cases-stx (intermediate-...) [() - #`(failure-cc)] + #``(failure-cc)] [(cases racket-... case) - #`(let [failure-cc - (lambda () - #,(intermediate-expand-case #'intermediate-stx #'case))] - #,(intermediate-expand-cases #'(cases racket-...)))]))]) + #``(let [failure-cc + (lambda () + ,#,(intermediate-expand-case #'intermediate-stx #'case))] + ,#,(intermediate-expand-cases #'(cases racket-...)))]))]) #``(let [failure-cc (lambda () (syntax-error @@ -145,7 +147,7 @@ (symbol->string (syntax->datum #'macro-name)) " call has invalid syntax") intermediate-stx))] - #,(intermediate-expand-cases #'(cases racket-...))))])) + ,#,(intermediate-expand-cases #'(cases racket-...))))])) (define-syntax (intermediate-define-syntax2 intermediate-stx) (syntax-case intermediate-stx () @@ -251,8 +253,8 @@ (intermediate-define-syntax2 (my-macro raw-stx) (keyword) [(_ ((a b) (c d))) - (pure ,(intermediate-quasiquote2 (a b c d) raw-stx))] + `(pure ,(intermediate-quasiquote2 (a b c d) raw-stx))] [(_ (foo tail intermediate-...)) - (pure (pair-list-syntax 'quote tail raw-stx))]) + `(pure (pair-list-syntax 'quote tail raw-stx))]) '(example (my-macro ((1 2) (3 4)))) '(example (my-macro (keyword foo bar)))))))))) From ba3243347a3ccd3e9b489751ea98ac4ff0c5f312 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sun, 11 Oct 2020 17:30:22 -0400 Subject: [PATCH 13/35] don't use racket-syntax-case eliminate a lot of mind-bending complexity like ,#,(...) blocks, at the cost of slightly more verbose call sites like (generate-syntax-case 'my-macro 'raw-stx (list 'keyword) (list (cons '() 'rhs1) (cons '((a b) (c d)) 'rhs2) (cons '(keyword tail ...) 'rhs3))) intead of (intermediate-syntax-case (my-macro raw-stx) (keyword) [() 'rhs1] [((a b) (c d)) 'rhs2] [(keyword tail ...) 'rhs3]) --- bootstrap.rkt | 298 ++++++++++++++++-------------------- examples/dot-dot-dot.golden | 5 +- examples/dot-dot-dot.kl | 256 +++++++++++++++++++------------ 3 files changed, 292 insertions(+), 267 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 60b62ae9..32a9dea1 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -1,8 +1,5 @@ #lang racket -(require (rename-in racket [define-syntax racket-define-syntax] - [syntax-case racket-syntax-case] - [... racket-...])) (require racket/pretty) ; Problem: bootstrapping can be difficult. When we don't yet have convenient @@ -12,23 +9,10 @@ ; 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 macro-defining macros like racket-syntax-case. -; -; But it's also a bit mind-bending because there are many different versions of -; syntax-case defined in terms of each other: -; -; * In the generated Klister code, fancy-syntax-case is defined using -; raw-syntax-case and expands to code which uses raw-syntax-case. -; * In this file, we generate that Klister code using intermediate-syntax-case. -; * intermediate-syntax-case is defined using racket-syntax-case, and expands -; to Klister code which uses raw-syntax-case. -; -; * In the generated Klister code, fancy-quasiquote is defined using -; raw-syntax-case and {append,cons,pair}-list-syntax. -; * In this file, we generate that Klister code using intermediate-quasiquote. -; * intermediate-quasiquote is defined using racket-syntax-case. +; Racket does have convenient syntax-manipulating macros like match and +; quasiquote. -; (intermediate-define-keywords (foo bar)) +; (generate-define-keywords (list 'foo 'bar)) ; => ; '(raw-define-macros ; ([foo @@ -37,32 +21,29 @@ ; [bar ; (lambda (raw-stx) ; (syntax-error '"bar used out of context" raw-stx))])) -(racket-define-syntax (intermediate-define-keywords racket-stx) - (racket-syntax-case racket-stx () - [(_ (keyword racket-...)) - (let* ([error-message - (lambda (symbol) - (string-append (symbol->string symbol) - " used out of context"))] - [undefined-macro - (lambda (symbol) - #`[#,symbol - (lambda (raw-stx) - (syntax-error '#,(error-message symbol) raw-stx))])] - [symbols - (syntax->datum #'(keyword racket-...))] - [undefined-macros - (map undefined-macro symbols)]) - #``(raw-define-macros - (#,@undefined-macros)))])) +(define (generate-define-keywords keywords) + (let* ([error-message + (lambda (symbol) + (string-append (symbol->string symbol) + " used out of context"))] + [undefined-macro + (lambda (keyword) + `[,keyword + (lambda (raw-stx) + (syntax-error ',(error-message keyword) raw-stx))])] + [undefined-macros + (map undefined-macro keywords)]) + `(raw-define-macros + ,undefined-macros))) -; (intermediate-syntax-case raw-stx (keyword) -; [() -; 'rhs1] -; [((a b) (c d)) -; 'rhs2] -; [(keyword tail intermediate-...) -; 'rhs3]) +; (generate-syntax-case 'my-macro 'raw-stx (list 'keyword) +; (list +; (cons '() +; 'rhs1) +; (cons '((a b) (c d)) +; 'rhs2) +; (cons '(keyword tail ...) +; 'rhs3))) ; => ; '(let [failure-cc ; (lambda () @@ -83,7 +64,7 @@ ; [(cons ab cd-nil) ; (raw-syntax-case ab ; [(cons a b-nil) -; (... rhs2)] +; (...etc... rhs2)] ; [_ (failure-cc)])] ; [_ (failure-cc)]))] ; (let [failure-cc @@ -92,133 +73,114 @@ ; [() rhs1] ; [_ (failure-cc)]))] ; (failure-cc))))) -(racket-define-syntax (intermediate-syntax-case racket-stx) - (racket-syntax-case racket-stx () - [(_ intermediate-stx (keyword racket-...) - cases racket-...) - (letrec ([symbols - (syntax->datum #'(keyword racket-...))] - [intermediate-expand-case - (lambda (scrutinee-name intermediate-case-stx) - (racket-syntax-case intermediate-case-stx (intermediate-...) - [[() rhs] - #``(raw-syntax-case #,scrutinee-name - [() ,rhs] - [_ (failure-cc)])] - [[x rhs] - (and (identifier? #'x) - (member (syntax->datum #'x) symbols)) - #``(>>= (free-identifier=? #,scrutinee-name 'x) - (lambda (same-identifier) - (if same-identifier - ,rhs - (failure-cc))))] - [[x rhs] - (identifier? #'x) - #``(let [x #,scrutinee-name] - ,rhs)] - [[(x intermediate-...) rhs] - #``(let [x #,scrutinee-name] - ,rhs)] - [[(intermediate-head intermediate-tail racket-...) rhs] +(define (generate-syntax-case macro-name stx-name keywords cases) + (letrec ([generate-case + (lambda (scrutinee-name case) + (match case + [(cons pat rhs) + (match pat + [`() + `(raw-syntax-case ,scrutinee-name + [() ,rhs] + [_ (failure-cc)])] + [x + #:when (and (symbol? x) + (member x keywords)) + `(>>= (free-identifier=? ,scrutinee-name ',x) + (lambda (same-identifier) + (if same-identifier + ,rhs + (failure-cc))))] + [x + #:when (symbol? x) + `(let [,x ,scrutinee-name] + ,rhs)] + [`(,x ,'...) + `(let [,x ,scrutinee-name] + ,rhs)] + [`(,pat-head ,@pat-tail) (let ([head-name (gensym 'head-)] [tail-name (gensym 'tail-)]) - #``(raw-syntax-case #,scrutinee-name - [(cons #,head-name #,tail-name) - ,#,(intermediate-expand-case head-name - #`[intermediate-head - #,(intermediate-expand-case tail-name - #`[(intermediate-tail racket-...) rhs])])] - [_ (failure-cc)]))]))] - [intermediate-expand-cases - (lambda (intermediate-cases-stx) - (racket-syntax-case intermediate-cases-stx (intermediate-...) - [() - #``(failure-cc)] - [(cases racket-... case) - #``(let [failure-cc - (lambda () - ,#,(intermediate-expand-case #'intermediate-stx #'case))] - ,#,(intermediate-expand-cases #'(cases racket-...)))]))]) - #``(let [failure-cc - (lambda () - (syntax-error - '#,(string-append - (symbol->string (syntax->datum #'macro-name)) - " call has invalid syntax") - intermediate-stx))] - ,#,(intermediate-expand-cases #'(cases racket-...))))])) + `(raw-syntax-case ,scrutinee-name + [(cons ,head-name ,tail-name) + ,(generate-case head-name + (cons pat-head + (generate-case tail-name + (cons pat-tail rhs))))] + [_ (failure-cc)]))])]))] + [generate-cases + (lambda (cases) + (match cases + ['() + `(failure-cc)] + [`(,@(list cases ...) ,case) + `(let [failure-cc + (lambda () + ,(generate-case stx-name case))] + ,(generate-cases cases))]))]) + `(let [failure-cc + (lambda () + (syntax-error + ',(string-append + (symbol->string macro-name) + " call has invalid syntax") + ,stx-name))] + ,(generate-cases cases)))) -(define-syntax (intermediate-define-syntax2 intermediate-stx) - (syntax-case intermediate-stx () - [(_ (macro-name intermediate-stx) (keyword racket-...) - case racket-...) - #'`(group - ,(intermediate-define-keywords (keyword racket-...)) - (define-macros - ([macro-name - (lambda (intermediate-stx) - ,(intermediate-syntax-case intermediate-stx (keyword racket-...) - case racket-...))])))])) +(define (generate-define-syntax macro-name stx-name keywords cases) + `(group + ,(generate-define-keywords keywords) + (define-macros + ([,macro-name + (lambda (,stx-name) + ,(generate-syntax-case macro-name stx-name keywords + cases))])))) ; `(1 ,(list 2 3) ,@(list 4 5) 6) ; => ; '(1 (2 3) 4 5 6) ; -; (intermediate-quasiquote1 -; (1 -; (intermediate-unquote '(2 3)) -; '(4 5) intermediate-... -; 6) -; raw-stx) +; (generate-quasiquote +; '(1 +; ,'(2 3) +; ,'(4 5) ... +; 6) +; 'raw-stx) ; => -; '(cons-list-syntax 1 -; (cons-list-syntax '(2 3) -; (append-list-syntax '(4 5) -; (cons-list-syntax 6 -; '() +; '(pair-list-syntax 'quote +; (cons-list-syntax 1 +; (cons-list-syntax '(2 3) +; (append-list-syntax '(4 5) +; (cons-list-syntax 6 +; '() +; raw-stx) ; raw-stx) ; raw-stx) ; raw-stx) ; raw-stx) ; => -; (1 (2 3) 4 5 6) -(define-syntax (intermediate-quasiquote1 racket-stx) - (racket-syntax-case racket-stx (intermediate-unquote intermediate-...) - [(_ ((intermediate-unquote head) tail racket-...) intermediate-stx) - #'`(cons-list-syntax - head - ,(intermediate-quasiquote1 (tail racket-...) intermediate-stx) - intermediate-stx)] - [(_ (head intermediate-... tail racket-...) intermediate-stx) - #'`(append-list-syntax - head - ,(intermediate-quasiquote1 (tail racket-...) intermediate-stx) - intermediate-stx)] - [(_ (head tail racket-...) intermediate-stx) - #'`(cons-list-syntax - ,(intermediate-quasiquote1 head intermediate-stx) - ,(intermediate-quasiquote1 (tail racket-...) intermediate-stx) - intermediate-stx)] - [(_ x intermediate-stx) - #'''x])) - -; (intermediate-quasiquote2 -; (1 -; (intermediate-unquote '(2 3)) -; '(4 5) intermediate-... -; 6) -; raw-stx) -; => -; ... -; => ; '(1 (2 3) 4 5 6) -(define-syntax (intermediate-quasiquote2 racket-stx) - (racket-syntax-case racket-stx () - [(_ e intermediate-stx) - #'`(pair-list-syntax 'quote - ,(intermediate-quasiquote1 e intermediate-stx) - intermediate-stx)])) +(define (generate-quasiquote pat stx-name) + (letrec ([go + (lambda (pat) + (match pat + [`(,'unquote ,head) + head] + [`((,'unquote ,head) ,'... ,@tail) + `(append-list-syntax + ,head + ,(go tail) + ,stx-name)] + [`(,head ,@tail) + `(cons-list-syntax + ,(go head) + ,(go tail) + ,stx-name)] + [x + `(quote ,x)]))]) + `(pair-list-syntax 'quote + ,(go pat) + ,stx-name))) (void @@ -251,10 +213,20 @@ '(import (rename (shift "prelude.kl" 1) [syntax-case raw-syntax-case])) - (intermediate-define-syntax2 (my-macro raw-stx) (keyword) - [(_ ((a b) (c d))) - `(pure ,(intermediate-quasiquote2 (a b c d) raw-stx))] - [(_ (foo tail intermediate-...)) - `(pure (pair-list-syntax 'quote tail raw-stx))]) + (generate-define-syntax 'my-macro 'raw-stx (list 'keyword) + (list + (cons '(_ ((a b) (c d))) + `(pure ,(generate-quasiquote + '(,a ,b ,c ,d) + 'raw-stx))) + (cons '(_ (keyword tail ...)) + `(pure ,(generate-quasiquote + '(keyword-prefixed ,tail ... end-of-list) + 'raw-stx))) + (cons '(_ (e ...)) + `(pure ,(generate-quasiquote + '(ordinary-list ,e ... end-of-list) + 'raw-stx))))) '(example (my-macro ((1 2) (3 4)))) - '(example (my-macro (keyword foo bar)))))))))) + '(example (my-macro (keyword bar baz))) + '(example (my-macro (foo bar baz)))))))))) diff --git a/examples/dot-dot-dot.golden b/examples/dot-dot-dot.golden index 635fd625..2b409895 100644 --- a/examples/dot-dot-dot.golden +++ b/examples/dot-dot-dot.golden @@ -1,2 +1,3 @@ -#[dot-dot-dot.kl:170.10-170.34]<(a b c d)> : Syntax -#[dot-dot-dot.kl:172.20-172.37]<(foo bar)> : Syntax +#[dot-dot-dot.kl:220.10-220.34]<(1 2 3 4)> : Syntax +#[dot-dot-dot.kl:222.10-222.38]<(keyword-prefixed bar baz end-of-list)> : Syntax +#[dot-dot-dot.kl:224.10-224.34]<(ordinary-list foo bar baz end-of-list)> : Syntax diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index 7b7448cb..5148d316 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -24,42 +24,41 @@ (let (failure-cc (lambda () (syntax-error - '"macro-name call has invalid syntax" + '"my-macro call has invalid syntax" raw-stx))) (let (failure-cc (lambda () (raw-syntax-case raw-stx ((cons - head-163 - tail-164) - (let (_ head-163) + head-120 + tail-121) + (let (_ head-120) (raw-syntax-case - tail-164 + tail-121 ((cons - head-165 - tail-166) - (raw-syntax-case - head-165 - ((cons - head-167 - tail-168) - (let (foo - head-167) - (let (tail - tail-168) - (raw-syntax-case - tail-166 - (() - (pure - (pair-list-syntax - 'quote - tail - raw-stx))) - (_ - (failure-cc)))))) - (_ - (failure-cc)))) + head-122 + tail-123) + (let (e head-122) + (raw-syntax-case + tail-123 + (() + (pure + (pair-list-syntax + 'quote + (cons-list-syntax + 'ordinary-list + (append-list-syntax + e + (cons-list-syntax + 'end-of-list + '() + raw-stx) + raw-stx) + raw-stx) + raw-stx))) + (_ + (failure-cc))))) (_ (failure-cc))))) (_ (failure-cc))))) (let (failure-cc @@ -67,106 +66,159 @@ (raw-syntax-case raw-stx ((cons - head-169 - tail-170) - (let (_ head-169) + head-124 + tail-125) + (let (_ head-124) (raw-syntax-case - tail-170 + tail-125 ((cons - head-171 - tail-172) + head-126 + tail-127) + (raw-syntax-case + head-126 + ((cons + head-128 + tail-129) + (>>= + (free-identifier=? + head-128 + 'keyword) + (lambda (same-identifier) + (if same-identifier + (let (tail + tail-129) + (raw-syntax-case + tail-127 + (() + (pure + (pair-list-syntax + 'quote + (cons-list-syntax + 'keyword-prefixed + (append-list-syntax + tail + (cons-list-syntax + 'end-of-list + '() + raw-stx) + raw-stx) + raw-stx) + raw-stx))) + (_ + (failure-cc)))) + (failure-cc))))) + (_ + (failure-cc)))) + (_ + (failure-cc))))) + (_ (failure-cc))))) + (let (failure-cc + (lambda () + (raw-syntax-case + raw-stx + ((cons + head-130 + tail-131) + (let (_ head-130) (raw-syntax-case - head-171 + tail-131 ((cons - head-173 - tail-174) + head-132 + tail-133) (raw-syntax-case - head-173 + head-132 ((cons - head-181 - tail-182) - (let (a - head-181) - (raw-syntax-case - tail-182 - ((cons - head-183 - tail-184) - (let (b - head-183) - (raw-syntax-case - tail-184 - (() + head-134 + tail-135) + (raw-syntax-case + head-134 + ((cons + head-142 + tail-143) + (let (a + head-142) + (raw-syntax-case + tail-143 + ((cons + head-144 + tail-145) + (let (b + head-144) (raw-syntax-case - tail-174 - ((cons - head-175 - tail-176) + tail-145 + (() (raw-syntax-case - head-175 + tail-135 ((cons - head-177 - tail-178) - (let (c - head-177) - (raw-syntax-case - tail-178 - ((cons - head-179 - tail-180) - (let (d - head-179) - (raw-syntax-case - tail-180 - (() + head-136 + tail-137) + (raw-syntax-case + head-136 + ((cons + head-138 + tail-139) + (let (c + head-138) + (raw-syntax-case + tail-139 + ((cons + head-140 + tail-141) + (let (d + head-140) (raw-syntax-case - tail-176 + tail-141 (() (raw-syntax-case - tail-172 + tail-137 (() - (pure - (pair-list-syntax - 'quote - (cons-list-syntax - 'a - (cons-list-syntax - 'b + (raw-syntax-case + tail-133 + (() + (pure + (pair-list-syntax + 'quote (cons-list-syntax - 'c + a (cons-list-syntax - 'd - '() + b + (cons-list-syntax + c + (cons-list-syntax + d + '() + raw-stx) + raw-stx) raw-stx) raw-stx) - raw-stx) - raw-stx) - raw-stx))) + raw-stx))) + (_ + (failure-cc)))) (_ (failure-cc)))) (_ - (failure-cc)))) - (_ - (failure-cc))))) - (_ - (failure-cc))))) + (failure-cc))))) + (_ + (failure-cc))))) + (_ + (failure-cc)))) (_ (failure-cc)))) (_ - (failure-cc)))) - (_ - (failure-cc))))) - (_ - (failure-cc))))) + (failure-cc))))) + (_ + (failure-cc))))) + (_ + (failure-cc)))) (_ (failure-cc)))) (_ - (failure-cc)))) - (_ - (failure-cc))))) - (_ (failure-cc))))) - (failure-cc))))))))) + (failure-cc))))) + (_ (failure-cc))))) + (failure-cc)))))))))) (example (my-macro ((1 2) (3 4)))) -(example (my-macro (keyword foo bar))) +(example (my-macro (keyword bar baz))) + +(example (my-macro (foo bar baz))) From 81ca047f11efccc508bc3f6ab0f8b5bc68a93dd5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sun, 11 Oct 2020 17:58:12 -0400 Subject: [PATCH 14/35] use the same syntax in generate-syntax-case and -quasiquote --- bootstrap.rkt | 35 ++++- examples/dot-dot-dot.golden | 6 +- examples/dot-dot-dot.kl | 276 ++++++++++++++++++------------------ 3 files changed, 167 insertions(+), 150 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 32a9dea1..a97cbfce 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -40,9 +40,9 @@ ; (list ; (cons '() ; 'rhs1) -; (cons '((a b) (c d)) +; (cons '((,a ,b) (,c ,d)) ; 'rhs2) -; (cons '(keyword tail ...) +; (cons '(keyword ,tail ...) ; 'rhs3))) ; => ; '(let [failure-cc @@ -83,6 +83,8 @@ `(raw-syntax-case ,scrutinee-name [() ,rhs] [_ (failure-cc)])] + [`_ + rhs] [x #:when (and (symbol? x) (member x keywords)) @@ -91,13 +93,32 @@ (if same-identifier ,rhs (failure-cc))))] - [x + [`(,'unquote ,x) #:when (symbol? x) `(let [,x ,scrutinee-name] ,rhs)] - [`(,x ,'...) + [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] ,rhs)] + [`(,e ,'...) + (raise-arguments-error + 'generate-syntax-case + "the syntax for ellipsis is '(,x ...)" + "got" `(,e ...))] [`(,pat-head ,@pat-tail) (let ([head-name (gensym 'head-)] [tail-name (gensym 'tail-)]) @@ -215,15 +236,15 @@ (generate-define-syntax 'my-macro 'raw-stx (list 'keyword) (list - (cons '(_ ((a b) (c d))) + (cons '(_ ((,a ,b) (,c ,d))) `(pure ,(generate-quasiquote '(,a ,b ,c ,d) 'raw-stx))) - (cons '(_ (keyword tail ...)) + (cons '(_ (keyword ,tail ...)) `(pure ,(generate-quasiquote '(keyword-prefixed ,tail ... end-of-list) 'raw-stx))) - (cons '(_ (e ...)) + (cons '(_ (,e ...)) `(pure ,(generate-quasiquote '(ordinary-list ,e ... end-of-list) 'raw-stx))))) diff --git a/examples/dot-dot-dot.golden b/examples/dot-dot-dot.golden index 2b409895..89a5c3fb 100644 --- a/examples/dot-dot-dot.golden +++ b/examples/dot-dot-dot.golden @@ -1,3 +1,3 @@ -#[dot-dot-dot.kl:220.10-220.34]<(1 2 3 4)> : Syntax -#[dot-dot-dot.kl:222.10-222.38]<(keyword-prefixed bar baz end-of-list)> : Syntax -#[dot-dot-dot.kl:224.10-224.34]<(ordinary-list foo bar baz end-of-list)> : Syntax +#[dot-dot-dot.kl:216.10-216.34]<(1 2 3 4)> : Syntax +#[dot-dot-dot.kl:218.10-218.38]<(keyword-prefixed bar baz end-of-list)> : Syntax +#[dot-dot-dot.kl:220.10-220.34]<(ordinary-list foo bar baz end-of-list)> : Syntax diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index 5148d316..d4e30814 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -31,189 +31,185 @@ (raw-syntax-case raw-stx ((cons - head-120 - tail-121) - (let (_ head-120) - (raw-syntax-case - tail-121 - ((cons - head-122 - tail-123) - (let (e head-122) - (raw-syntax-case - tail-123 - (() - (pure - (pair-list-syntax - 'quote + head-123 + tail-124) + (raw-syntax-case + tail-124 + ((cons + head-125 + tail-126) + (let (e head-125) + (raw-syntax-case + tail-126 + (() + (pure + (pair-list-syntax + 'quote + (cons-list-syntax + 'ordinary-list + (append-list-syntax + e (cons-list-syntax - 'ordinary-list - (append-list-syntax - e - (cons-list-syntax - 'end-of-list - '() - raw-stx) - raw-stx) + 'end-of-list + '() raw-stx) - raw-stx))) - (_ - (failure-cc))))) - (_ (failure-cc))))) + raw-stx) + raw-stx) + raw-stx))) + (_ + (failure-cc))))) + (_ (failure-cc)))) (_ (failure-cc))))) (let (failure-cc (lambda () (raw-syntax-case raw-stx ((cons - head-124 - tail-125) - (let (_ head-124) + head-127 + tail-128) + (raw-syntax-case + tail-128 + ((cons + head-129 + tail-130) (raw-syntax-case - tail-125 + head-129 ((cons - head-126 - tail-127) - (raw-syntax-case - head-126 - ((cons - head-128 - tail-129) - (>>= - (free-identifier=? - head-128 - 'keyword) - (lambda (same-identifier) - (if same-identifier - (let (tail - tail-129) - (raw-syntax-case - tail-127 - (() - (pure - (pair-list-syntax - 'quote + head-131 + tail-132) + (>>= + (free-identifier=? + head-131 + 'keyword) + (lambda (same-identifier) + (if same-identifier + (let (tail + tail-132) + (raw-syntax-case + tail-130 + (() + (pure + (pair-list-syntax + 'quote + (cons-list-syntax + 'keyword-prefixed + (append-list-syntax + tail (cons-list-syntax - 'keyword-prefixed - (append-list-syntax - tail - (cons-list-syntax - 'end-of-list - '() - raw-stx) - raw-stx) + 'end-of-list + '() raw-stx) - raw-stx))) - (_ - (failure-cc)))) - (failure-cc))))) - (_ - (failure-cc)))) + raw-stx) + raw-stx) + raw-stx))) + (_ + (failure-cc)))) + (failure-cc))))) (_ - (failure-cc))))) + (failure-cc)))) + (_ (failure-cc)))) (_ (failure-cc))))) (let (failure-cc (lambda () (raw-syntax-case raw-stx ((cons - head-130 - tail-131) - (let (_ head-130) + head-133 + tail-134) + (raw-syntax-case + tail-134 + ((cons + head-135 + tail-136) (raw-syntax-case - tail-131 + head-135 ((cons - head-132 - tail-133) + head-137 + tail-138) (raw-syntax-case - head-132 + head-137 ((cons - head-134 - tail-135) - (raw-syntax-case - head-134 - ((cons - head-142 - tail-143) - (let (a - head-142) - (raw-syntax-case - tail-143 - ((cons - head-144 - tail-145) - (let (b - head-144) + head-145 + tail-146) + (let (a + head-145) + (raw-syntax-case + tail-146 + ((cons + head-147 + tail-148) + (let (b + head-147) + (raw-syntax-case + tail-148 + (() (raw-syntax-case - tail-145 - (() + tail-138 + ((cons + head-139 + tail-140) (raw-syntax-case - tail-135 + head-139 ((cons - head-136 - tail-137) - (raw-syntax-case - head-136 - ((cons - head-138 - tail-139) - (let (c - head-138) - (raw-syntax-case - tail-139 - ((cons - head-140 - tail-141) - (let (d - head-140) + head-141 + tail-142) + (let (c + head-141) + (raw-syntax-case + tail-142 + ((cons + head-143 + tail-144) + (let (d + head-143) + (raw-syntax-case + tail-144 + (() (raw-syntax-case - tail-141 + tail-140 (() (raw-syntax-case - tail-137 + tail-136 (() - (raw-syntax-case - tail-133 - (() - (pure - (pair-list-syntax - 'quote + (pure + (pair-list-syntax + 'quote + (cons-list-syntax + a + (cons-list-syntax + b (cons-list-syntax - a + c (cons-list-syntax - b - (cons-list-syntax - c - (cons-list-syntax - d - '() - raw-stx) - raw-stx) + d + '() raw-stx) raw-stx) - raw-stx))) - (_ - (failure-cc)))) + raw-stx) + raw-stx) + raw-stx))) (_ (failure-cc)))) (_ - (failure-cc))))) - (_ - (failure-cc))))) - (_ - (failure-cc)))) + (failure-cc)))) + (_ + (failure-cc))))) + (_ + (failure-cc))))) (_ (failure-cc)))) (_ - (failure-cc))))) - (_ - (failure-cc))))) - (_ - (failure-cc)))) + (failure-cc)))) + (_ + (failure-cc))))) + (_ + (failure-cc))))) (_ (failure-cc)))) (_ - (failure-cc))))) + (failure-cc)))) + (_ + (failure-cc)))) (_ (failure-cc))))) (failure-cc)))))))))) From 4453feddabb9329b25dd7a35e70425736615a9be Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sun, 11 Oct 2020 20:04:25 -0400 Subject: [PATCH 15/35] =?UTF-8?q?only=20compare=20identifiers=20with=20fre?= =?UTF-8?q?e-identifier=3D=3F?= I thought comparing an identifier with a number would give False, but instead it fails with a runtime error. --- bootstrap.rkt | 32 ++++++++++++--------- examples/dot-dot-dot.golden | 6 ++-- examples/dot-dot-dot.kl | 57 ++++++++++++++++++++----------------- 3 files changed, 53 insertions(+), 42 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index a97cbfce..c8af5eb6 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -52,11 +52,14 @@ ; (lambda () ; (raw-syntax-case raw-stx ; [(cons head tail) -; (>>= (free-identifier=? head 'keyword) -; (lambda (same-identifier) -; (if same-identifier -; rhs3 -; (failure-cc))))] +; (raw-syntax-case head +; [(idenx x) +; (>>= (free-identifier=? head 'keyword) +; (lambda (same-identifier) +; (if same-identifier +; rhs3 +; (failure-cc))))] +; [_ (failure-cc)])] ; [_ (failure-cc)]))] ; (let [failure-cc ; (lambda () @@ -85,14 +88,17 @@ [_ (failure-cc)])] [`_ rhs] - [x - #:when (and (symbol? x) - (member x keywords)) - `(>>= (free-identifier=? ,scrutinee-name ',x) - (lambda (same-identifier) - (if same-identifier - ,rhs - (failure-cc))))] + [keyword + #:when (and (symbol? keyword) + (member keyword keywords)) + `(raw-syntax-case ,scrutinee-name + [(ident x) + (>>= (free-identifier=? x ',keyword) + (lambda (same-identifier) + (if same-identifier + ,rhs + (failure-cc))))] + [_ (failure-cc)])] [`(,'unquote ,x) #:when (symbol? x) `(let [,x ,scrutinee-name] diff --git a/examples/dot-dot-dot.golden b/examples/dot-dot-dot.golden index 89a5c3fb..78fab688 100644 --- a/examples/dot-dot-dot.golden +++ b/examples/dot-dot-dot.golden @@ -1,3 +1,3 @@ -#[dot-dot-dot.kl:216.10-216.34]<(1 2 3 4)> : Syntax -#[dot-dot-dot.kl:218.10-218.38]<(keyword-prefixed bar baz end-of-list)> : Syntax -#[dot-dot-dot.kl:220.10-220.34]<(ordinary-list foo bar baz end-of-list)> : Syntax +#[dot-dot-dot.kl:221.10-221.34]<(1 2 3 4)> : Syntax +#[dot-dot-dot.kl:223.10-223.38]<(keyword-prefixed bar baz end-of-list)> : Syntax +#[dot-dot-dot.kl:225.10-225.34]<(ordinary-list foo bar baz end-of-list)> : Syntax diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index d4e30814..2d53be85 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -77,34 +77,39 @@ ((cons head-131 tail-132) - (>>= - (free-identifier=? - head-131 - 'keyword) - (lambda (same-identifier) - (if same-identifier - (let (tail - tail-132) - (raw-syntax-case - tail-130 - (() - (pure - (pair-list-syntax - 'quote - (cons-list-syntax - 'keyword-prefixed - (append-list-syntax - tail + (raw-syntax-case + head-131 + ((ident x) + (>>= + (free-identifier=? + x + 'keyword) + (lambda (same-identifier) + (if same-identifier + (let (tail + tail-132) + (raw-syntax-case + tail-130 + (() + (pure + (pair-list-syntax + 'quote (cons-list-syntax - 'end-of-list - '() + 'keyword-prefixed + (append-list-syntax + tail + (cons-list-syntax + 'end-of-list + '() + raw-stx) + raw-stx) raw-stx) - raw-stx) - raw-stx) - raw-stx))) - (_ - (failure-cc)))) - (failure-cc))))) + raw-stx))) + (_ + (failure-cc)))) + (failure-cc))))) + (_ + (failure-cc)))) (_ (failure-cc)))) (_ (failure-cc)))) From 165fc3eadfcfb4320d57dd91726b634f6d6fc1a8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sun, 11 Oct 2020 20:48:49 -0400 Subject: [PATCH 16/35] expose generate-quasiquote helper this will be useful when implementing fancy-quasiquote --- bootstrap.rkt | 64 ++++++++++++++++++++++++++++++--------------------- 1 file changed, 38 insertions(+), 26 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index c8af5eb6..d2c0f717 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -167,6 +167,41 @@ ; => ; '(1 (2 3) 4 5 6) ; +; (generate-quasiquote-inside +; '(1 +; ,'(2 3) +; ,'(4 5) ... +; 6) +; 'raw-stx) +; => +; '(cons-list-syntax 1 +; (cons-list-syntax '(2 3) +; (append-list-syntax '(4 5) +; (cons-list-syntax 6 +; '() +; raw-stx) +; raw-stx) +; raw-stx) +; raw-stx) +; => +; (1 (2 3) 4 5 6) +(define (generate-quasiquote-inside pat stx-name) + (match pat + [`(,'unquote ,head) + head] + [`((,'unquote ,head) ,'... ,@tail) + `(append-list-syntax + ,head + ,(generate-quasiquote-inside tail stx-name) + ,stx-name)] + [`(,head ,@tail) + `(cons-list-syntax + ,(generate-quasiquote-inside head stx-name) + ,(generate-quasiquote-inside tail stx-name) + ,stx-name)] + [x + `(quote ,x)])) + ; (generate-quasiquote ; '(1 ; ,'(2 3) @@ -176,38 +211,15 @@ ; => ; '(pair-list-syntax 'quote ; (cons-list-syntax 1 -; (cons-list-syntax '(2 3) -; (append-list-syntax '(4 5) -; (cons-list-syntax 6 -; '() -; raw-stx) -; raw-stx) -; raw-stx) +; ...etc... ; raw-stx) ; raw-stx) ; => ; '(1 (2 3) 4 5 6) (define (generate-quasiquote pat stx-name) - (letrec ([go - (lambda (pat) - (match pat - [`(,'unquote ,head) - head] - [`((,'unquote ,head) ,'... ,@tail) - `(append-list-syntax - ,head - ,(go tail) - ,stx-name)] - [`(,head ,@tail) - `(cons-list-syntax - ,(go head) - ,(go tail) - ,stx-name)] - [x - `(quote ,x)]))]) `(pair-list-syntax 'quote - ,(go pat) - ,stx-name))) + ,(generate-quasiquote-inside pat stx-name) + ,stx-name)) (void From 68841e41e759fd54da3588397cd236bdf344a621 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sun, 11 Oct 2020 22:39:08 -0400 Subject: [PATCH 17/35] drop some raw- prefixes there is only one define-macros and one stx, no need to distinguish intermediate-stx from raw-stx from racket-stx. --- bootstrap.rkt | 52 ++++++++++++++++++------------------- examples/dot-dot-dot.golden | 6 ++--- examples/dot-dot-dot.kl | 46 +++++++++++++++----------------- 3 files changed, 49 insertions(+), 55 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index d2c0f717..cc135914 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -14,13 +14,13 @@ ; (generate-define-keywords (list 'foo 'bar)) ; => -; '(raw-define-macros +; '(define-macros ; ([foo -; (lambda (raw-stx) -; (syntax-error '"foo used out of context" raw-stx))] +; (lambda (stx) +; (syntax-error '"foo used out of context" stx))] ; [bar -; (lambda (raw-stx) -; (syntax-error '"bar used out of context" raw-stx))])) +; (lambda (stx) +; (syntax-error '"bar used out of context" stx))])) (define (generate-define-keywords keywords) (let* ([error-message (lambda (symbol) @@ -29,14 +29,14 @@ [undefined-macro (lambda (keyword) `[,keyword - (lambda (raw-stx) - (syntax-error ',(error-message keyword) raw-stx))])] + (lambda (stx) + (syntax-error ',(error-message keyword) stx))])] [undefined-macros (map undefined-macro keywords)]) - `(raw-define-macros + `(define-macros ,undefined-macros))) -; (generate-syntax-case 'my-macro 'raw-stx (list 'keyword) +; (generate-syntax-case 'my-macro 'stx (list 'keyword) ; (list ; (cons '() ; 'rhs1) @@ -47,10 +47,10 @@ ; => ; '(let [failure-cc ; (lambda () -; (syntax-error '"my-macro call has invalid syntax" raw-stx))] +; (syntax-error '"my-macro call has invalid syntax" stx))] ; (let [failure-cc ; (lambda () -; (raw-syntax-case raw-stx +; (raw-syntax-case stx ; [(cons head tail) ; (raw-syntax-case head ; [(idenx x) @@ -63,7 +63,7 @@ ; [_ (failure-cc)]))] ; (let [failure-cc ; (lambda () -; (raw-syntax-case raw-stx +; (raw-syntax-case stx ; [(cons ab cd-nil) ; (raw-syntax-case ab ; [(cons a b-nil) @@ -72,7 +72,7 @@ ; [_ (failure-cc)]))] ; (let [failure-cc ; (lambda () -; (raw-syntax-case raw-stx +; (raw-syntax-case stx ; [() rhs1] ; [_ (failure-cc)]))] ; (failure-cc))))) @@ -172,17 +172,17 @@ ; ,'(2 3) ; ,'(4 5) ... ; 6) -; 'raw-stx) +; 'stx) ; => ; '(cons-list-syntax 1 ; (cons-list-syntax '(2 3) ; (append-list-syntax '(4 5) ; (cons-list-syntax 6 ; '() -; raw-stx) -; raw-stx) -; raw-stx) -; raw-stx) +; stx) +; stx) +; stx) +; stx) ; => ; (1 (2 3) 4 5 6) (define (generate-quasiquote-inside pat stx-name) @@ -207,13 +207,13 @@ ; ,'(2 3) ; ,'(4 5) ... ; 6) -; 'raw-stx) +; 'stx) ; => ; '(pair-list-syntax 'quote ; (cons-list-syntax 1 ; ...etc... -; raw-stx) -; raw-stx) +; stx) +; stx) ; => ; '(1 (2 3) 4 5 6) (define (generate-quasiquote pat stx-name) @@ -246,26 +246,24 @@ (newline) (writeln form)) (list - '(import (rename "prelude.kl" - [define-macros raw-define-macros])) '(import (shift "list-syntax.kl" 1)) '(import (rename (shift "prelude.kl" 1) [syntax-case raw-syntax-case])) - (generate-define-syntax 'my-macro 'raw-stx (list 'keyword) + (generate-define-syntax 'my-macro 'stx (list 'keyword) (list (cons '(_ ((,a ,b) (,c ,d))) `(pure ,(generate-quasiquote '(,a ,b ,c ,d) - 'raw-stx))) + 'stx))) (cons '(_ (keyword ,tail ...)) `(pure ,(generate-quasiquote '(keyword-prefixed ,tail ... end-of-list) - 'raw-stx))) + 'stx))) (cons '(_ (,e ...)) `(pure ,(generate-quasiquote '(ordinary-list ,e ... end-of-list) - 'raw-stx))))) + 'stx))))) '(example (my-macro ((1 2) (3 4)))) '(example (my-macro (keyword bar baz))) '(example (my-macro (foo bar baz)))))))))) diff --git a/examples/dot-dot-dot.golden b/examples/dot-dot-dot.golden index 78fab688..597ea29e 100644 --- a/examples/dot-dot-dot.golden +++ b/examples/dot-dot-dot.golden @@ -1,3 +1,3 @@ -#[dot-dot-dot.kl:221.10-221.34]<(1 2 3 4)> : Syntax -#[dot-dot-dot.kl:223.10-223.38]<(keyword-prefixed bar baz end-of-list)> : Syntax -#[dot-dot-dot.kl:225.10-225.34]<(ordinary-list foo bar baz end-of-list)> : Syntax +#[dot-dot-dot.kl:217.10-217.34]<(1 2 3 4)> : Syntax +#[dot-dot-dot.kl:219.10-219.38]<(keyword-prefixed bar baz end-of-list)> : Syntax +#[dot-dot-dot.kl:221.10-221.34]<(ordinary-list foo bar baz end-of-list)> : Syntax diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index 2d53be85..617feede 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -1,10 +1,6 @@ #lang "prelude.kl" -- GENERATED BY ../bootstrap.rkt, DO NOT EDIT -(import (rename "prelude.kl" - (define-macros - raw-define-macros))) - (import (shift "list-syntax.kl" 1)) (import (rename (shift "prelude.kl" 1) @@ -12,24 +8,24 @@ raw-syntax-case))) (group - (raw-define-macros + (define-macros ((keyword - (lambda (raw-stx) + (lambda (stx) (syntax-error '"keyword used out of context" - raw-stx))))) + stx))))) (define-macros ((my-macro - (lambda (raw-stx) + (lambda (stx) (let (failure-cc (lambda () (syntax-error '"my-macro call has invalid syntax" - raw-stx))) + stx))) (let (failure-cc (lambda () (raw-syntax-case - raw-stx + stx ((cons head-123 tail-124) @@ -52,10 +48,10 @@ (cons-list-syntax 'end-of-list '() - raw-stx) - raw-stx) - raw-stx) - raw-stx))) + stx) + stx) + stx) + stx))) (_ (failure-cc))))) (_ (failure-cc)))) @@ -63,7 +59,7 @@ (let (failure-cc (lambda () (raw-syntax-case - raw-stx + stx ((cons head-127 tail-128) @@ -101,10 +97,10 @@ (cons-list-syntax 'end-of-list '() - raw-stx) - raw-stx) - raw-stx) - raw-stx))) + stx) + stx) + stx) + stx))) (_ (failure-cc)))) (failure-cc))))) @@ -117,7 +113,7 @@ (let (failure-cc (lambda () (raw-syntax-case - raw-stx + stx ((cons head-133 tail-134) @@ -188,11 +184,11 @@ (cons-list-syntax d '() - raw-stx) - raw-stx) - raw-stx) - raw-stx) - raw-stx))) + stx) + stx) + stx) + stx) + stx))) (_ (failure-cc)))) (_ From bec8e4d06ff4f90e9f9d095a43517b3936b22c51 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sun, 11 Oct 2020 22:56:45 -0400 Subject: [PATCH 18/35] fancy-quasiquote --- bootstrap.rkt | 83 +++++--- examples/dot-dot-dot.golden | 4 +- examples/dot-dot-dot.kl | 396 +++++++++++++++++++----------------- 3 files changed, 273 insertions(+), 210 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index cc135914..1726744a 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -91,14 +91,15 @@ [keyword #:when (and (symbol? keyword) (member keyword keywords)) - `(raw-syntax-case ,scrutinee-name - [(ident x) - (>>= (free-identifier=? x ',keyword) - (lambda (same-identifier) - (if same-identifier - ,rhs - (failure-cc))))] - [_ (failure-cc)])] + (let ([ident-name (gensym 'ident)]) + `(raw-syntax-case ,scrutinee-name + [(ident ,ident-name) + (>>= (free-identifier=? ,ident-name ',keyword) + (lambda (same-identifier) + (if same-identifier + ,rhs + (failure-cc))))] + [_ (failure-cc)]))] [`(,'unquote ,x) #:when (symbol? x) `(let [,x ,scrutinee-name] @@ -246,24 +247,58 @@ (newline) (writeln form)) (list + '(import "list-syntax.kl") '(import (shift "list-syntax.kl" 1)) '(import (rename (shift "prelude.kl" 1) [syntax-case raw-syntax-case])) - (generate-define-syntax 'my-macro 'stx (list 'keyword) + (generate-define-keywords (list 'fancy-unquote 'fancy-...)) + (generate-define-syntax 'fancy-quasiquote 'stx '() (list - (cons '(_ ((,a ,b) (,c ,d))) - `(pure ,(generate-quasiquote - '(,a ,b ,c ,d) - 'stx))) - (cons '(_ (keyword ,tail ...)) - `(pure ,(generate-quasiquote - '(keyword-prefixed ,tail ... end-of-list) - 'stx))) - (cons '(_ (,e ...)) - `(pure ,(generate-quasiquote - '(ordinary-list ,e ... end-of-list) - 'stx))))) - '(example (my-macro ((1 2) (3 4)))) - '(example (my-macro (keyword bar baz))) - '(example (my-macro (foo bar baz)))))))))) + (cons '(_ ,pat) + `(let [stx-name ''here] + (flet (go (pat) + ,(generate-syntax-case 'fancy-quasiquote 'pat (list 'fancy-unquote 'fancy-...) + (list + (cons '(fancy-unquote ,x) + '(pure x)) + (cons '((fancy-unquote ,head) fancy-... ,tail ...) + `(>>= (go tail) + (lambda (inside-tail) + (pure ,(generate-quasiquote-inside + '(append-list-syntax + ,head + ,inside-tail + ,stx-name) + 'stx))))) + (cons '(,head ,tail ...) + `(>>= (go head) + (lambda (inside-head) + (>>= (go tail) + (lambda (inside-tail) + (pure ,(generate-quasiquote-inside + '(cons-list-syntax + ,inside-head + ,inside-tail + ,stx-name) + 'stx))))))) + (cons ',x + `(pure (pair-list-syntax + 'quote + x + stx)))))) + (>>= (go pat) + (lambda (inside) + (pure inside)))))))) + '(example + (fancy-quasiquote + (1 + (fancy-unquote '(2 3)) + (fancy-unquote '(4 5)) fancy-... + 6))) + '(export (rename ([fancy-quasiquote quasiquote] + [fancy-unquote unquote] + [fancy-... ...]) + fancy-quasiquote + fancy-unquote + fancy-...))))))))) diff --git a/examples/dot-dot-dot.golden b/examples/dot-dot-dot.golden index 597ea29e..10dd4a63 100644 --- a/examples/dot-dot-dot.golden +++ b/examples/dot-dot-dot.golden @@ -1,3 +1 @@ -#[dot-dot-dot.kl:217.10-217.34]<(1 2 3 4)> : Syntax -#[dot-dot-dot.kl:219.10-219.38]<(keyword-prefixed bar baz end-of-list)> : Syntax -#[dot-dot-dot.kl:221.10-221.34]<(ordinary-list foo bar baz end-of-list)> : Syntax +#[dot-dot-dot.kl:51.33-51.37]<(1 (2 3) 4 5 6)> : Syntax diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index 617feede..59c7f3f2 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -1,221 +1,251 @@ #lang "prelude.kl" -- GENERATED BY ../bootstrap.rkt, DO NOT EDIT +(import "list-syntax.kl") + (import (shift "list-syntax.kl" 1)) (import (rename (shift "prelude.kl" 1) (syntax-case raw-syntax-case))) +(define-macros + ((fancy-unquote + (lambda (stx) + (syntax-error + '"fancy-unquote used out of context" + stx))) + (fancy-... + (lambda (stx) + (syntax-error + '"fancy-... used out of context" + stx))))) + (group + (define-macros ()) (define-macros - ((keyword - (lambda (stx) - (syntax-error - '"keyword used out of context" - stx))))) - (define-macros - ((my-macro + ((fancy-quasiquote (lambda (stx) (let (failure-cc (lambda () (syntax-error - '"my-macro call has invalid syntax" + '"fancy-quasiquote call has invalid syntax" stx))) (let (failure-cc (lambda () (raw-syntax-case stx ((cons - head-123 - tail-124) + head-140 + tail-141) (raw-syntax-case - tail-124 + tail-141 ((cons - head-125 - tail-126) - (let (e head-125) + head-142 + tail-143) + (let (pat head-142) (raw-syntax-case - tail-126 + tail-143 (() - (pure - (pair-list-syntax - 'quote - (cons-list-syntax - 'ordinary-list - (append-list-syntax - e - (cons-list-syntax - 'end-of-list - '() - stx) - stx) - stx) - stx))) - (_ - (failure-cc))))) - (_ (failure-cc)))) - (_ (failure-cc))))) - (let (failure-cc - (lambda () - (raw-syntax-case - stx - ((cons - head-127 - tail-128) - (raw-syntax-case - tail-128 - ((cons - head-129 - tail-130) - (raw-syntax-case - head-129 - ((cons - head-131 - tail-132) - (raw-syntax-case - head-131 - ((ident x) - (>>= - (free-identifier=? - x - 'keyword) - (lambda (same-identifier) - (if same-identifier - (let (tail - tail-132) - (raw-syntax-case - tail-130 - (() - (pure - (pair-list-syntax - 'quote - (cons-list-syntax - 'keyword-prefixed - (append-list-syntax - tail - (cons-list-syntax - 'end-of-list - '() - stx) - stx) - stx) - stx))) - (_ - (failure-cc)))) - (failure-cc))))) - (_ - (failure-cc)))) - (_ - (failure-cc)))) - (_ (failure-cc)))) - (_ (failure-cc))))) - (let (failure-cc - (lambda () - (raw-syntax-case - stx - ((cons - head-133 - tail-134) - (raw-syntax-case - tail-134 - ((cons - head-135 - tail-136) - (raw-syntax-case - head-135 - ((cons - head-137 - tail-138) - (raw-syntax-case - head-137 - ((cons - head-145 - tail-146) - (let (a - head-145) - (raw-syntax-case - tail-146 - ((cons - head-147 - tail-148) - (let (b - head-147) - (raw-syntax-case - tail-148 - (() - (raw-syntax-case - tail-138 - ((cons - head-139 - tail-140) - (raw-syntax-case - head-139 - ((cons - head-141 - tail-142) - (let (c - head-141) - (raw-syntax-case - tail-142 - ((cons - head-143 - tail-144) - (let (d - head-143) - (raw-syntax-case - tail-144 - (() - (raw-syntax-case - tail-140 - (() - (raw-syntax-case - tail-136 - (() + (let (stx-name + ''here) + (flet + (go + (pat) + (let (failure-cc + (lambda () + (syntax-error + '"fancy-quasiquote call has invalid syntax" + pat))) + (let (failure-cc + (lambda () + (let (x + pat) + (pure + (pair-list-syntax + 'quote + x + stx))))) + (let (failure-cc + (lambda () + (raw-syntax-case + pat + ((cons + head-123 + tail-124) + (let (head + head-123) + (let (tail + tail-124) + (>>= + (go + head) + (lambda (inside-head) + (>>= + (go + tail) + (lambda (inside-tail) (pure - (pair-list-syntax - 'quote + (cons-list-syntax + 'cons-list-syntax (cons-list-syntax - a + inside-head (cons-list-syntax - b + inside-tail (cons-list-syntax - c - (cons-list-syntax - d - '() - stx) + stx-name + '() stx) stx) stx) - stx))) - (_ - (failure-cc)))) - (_ - (failure-cc)))) + stx))))))))) + (_ + (failure-cc))))) + (let (failure-cc + (lambda () + (raw-syntax-case + pat + ((cons + head-125 + tail-126) + (raw-syntax-case + head-125 + ((cons + head-130 + tail-131) + (raw-syntax-case + head-130 + ((ident + ident134) + (>>= + (free-identifier=? + ident134 + 'fancy-unquote) + (lambda (same-identifier) + (if same-identifier + (raw-syntax-case + tail-131 + ((cons + head-132 + tail-133) + (let (head + head-132) + (raw-syntax-case + tail-133 + (() + (raw-syntax-case + tail-126 + ((cons + head-127 + tail-128) + (raw-syntax-case + head-127 + ((ident + ident129) + (>>= + (free-identifier=? + ident129 + 'fancy-...) + (lambda (same-identifier) + (if same-identifier + (let (tail + tail-128) + (>>= + (go + 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))))) + (_ + (failure-cc)))) + (_ + (failure-cc)))) + (_ + (failure-cc))))) + (_ + (failure-cc))) + (failure-cc))))) (_ - (failure-cc))))) + (failure-cc)))) + (_ + (failure-cc)))) (_ (failure-cc))))) - (_ - (failure-cc)))) - (_ - (failure-cc)))) - (_ - (failure-cc))))) - (_ - (failure-cc))))) - (_ - (failure-cc)))) - (_ - (failure-cc)))) + (let (failure-cc + (lambda () + (raw-syntax-case + pat + ((cons + head-135 + tail-136) + (raw-syntax-case + head-135 + ((ident + ident139) + (>>= + (free-identifier=? + ident139 + 'fancy-unquote) + (lambda (same-identifier) + (if same-identifier + (raw-syntax-case + tail-136 + ((cons + head-137 + tail-138) + (let (x + head-137) + (raw-syntax-case + tail-138 + (() + (pure + x)) + (_ + (failure-cc))))) + (_ + (failure-cc))) + (failure-cc))))) + (_ + (failure-cc)))) + (_ + (failure-cc))))) + (failure-cc))))))) + (>>= + (go pat) + (lambda (inside) + (pure + inside)))))) (_ - (failure-cc)))) - (_ (failure-cc))))) - (failure-cc)))))))))) - -(example (my-macro ((1 2) (3 4)))) + (failure-cc))))) + (_ (failure-cc)))) + (_ (failure-cc))))) + (failure-cc)))))))) -(example (my-macro (keyword bar baz))) +(example + (fancy-quasiquote + (1 + (fancy-unquote '(2 3)) + (fancy-unquote '(4 5)) + fancy-... + 6))) -(example (my-macro (foo bar baz))) +(export (rename ((fancy-quasiquote + quasiquote) + (fancy-unquote unquote) + (fancy-... ...)) + fancy-quasiquote + fancy-unquote + fancy-...)) From 2b176d15ff3bac123645d2ff4faa97f9f7eb9d35 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Mon, 12 Oct 2020 00:09:57 -0400 Subject: [PATCH 19/35] use the loc of the `(...) not the loc of the implementation of quasiquote --- bootstrap.rkt | 4 +++- examples/dot-dot-dot.golden | 2 +- examples/dot-dot-dot.kl | 7 ++++++- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 1726744a..5b05ea07 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -256,7 +256,9 @@ (generate-define-syntax 'fancy-quasiquote 'stx '() (list (cons '(_ ,pat) - `(let [stx-name ''here] + `(let [stx-name ,(generate-quasiquote + ',(replace-loc pat 'here) + ''here)] (flet (go (pat) ,(generate-syntax-case 'fancy-quasiquote 'pat (list 'fancy-unquote 'fancy-...) (list diff --git a/examples/dot-dot-dot.golden b/examples/dot-dot-dot.golden index 10dd4a63..4756a8b2 100644 --- a/examples/dot-dot-dot.golden +++ b/examples/dot-dot-dot.golden @@ -1 +1 @@ -#[dot-dot-dot.kl:51.33-51.37]<(1 (2 3) 4 5 6)> : Syntax +#[dot-dot-dot.kl:244.3-248.6]<(1 (2 3) 4 5 6)> : Syntax diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index 59c7f3f2..d524df0d 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -48,7 +48,12 @@ tail-143 (() (let (stx-name - ''here) + (pair-list-syntax + 'quote + (replace-loc + pat + 'here) + 'here)) (flet (go (pat) From 6bf4c3ba0ccc23cb84e218e21f590a05bcd7a504 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Mon, 12 Oct 2020 00:47:15 -0400 Subject: [PATCH 20/35] simplify macros using fancy-quasiquote the old quasiquote didn't support splicing-in lists, so we had to use cons-list-syntax instead. --- examples/bool.kl | 8 +++----- examples/do.kl | 34 ++++++++++++++++++---------------- 2 files changed, 21 insertions(+), 21 deletions(-) diff --git a/examples/bool.kl b/examples/bool.kl index 5eaf5afc..f49c8933 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) @@ -23,8 +23,7 @@ (() (pure '(true))) ((cons x xs) - (pure `(binary-and ,x - ,(cons-list-syntax 'and xs stx))))))))) + (pure `(binary-and ,x (and ,xs ...))))))))) (or (lambda (stx) (syntax-case stx ((cons _ args) @@ -32,8 +31,7 @@ (() (pure '(false))) ((cons x xs) - (pure `(binary-or ,x - ,(cons-list-syntax 'or xs stx))))))))))) + (pure `(binary-or ,x (or ,xs ...))))))))))) (example (binary-and (false) (false))) (example (binary-and (false) (true))) diff --git a/examples/do.kl b/examples/do.kl index 97f2ef9b..347363df 100644 --- a/examples/do.kl +++ b/examples/do.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)) (import (shift "let.kl" 1)) (define-macros @@ -14,27 +14,29 @@ -- (>>= (bar x) (lambda (_) -- (>>= (baz x) (lambda (y) -- (quux x y))))))) - ((<- + ([<- (lambda (stx) - (syntax-error (quote "<- used out of context") stx))) - (do (lambda (stx) + (syntax-error (quote "<- used out of context") stx))] + [do (lambda (stx) (syntax-case stx - ((cons _ all-actions) + [(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)))))) + [(list (last-action)) + (pure last-action)] + [(cons first-action actions) + (let ([otherwise (pure `(>>= ,first-action + (lambda (_) + (do ,actions ...))))]) (syntax-case first-action - ((list (var <-? action)) + [(list (var <-? action)) (>>= (free-identifier=? '<- <-?) (lambda (isArrow) (if isArrow - (pure `(>>= ,action (lambda (,var) - ,(cons-list-syntax 'do actions stx)))) - otherwise)))) - (_ - otherwise))))))))))) + (pure `(>>= ,action + (lambda (,var) + (do ,actions ...)))) + otherwise)))] + [_ + otherwise]))])]))])) (export <- do) From bb50c7cde1f0075587a7cf897b95b267b0fdfda0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Mon, 12 Oct 2020 14:06:40 -0400 Subject: [PATCH 21/35] simplify fancy-quasiquote --- bootstrap.rkt | 12 +++++------- examples/dot-dot-dot.kl | 15 ++++++--------- 2 files changed, 11 insertions(+), 16 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 5b05ea07..7303a08a 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -259,13 +259,13 @@ `(let [stx-name ,(generate-quasiquote ',(replace-loc pat 'here) ''here)] - (flet (go (pat) + (flet (fancy-inside (pat) ,(generate-syntax-case 'fancy-quasiquote 'pat (list 'fancy-unquote 'fancy-...) (list (cons '(fancy-unquote ,x) '(pure x)) (cons '((fancy-unquote ,head) fancy-... ,tail ...) - `(>>= (go tail) + `(>>= (fancy-inside tail) (lambda (inside-tail) (pure ,(generate-quasiquote-inside '(append-list-syntax @@ -274,9 +274,9 @@ ,stx-name) 'stx))))) (cons '(,head ,tail ...) - `(>>= (go head) + `(>>= (fancy-inside head) (lambda (inside-head) - (>>= (go tail) + (>>= (fancy-inside tail) (lambda (inside-tail) (pure ,(generate-quasiquote-inside '(cons-list-syntax @@ -289,9 +289,7 @@ 'quote x stx)))))) - (>>= (go pat) - (lambda (inside) - (pure inside)))))))) + (fancy-inside pat)))))) '(example (fancy-quasiquote (1 diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index d524df0d..cd2fa58c 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -55,7 +55,7 @@ 'here) 'here)) (flet - (go + (fancy-inside (pat) (let (failure-cc (lambda () @@ -83,11 +83,11 @@ (let (tail tail-124) (>>= - (go + (fancy-inside head) (lambda (inside-head) (>>= - (go + (fancy-inside tail) (lambda (inside-tail) (pure @@ -156,7 +156,7 @@ (let (tail tail-128) (>>= - (go + (fancy-inside tail) (lambda (inside-tail) (pure @@ -228,11 +228,8 @@ (_ (failure-cc))))) (failure-cc))))))) - (>>= - (go pat) - (lambda (inside) - (pure - inside)))))) + (fancy-inside + pat)))) (_ (failure-cc))))) (_ (failure-cc)))) From 80366b048966b7f99be9febe1cb95897af1bf195 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Mon, 12 Oct 2020 20:40:23 -0400 Subject: [PATCH 22/35] avoid capturing 'failure-cc' --- bootstrap.rkt | 21 +++--- examples/dot-dot-dot.golden | 2 +- examples/dot-dot-dot.kl | 137 ++++++++++++++++++------------------ 3 files changed, 81 insertions(+), 79 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 7303a08a..e0e748e4 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -77,7 +77,8 @@ ; [_ (failure-cc)]))] ; (failure-cc))))) (define (generate-syntax-case macro-name stx-name keywords cases) - (letrec ([generate-case + (letrec ([failure-cc-name (gensym 'failure-cc-)] + [generate-case (lambda (scrutinee-name case) (match case [(cons pat rhs) @@ -85,7 +86,7 @@ [`() `(raw-syntax-case ,scrutinee-name [() ,rhs] - [_ (failure-cc)])] + [_ (,failure-cc-name)])] [`_ rhs] [keyword @@ -98,8 +99,8 @@ (lambda (same-identifier) (if same-identifier ,rhs - (failure-cc))))] - [_ (failure-cc)]))] + (,failure-cc-name))))] + [_ (,failure-cc-name)]))] [`(,'unquote ,x) #:when (symbol? x) `(let [,x ,scrutinee-name] @@ -135,18 +136,18 @@ (cons pat-head (generate-case tail-name (cons pat-tail rhs))))] - [_ (failure-cc)]))])]))] + [_ (,failure-cc-name)]))])]))] [generate-cases (lambda (cases) (match cases ['() - `(failure-cc)] + `(,failure-cc-name)] [`(,@(list cases ...) ,case) - `(let [failure-cc + `(let [,failure-cc-name (lambda () ,(generate-case stx-name case))] ,(generate-cases cases))]))]) - `(let [failure-cc + `(let [,failure-cc-name (lambda () (syntax-error ',(string-append @@ -188,8 +189,8 @@ ; (1 (2 3) 4 5 6) (define (generate-quasiquote-inside pat stx-name) (match pat - [`(,'unquote ,head) - head] + [`(,'unquote ,x) + x] [`((,'unquote ,head) ,'... ,@tail) `(append-list-syntax ,head diff --git a/examples/dot-dot-dot.golden b/examples/dot-dot-dot.golden index 4756a8b2..8416caf8 100644 --- a/examples/dot-dot-dot.golden +++ b/examples/dot-dot-dot.golden @@ -1 +1 @@ -#[dot-dot-dot.kl:244.3-248.6]<(1 (2 3) 4 5 6)> : Syntax +#[dot-dot-dot.kl:242.3-246.6]<(1 (2 3) 4 5 6)> : Syntax diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index cd2fa58c..82456ba5 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -26,26 +26,26 @@ (define-macros ((fancy-quasiquote (lambda (stx) - (let (failure-cc + (let (failure-cc-141 (lambda () (syntax-error '"fancy-quasiquote call has invalid syntax" stx))) - (let (failure-cc + (let (failure-cc-141 (lambda () (raw-syntax-case stx ((cons - head-140 - tail-141) + head-142 + tail-143) (raw-syntax-case - tail-141 + tail-143 ((cons - head-142 - tail-143) - (let (pat head-142) + head-144 + tail-145) + (let (pat head-144) (raw-syntax-case - tail-143 + tail-145 (() (let (stx-name (pair-list-syntax @@ -57,12 +57,12 @@ (flet (fancy-inside (pat) - (let (failure-cc + (let (failure-cc-123 (lambda () (syntax-error '"fancy-quasiquote call has invalid syntax" pat))) - (let (failure-cc + (let (failure-cc-123 (lambda () (let (x pat) @@ -71,17 +71,17 @@ 'quote x stx))))) - (let (failure-cc + (let (failure-cc-123 (lambda () (raw-syntax-case pat ((cons - head-123 - tail-124) + head-124 + tail-125) (let (head - head-123) + head-124) (let (tail - tail-124) + tail-125) (>>= (fancy-inside head) @@ -105,56 +105,56 @@ stx) stx))))))))) (_ - (failure-cc))))) - (let (failure-cc + (failure-cc-123))))) + (let (failure-cc-123 (lambda () (raw-syntax-case pat ((cons - head-125 - tail-126) + head-126 + tail-127) (raw-syntax-case - head-125 + head-126 ((cons - head-130 - tail-131) + head-131 + tail-132) (raw-syntax-case - head-130 + head-131 ((ident - ident134) + ident135) (>>= (free-identifier=? - ident134 + ident135 'fancy-unquote) (lambda (same-identifier) (if same-identifier (raw-syntax-case - tail-131 + tail-132 ((cons - head-132 - tail-133) + head-133 + tail-134) (let (head - head-132) + head-133) (raw-syntax-case - tail-133 + tail-134 (() (raw-syntax-case - tail-126 + tail-127 ((cons - head-127 - tail-128) + head-128 + tail-129) (raw-syntax-case - head-127 + head-128 ((ident - ident129) + ident130) (>>= (free-identifier=? - ident129 + ident130 'fancy-...) (lambda (same-identifier) (if same-identifier (let (tail - tail-128) + tail-129) (>>= (fancy-inside tail) @@ -173,68 +173,69 @@ stx) stx) stx))))) - (failure-cc))))) + (failure-cc-123))))) (_ - (failure-cc)))) + (failure-cc-123)))) (_ - (failure-cc)))) + (failure-cc-123)))) (_ - (failure-cc))))) + (failure-cc-123))))) (_ - (failure-cc))) - (failure-cc))))) + (failure-cc-123))) + (failure-cc-123))))) (_ - (failure-cc)))) + (failure-cc-123)))) (_ - (failure-cc)))) + (failure-cc-123)))) (_ - (failure-cc))))) - (let (failure-cc + (failure-cc-123))))) + (let (failure-cc-123 (lambda () (raw-syntax-case pat ((cons - head-135 - tail-136) + head-136 + tail-137) (raw-syntax-case - head-135 + head-136 ((ident - ident139) + ident140) (>>= (free-identifier=? - ident139 + ident140 'fancy-unquote) (lambda (same-identifier) (if same-identifier (raw-syntax-case - tail-136 + tail-137 ((cons - head-137 - tail-138) + head-138 + tail-139) (let (x - head-137) + head-138) (raw-syntax-case - tail-138 + tail-139 (() (pure x)) (_ - (failure-cc))))) + (failure-cc-123))))) (_ - (failure-cc))) - (failure-cc))))) + (failure-cc-123))) + (failure-cc-123))))) (_ - (failure-cc)))) + (failure-cc-123)))) (_ - (failure-cc))))) - (failure-cc))))))) + (failure-cc-123))))) + (failure-cc-123))))))) (fancy-inside pat)))) (_ - (failure-cc))))) - (_ (failure-cc)))) - (_ (failure-cc))))) - (failure-cc)))))))) + (failure-cc-141))))) + (_ + (failure-cc-141)))) + (_ (failure-cc-141))))) + (failure-cc-141)))))))) (example (fancy-quasiquote From 1335aa5816897691e917a41c55f3b23065186bf0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Mon, 12 Oct 2020 21:18:38 -0400 Subject: [PATCH 23/35] don't use the (,@(list xs ...) x) pattern given a list of N+1 elements, it assigns the first N to xs and the last one to x. This is convenient, but it doesn't generalize well: what if we had (,@(list xs ...) ,@(list ys ...)), which fraction should be assigned to which side? for this reason, generate-syntax-parse doesn't support this kind of pattern, and thus we cannot use it to implement fancy-syntax-parse. since generate-syntax-parse is used as a template demonstrating how to implement such a function, I've updated generated-syntax-parse to use the more reasonable pattern (x ,@xs). --- bootstrap.rkt | 17 ++--- examples/dot-dot-dot.kl | 136 ++++++++++++++++++++-------------------- 2 files changed, 77 insertions(+), 76 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index e0e748e4..004e9acb 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -138,15 +138,16 @@ (cons pat-tail rhs))))] [_ (,failure-cc-name)]))])]))] [generate-cases - (lambda (cases) + (lambda (cases inner) (match cases ['() - `(,failure-cc-name)] - [`(,@(list cases ...) ,case) - `(let [,failure-cc-name - (lambda () - ,(generate-case stx-name case))] - ,(generate-cases cases))]))]) + inner] + [`(,case ,@cases) + (generate-cases cases + `(let [,failure-cc-name + (lambda () + ,(generate-case stx-name case))] + ,inner))]))]) `(let [,failure-cc-name (lambda () (syntax-error @@ -154,7 +155,7 @@ (symbol->string macro-name) " call has invalid syntax") ,stx-name))] - ,(generate-cases cases)))) + ,(generate-cases cases `(,failure-cc-name))))) (define (generate-define-syntax macro-name stx-name keywords cases) `(group diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index 82456ba5..c5e59d99 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -26,26 +26,26 @@ (define-macros ((fancy-quasiquote (lambda (stx) - (let (failure-cc-141 + (let (failure-cc-139 (lambda () (syntax-error '"fancy-quasiquote call has invalid syntax" stx))) - (let (failure-cc-141 + (let (failure-cc-139 (lambda () (raw-syntax-case stx ((cons - head-142 - tail-143) + head-140 + tail-141) (raw-syntax-case - tail-143 + tail-141 ((cons - head-144 - tail-145) - (let (pat head-144) + head-142 + tail-143) + (let (pat head-142) (raw-syntax-case - tail-145 + tail-143 (() (let (stx-name (pair-list-syntax @@ -57,12 +57,12 @@ (flet (fancy-inside (pat) - (let (failure-cc-123 + (let (failure-cc-121 (lambda () (syntax-error '"fancy-quasiquote call has invalid syntax" pat))) - (let (failure-cc-123 + (let (failure-cc-121 (lambda () (let (x pat) @@ -71,17 +71,17 @@ 'quote x stx))))) - (let (failure-cc-123 + (let (failure-cc-121 (lambda () (raw-syntax-case pat ((cons - head-124 - tail-125) + head-137 + tail-138) (let (head - head-124) + head-137) (let (tail - tail-125) + tail-138) (>>= (fancy-inside head) @@ -105,56 +105,56 @@ stx) stx))))))))) (_ - (failure-cc-123))))) - (let (failure-cc-123 + (failure-cc-121))))) + (let (failure-cc-121 (lambda () (raw-syntax-case pat ((cons - head-126 - tail-127) + head-127 + tail-128) (raw-syntax-case - head-126 + head-127 ((cons - head-131 - tail-132) + head-132 + tail-133) (raw-syntax-case - head-131 + head-132 ((ident - ident135) + ident136) (>>= (free-identifier=? - ident135 + ident136 'fancy-unquote) (lambda (same-identifier) (if same-identifier (raw-syntax-case - tail-132 + tail-133 ((cons - head-133 - tail-134) + head-134 + tail-135) (let (head - head-133) + head-134) (raw-syntax-case - tail-134 + tail-135 (() (raw-syntax-case - tail-127 + tail-128 ((cons - head-128 - tail-129) + head-129 + tail-130) (raw-syntax-case - head-128 + head-129 ((ident - ident130) + ident131) (>>= (free-identifier=? - ident130 + ident131 'fancy-...) (lambda (same-identifier) (if same-identifier (let (tail - tail-129) + tail-130) (>>= (fancy-inside tail) @@ -173,69 +173,69 @@ stx) stx) stx))))) - (failure-cc-123))))) + (failure-cc-121))))) (_ - (failure-cc-123)))) + (failure-cc-121)))) (_ - (failure-cc-123)))) + (failure-cc-121)))) (_ - (failure-cc-123))))) + (failure-cc-121))))) (_ - (failure-cc-123))) - (failure-cc-123))))) + (failure-cc-121))) + (failure-cc-121))))) (_ - (failure-cc-123)))) + (failure-cc-121)))) (_ - (failure-cc-123)))) + (failure-cc-121)))) (_ - (failure-cc-123))))) - (let (failure-cc-123 + (failure-cc-121))))) + (let (failure-cc-121 (lambda () (raw-syntax-case pat ((cons - head-136 - tail-137) + head-122 + tail-123) (raw-syntax-case - head-136 + head-122 ((ident - ident140) + ident126) (>>= (free-identifier=? - ident140 + ident126 'fancy-unquote) (lambda (same-identifier) (if same-identifier (raw-syntax-case - tail-137 + tail-123 ((cons - head-138 - tail-139) + head-124 + tail-125) (let (x - head-138) + head-124) (raw-syntax-case - tail-139 + tail-125 (() (pure x)) (_ - (failure-cc-123))))) + (failure-cc-121))))) (_ - (failure-cc-123))) - (failure-cc-123))))) + (failure-cc-121))) + (failure-cc-121))))) (_ - (failure-cc-123)))) + (failure-cc-121)))) (_ - (failure-cc-123))))) - (failure-cc-123))))))) + (failure-cc-121))))) + (failure-cc-121))))))) (fancy-inside pat)))) (_ - (failure-cc-141))))) + (failure-cc-139))))) (_ - (failure-cc-141)))) - (_ (failure-cc-141))))) - (failure-cc-141)))))))) + (failure-cc-139)))) + (_ (failure-cc-139))))) + (failure-cc-139)))))))) (example (fancy-quasiquote From 2b09cd58558b4bf1eed6bd2066104206652dc34a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Thu, 15 Oct 2020 09:39:13 -0400 Subject: [PATCH 24/35] drop generate-quasiquote it is easy to emulate using generate-quasiquote-inside, and it is not nearly as useful as generate-quasiquote-inside. --- bootstrap.rkt | 23 ++--------------------- examples/dot-dot-dot.golden | 2 +- examples/dot-dot-dot.kl | 9 ++++++--- 3 files changed, 9 insertions(+), 25 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 004e9acb..f521559c 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -205,25 +205,6 @@ [x `(quote ,x)])) -; (generate-quasiquote -; '(1 -; ,'(2 3) -; ,'(4 5) ... -; 6) -; 'stx) -; => -; '(pair-list-syntax 'quote -; (cons-list-syntax 1 -; ...etc... -; stx) -; stx) -; => -; '(1 (2 3) 4 5 6) -(define (generate-quasiquote pat stx-name) - `(pair-list-syntax 'quote - ,(generate-quasiquote-inside pat stx-name) - ,stx-name)) - (void (call-with-output-file @@ -258,8 +239,8 @@ (generate-define-syntax 'fancy-quasiquote 'stx '() (list (cons '(_ ,pat) - `(let [stx-name ,(generate-quasiquote - ',(replace-loc pat 'here) + `(let [stx-name ,(generate-quasiquote-inside + '',(replace-loc pat 'here) ''here)] (flet (fancy-inside (pat) ,(generate-syntax-case 'fancy-quasiquote 'pat (list 'fancy-unquote 'fancy-...) diff --git a/examples/dot-dot-dot.golden b/examples/dot-dot-dot.golden index 8416caf8..aacc47ba 100644 --- a/examples/dot-dot-dot.golden +++ b/examples/dot-dot-dot.golden @@ -1 +1 @@ -#[dot-dot-dot.kl:242.3-246.6]<(1 (2 3) 4 5 6)> : Syntax +#[dot-dot-dot.kl:245.3-249.6]<(1 (2 3) 4 5 6)> : Syntax diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index c5e59d99..b71294bc 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -48,10 +48,13 @@ tail-143 (() (let (stx-name - (pair-list-syntax + (cons-list-syntax 'quote - (replace-loc - pat + (cons-list-syntax + (replace-loc + pat + 'here) + '() 'here) 'here)) (flet From 6b438e5a87b3eab29abc73311a0d74a8a8a61d6d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Thu, 15 Oct 2020 09:40:43 -0400 Subject: [PATCH 25/35] rename generate-quasiquote-inside to generate-quasiquote there's only one function left, might as well give it the simpler name. --- bootstrap.rkt | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index f521559c..dca49bc8 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -170,7 +170,7 @@ ; => ; '(1 (2 3) 4 5 6) ; -; (generate-quasiquote-inside +; (generate-quasiquote ; '(1 ; ,'(2 3) ; ,'(4 5) ... @@ -187,20 +187,20 @@ ; stx) ; stx) ; => -; (1 (2 3) 4 5 6) -(define (generate-quasiquote-inside pat stx-name) +; '(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-inside tail stx-name) + ,(generate-quasiquote tail stx-name) ,stx-name)] [`(,head ,@tail) `(cons-list-syntax - ,(generate-quasiquote-inside head stx-name) - ,(generate-quasiquote-inside tail stx-name) + ,(generate-quasiquote head stx-name) + ,(generate-quasiquote tail stx-name) ,stx-name)] [x `(quote ,x)])) @@ -239,7 +239,7 @@ (generate-define-syntax 'fancy-quasiquote 'stx '() (list (cons '(_ ,pat) - `(let [stx-name ,(generate-quasiquote-inside + `(let [stx-name ,(generate-quasiquote '',(replace-loc pat 'here) ''here)] (flet (fancy-inside (pat) @@ -250,7 +250,7 @@ (cons '((fancy-unquote ,head) fancy-... ,tail ...) `(>>= (fancy-inside tail) (lambda (inside-tail) - (pure ,(generate-quasiquote-inside + (pure ,(generate-quasiquote '(append-list-syntax ,head ,inside-tail @@ -261,7 +261,7 @@ (lambda (inside-head) (>>= (fancy-inside tail) (lambda (inside-tail) - (pure ,(generate-quasiquote-inside + (pure ,(generate-quasiquote '(cons-list-syntax ,inside-head ,inside-tail From 58ef435aeca6c98b3519620abfeeb430c928ffe4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Thu, 15 Oct 2020 10:08:00 -0400 Subject: [PATCH 26/35] auto-splice simplifies code-generation. another alternative would have been to define, for each Klister form, a Racket macro which mimics that form and outputs racket code which constructs the Klister code for that form by taking Racket expressions producing the code for the arguments and splicing the results in the generated code for the form. That would require work proportional to the number of syntax forms in Klister, whereas the auto-splice approach only requires work proportional to the number of generate- functions defined in bootstrap.rkt, which is currently much smaller. --- bootstrap.rkt | 123 +++++++---- examples/dot-dot-dot.golden | 2 +- examples/dot-dot-dot.kl | 409 ++++++++++++++++++------------------ 3 files changed, 289 insertions(+), 245 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index dca49bc8..5392d872 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -1,5 +1,6 @@ #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 @@ -9,8 +10,8 @@ ; 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 and -; quasiquote. +; Racket does have convenient syntax-manipulating macros like match, +; quasiquote, and racket-syntax-case. ; (generate-define-keywords (list 'foo 'bar)) ; => @@ -206,6 +207,50 @@ `(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 +; (cons '() +; `(pure ''nil)) +; (cons '((,a ,b) (,c ,d)) +; `(let [quadruple ,(generate-quasiquote '(,a ,b ,c ,d) 'stx)] +; (pure ,(generate-quasiquote ''(four-elements ,quadruple) 'stx)))) +; (cons '(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-name (keyword ...) + [lhs rhs] ...)) + #'(generate-syntax-case 'macro-name 'stx-name (list 'keyword ...) + (list + (cons '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" @@ -236,43 +281,45 @@ [syntax-case raw-syntax-case])) (generate-define-keywords (list 'fancy-unquote 'fancy-...)) - (generate-define-syntax 'fancy-quasiquote 'stx '() - (list - (cons '(_ ,pat) - `(let [stx-name ,(generate-quasiquote - '',(replace-loc pat 'here) - ''here)] + (auto-splice + (define-macros + ([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 (list 'fancy-unquote 'fancy-...) - (list - (cons '(fancy-unquote ,x) - '(pure x)) - (cons '((fancy-unquote ,head) fancy-... ,tail ...) - `(>>= (fancy-inside tail) - (lambda (inside-tail) - (pure ,(generate-quasiquote - '(append-list-syntax - ,head - ,inside-tail - ,stx-name) - 'stx))))) - (cons '(,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))))))) - (cons ',x - `(pure (pair-list-syntax - 'quote - x - stx)))))) - (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)))]))]))) '(example (fancy-quasiquote (1 diff --git a/examples/dot-dot-dot.golden b/examples/dot-dot-dot.golden index aacc47ba..8416caf8 100644 --- a/examples/dot-dot-dot.golden +++ b/examples/dot-dot-dot.golden @@ -1 +1 @@ -#[dot-dot-dot.kl:245.3-249.6]<(1 (2 3) 4 5 6)> : Syntax +#[dot-dot-dot.kl:242.3-246.6]<(1 (2 3) 4 5 6)> : Syntax diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index b71294bc..8a11cc2c 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -21,224 +21,221 @@ '"fancy-... used out of context" stx))))) -(group - (define-macros ()) - (define-macros - ((fancy-quasiquote - (lambda (stx) - (let (failure-cc-139 - (lambda () - (syntax-error - '"fancy-quasiquote call has invalid syntax" - stx))) - (let (failure-cc-139 - (lambda () - (raw-syntax-case - stx - ((cons - head-140 - tail-141) - (raw-syntax-case - tail-141 - ((cons - head-142 - tail-143) - (let (pat head-142) - (raw-syntax-case - tail-143 - (() - (let (stx-name +(define-macros + ((fancy-quasiquote + (lambda (stx) + (let (failure-cc-174 + (lambda () + (syntax-error + '"fancy-quasiquote call has invalid syntax" + stx))) + (let (failure-cc-174 + (lambda () + (raw-syntax-case + stx + ((cons + head-175 + tail-176) + (raw-syntax-case + tail-176 + ((cons + head-177 + tail-178) + (let (pat head-177) + (raw-syntax-case + tail-178 + (() + (let (stx-name + (cons-list-syntax + 'quote (cons-list-syntax - 'quote - (cons-list-syntax - (replace-loc - pat - 'here) - '() + (replace-loc + pat 'here) - 'here)) - (flet - (fancy-inside - (pat) - (let (failure-cc-121 - (lambda () - (syntax-error - '"fancy-quasiquote call has invalid syntax" - pat))) - (let (failure-cc-121 - (lambda () - (let (x - pat) - (pure - (pair-list-syntax - 'quote - x - stx))))) - (let (failure-cc-121 - (lambda () - (raw-syntax-case - pat - ((cons - head-137 - tail-138) - (let (head - head-137) - (let (tail - tail-138) - (>>= - (fancy-inside - head) - (lambda (inside-head) - (>>= - (fancy-inside - tail) - (lambda (inside-tail) - (pure + '() + 'here) + 'here)) + (flet + (fancy-inside + (pat) + (let (failure-cc-156 + (lambda () + (syntax-error + '"fancy-quasiquote call has invalid syntax" + pat))) + (let (failure-cc-156 + (lambda () + (let (x + pat) + (pure + (pair-list-syntax + 'quote + x + stx))))) + (let (failure-cc-156 + (lambda () + (raw-syntax-case + pat + ((cons + head-172 + tail-173) + (let (head + head-172) + (let (tail + tail-173) + (>>= + (fancy-inside + head) + (lambda (inside-head) + (>>= + (fancy-inside + tail) + (lambda (inside-tail) + (pure + (cons-list-syntax + 'cons-list-syntax (cons-list-syntax - 'cons-list-syntax + inside-head (cons-list-syntax - inside-head + inside-tail (cons-list-syntax - inside-tail - (cons-list-syntax - stx-name - '() - stx) + stx-name + '() stx) stx) - stx))))))))) - (_ - (failure-cc-121))))) - (let (failure-cc-121 - (lambda () - (raw-syntax-case - pat - ((cons - head-127 - tail-128) - (raw-syntax-case - head-127 - ((cons - head-132 - tail-133) - (raw-syntax-case - head-132 - ((ident - ident136) - (>>= - (free-identifier=? - ident136 - 'fancy-unquote) - (lambda (same-identifier) - (if same-identifier - (raw-syntax-case - tail-133 - ((cons - head-134 - tail-135) - (let (head - head-134) - (raw-syntax-case - tail-135 - (() - (raw-syntax-case - tail-128 - ((cons - head-129 - tail-130) - (raw-syntax-case - head-129 - ((ident - ident131) - (>>= - (free-identifier=? - ident131 - 'fancy-...) - (lambda (same-identifier) - (if same-identifier - (let (tail - tail-130) - (>>= - (fancy-inside - tail) - (lambda (inside-tail) - (pure + stx) + stx))))))))) + (_ + (failure-cc-156))))) + (let (failure-cc-156 + (lambda () + (raw-syntax-case + pat + ((cons + head-162 + tail-163) + (raw-syntax-case + head-162 + ((cons + head-167 + tail-168) + (raw-syntax-case + head-167 + ((ident + ident171) + (>>= + (free-identifier=? + ident171 + 'fancy-unquote) + (lambda (same-identifier) + (if same-identifier + (raw-syntax-case + tail-168 + ((cons + head-169 + tail-170) + (let (head + head-169) + (raw-syntax-case + tail-170 + (() + (raw-syntax-case + tail-163 + ((cons + head-164 + tail-165) + (raw-syntax-case + head-164 + ((ident + ident166) + (>>= + (free-identifier=? + ident166 + 'fancy-...) + (lambda (same-identifier) + (if same-identifier + (let (tail + tail-165) + (>>= + (fancy-inside + tail) + (lambda (inside-tail) + (pure + (cons-list-syntax + 'append-list-syntax (cons-list-syntax - 'append-list-syntax + head (cons-list-syntax - head + inside-tail (cons-list-syntax - inside-tail - (cons-list-syntax - stx-name - '() - stx) + stx-name + '() stx) stx) - stx))))) - (failure-cc-121))))) - (_ - (failure-cc-121)))) - (_ - (failure-cc-121)))) - (_ - (failure-cc-121))))) - (_ - (failure-cc-121))) - (failure-cc-121))))) - (_ - (failure-cc-121)))) - (_ - (failure-cc-121)))) - (_ - (failure-cc-121))))) - (let (failure-cc-121 - (lambda () - (raw-syntax-case - pat - ((cons - head-122 - tail-123) - (raw-syntax-case - head-122 - ((ident - ident126) - (>>= - (free-identifier=? - ident126 - 'fancy-unquote) - (lambda (same-identifier) - (if same-identifier - (raw-syntax-case - tail-123 - ((cons - head-124 - tail-125) - (let (x - head-124) - (raw-syntax-case - tail-125 - (() - (pure - x)) - (_ - (failure-cc-121))))) - (_ - (failure-cc-121))) - (failure-cc-121))))) - (_ - (failure-cc-121)))) - (_ - (failure-cc-121))))) - (failure-cc-121))))))) - (fancy-inside - pat)))) - (_ - (failure-cc-139))))) - (_ - (failure-cc-139)))) - (_ (failure-cc-139))))) - (failure-cc-139)))))))) + stx) + stx))))) + (failure-cc-156))))) + (_ + (failure-cc-156)))) + (_ + (failure-cc-156)))) + (_ + (failure-cc-156))))) + (_ + (failure-cc-156))) + (failure-cc-156))))) + (_ + (failure-cc-156)))) + (_ + (failure-cc-156)))) + (_ + (failure-cc-156))))) + (let (failure-cc-156 + (lambda () + (raw-syntax-case + pat + ((cons + head-157 + tail-158) + (raw-syntax-case + head-157 + ((ident + ident161) + (>>= + (free-identifier=? + ident161 + 'fancy-unquote) + (lambda (same-identifier) + (if same-identifier + (raw-syntax-case + tail-158 + ((cons + head-159 + tail-160) + (let (x + head-159) + (raw-syntax-case + tail-160 + (() + (pure + x)) + (_ + (failure-cc-156))))) + (_ + (failure-cc-156))) + (failure-cc-156))))) + (_ + (failure-cc-156)))) + (_ + (failure-cc-156))))) + (failure-cc-156))))))) + (fancy-inside + pat)))) + (_ + (failure-cc-174))))) + (_ (failure-cc-174)))) + (_ (failure-cc-174))))) + (failure-cc-174))))))) (example (fancy-quasiquote From d7b8fbb6b3cc7e26e95545f8e008973cbdb16001 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sat, 17 Oct 2020 16:04:14 -0400 Subject: [PATCH 27/35] fancy-syntax-case --- bootstrap.rkt | 309 ++++++-- examples/bool.kl | 28 +- examples/do-keywords.golden | 0 examples/do-keywords.kl | 8 + examples/do.kl | 39 +- examples/dot-dot-dot-test-keywords.golden | 0 examples/dot-dot-dot-test-keywords.kl | 8 + examples/dot-dot-dot-test.golden | 3 + examples/dot-dot-dot-test.kl | 24 + examples/dot-dot-dot.golden | 1 - examples/dot-dot-dot.kl | 883 +++++++++++++++++++--- examples/free-identifier-case.kl | 8 +- examples/identifier.golden | 0 examples/identifier.kl | 9 + examples/pmatch.golden | 14 +- examples/pmatch.kl | 6 +- 16 files changed, 1111 insertions(+), 229 deletions(-) create mode 100644 examples/do-keywords.golden create mode 100644 examples/do-keywords.kl create mode 100644 examples/dot-dot-dot-test-keywords.golden create mode 100644 examples/dot-dot-dot-test-keywords.kl create mode 100644 examples/dot-dot-dot-test.golden create mode 100644 examples/dot-dot-dot-test.kl create mode 100644 examples/identifier.golden create mode 100644 examples/identifier.kl diff --git a/bootstrap.rkt b/bootstrap.rkt index 5392d872..6cf32e8b 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -39,11 +39,12 @@ ; (generate-syntax-case 'my-macro 'stx (list 'keyword) ; (list -; (cons '() +; (list '() ; 'rhs1) -; (cons '((,a ,b) (,c ,d)) +; (list '((,a ,b) (,c ,d)) ; 'rhs2) -; (cons '(keyword ,tail ...) +; (list '(keyword ,tail ...) +; '(> (length tail) 2) ; 'rhs3))) ; => ; '(let [failure-cc @@ -53,14 +54,15 @@ ; (lambda () ; (raw-syntax-case stx ; [(cons head tail) -; (raw-syntax-case head -; [(idenx x) -; (>>= (free-identifier=? head 'keyword) -; (lambda (same-identifier) -; (if same-identifier -; rhs3 -; (failure-cc))))] -; [_ (failure-cc)])] +; (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 () @@ -79,33 +81,40 @@ ; (failure-cc))))) (define (generate-syntax-case macro-name stx-name keywords cases) (letrec ([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 rhs) + [(cons pat guard-rhs) (match pat [`() `(raw-syntax-case ,scrutinee-name - [() ,rhs] + [() ,(generate-guard-rhs guard-rhs)] [_ (,failure-cc-name)])] [`_ - rhs] + (generate-guard-rhs guard-rhs)] [keyword #:when (and (symbol? keyword) (member keyword keywords)) - (let ([ident-name (gensym 'ident)]) - `(raw-syntax-case ,scrutinee-name - [(ident ,ident-name) - (>>= (free-identifier=? ,ident-name ',keyword) - (lambda (same-identifier) - (if same-identifier - ,rhs - (,failure-cc-name))))] - [_ (,failure-cc-name)]))] + `(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] - ,rhs)] + ,(generate-guard-rhs guard-rhs))] [x #:when (symbol? x) (raise-arguments-error @@ -122,21 +131,21 @@ "keywords" keywords)] [`((,'unquote ,x) ,'...) `(let [,x ,scrutinee-name] - ,rhs)] + ,(generate-guard-rhs guard-rhs))] [`(,e ,'...) (raise-arguments-error 'generate-syntax-case "the syntax for ellipsis is '(,x ...)" - "got" `(,e ...))] + "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 - (cons pat-head + (list pat-head (generate-case tail-name - (cons pat-tail rhs))))] + (cons pat-tail guard-rhs))))] [_ (,failure-cc-name)]))])]))] [generate-cases (lambda (cases inner) @@ -225,12 +234,12 @@ ; (lambda (stx) ; ,(generate-syntax-case 'my-macro 'stx (list 'keyword) ; (list -; (cons '() +; (list '() ; `(pure ''nil)) -; (cons '((,a ,b) (,c ,d)) +; (list '((,a ,b) (,c ,d)) ; `(let [quadruple ,(generate-quasiquote '(,a ,b ,c ,d) 'stx)] ; (pure ,(generate-quasiquote ''(four-elements ,quadruple) 'stx)))) -; (cons '(keyword ,tail ...) +; (list '(keyword ,tail ...) ; `(pure ,(generate-quasiquote ''(keyword-prefixed (,tail ...)) 'stx))))))])) (define-syntax (auto-splice stx) (racket-syntax-case stx (generate-quasiquote generate-syntax-case) @@ -239,11 +248,11 @@ [(_ (generate-quasiquote pat stx-name)) #'(generate-quasiquote 'pat 'stx-name)] [(_ (generate-syntax-case macro-name stx-name (keyword ...) - [lhs rhs] ...)) + [lhs rhs ...] ...)) #'(generate-syntax-case 'macro-name 'stx-name (list 'keyword ...) (list - (cons 'lhs - (auto-splice rhs)) + (list 'lhs + (auto-splice rhs) ...) ...))] [(_ (head tail ...)) #'(cons (auto-splice head) @@ -275,60 +284,208 @@ (newline) (writeln form)) (list - '(import "list-syntax.kl") - '(import (shift "list-syntax.kl" 1)) + '(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)) - (generate-define-keywords (list 'fancy-unquote 'fancy-...)) + (generate-define-keywords (list 'fancy-unquote 'fancy-... 'fancy-_)) (auto-splice (define-macros - ([fancy-quasiquote + ([fancy-syntax-case + (flet [list-of-keywords? (xs) + (generate-syntax-case fancy-syntax-case xs () + [() + (pure (true))] + [(,x ,xs ...) + (pure (identifier? x)) + (list-of-keywords? xs)] + [_ + (pure (false))])] + (lambda (stx) + (generate-syntax-case fancy-syntax-case stx () + [(_ ,stx-name (,keywords ...) ,cases ...) + (>>= (list-of-keywords? keywords) + (lambda (keywords-are-keywords) + (if keywords-are-keywords + (flet [is-identifier-in-list? (identifier xs) + (generate-syntax-case fancy-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-case (scrutinee-name case) + (generate-syntax-case fancy-syntax-case case () + [(,pat ,rhs) + (generate-syntax-case fancy-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 + ('"fancy-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 + ('"fancy-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 + ('"fancy-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 fancy-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 [failure-cc + (lambda () + (syntax-error (list-syntax + ('"fancy-syntax-case: the input" + ,stx-name + '"does not match any of the following patterns" + ',(map car cases)) + ,stx-name) + ,stx-name))] + ,outer-cases) + stx)))))))) + (syntax-error (list-syntax + ('"fancy-syntax-case:" + keywords + '"does not look like a list of keywords." + '"did you forget a () between the input and the cases?") + stx-name)))))])))] + [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))])) + (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)))]))]))) - '(example - (fancy-quasiquote - (1 - (fancy-unquote '(2 3)) - (fancy-unquote '(4 5)) fancy-... - 6))) - '(export (rename ([fancy-quasiquote quasiquote] + + '(export (rename ([fancy-syntax-case syntax-case] + [fancy-quasiquote quasiquote] [fancy-unquote unquote] - [fancy-... ...]) + [fancy-... ...] + [fancy-_ _]) + fancy-syntax-case fancy-quasiquote fancy-unquote - fancy-...))))))))) + fancy-... + fancy-_))))))))) diff --git a/examples/bool.kl b/examples/bool.kl index f49c8933..ad755095 100644 --- a/examples/bool.kl +++ b/examples/bool.kl @@ -16,22 +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 (and ,xs ...))))))))) - (or (lambda (stx) - (syntax-case stx - ((cons _ args) - (syntax-case args - (() - (pure '(false))) - ((cons x xs) - (pure `(binary-or ,x (or ,xs ...))))))))))) + ([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/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 347363df..970b45af 100644 --- a/examples/do.kl +++ b/examples/do.kl @@ -2,7 +2,8 @@ (import (shift "prelude.kl" 1)) (import (shift "dot-dot-dot.kl" 1)) -(import (shift "let.kl" 1)) +(import (shift "do-keywords.kl" 1)) +(import "do-keywords.kl") (define-macros -- (do (x <- foo) @@ -14,29 +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 (_) - (do ,actions ...))))]) - (syntax-case first-action - [(list (var <-? action)) - (>>= (free-identifier=? '<- <-?) - (lambda (isArrow) - (if isArrow - (pure `(>>= ,action - (lambda (,var) - (do ,actions ...)))) - 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..55a0bd41 --- /dev/null +++ b/examples/dot-dot-dot-test.golden @@ -0,0 +1,3 @@ +#[dot-dot-dot-test.kl:16.17-16.31]<(1 2 3 4)> : Syntax +#[dot-dot-dot-test.kl:18.17-18.58]<(keyword-prefixed bar baz end-of-list)> : Syntax +#[dot-dot-dot-test.kl:20.17-20.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..27ed34b8 --- /dev/null +++ b/examples/dot-dot-dot-test.kl @@ -0,0 +1,24 @@ +#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)) + +(define-macros + ([my-macro + (lambda (stx) + (syntax-case stx (keyword) + [(_ ((,a ,b) (,c ,d))) + (pure `'(,a ,b ,c ,d))] + [(_ (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 (foo bar baz))) diff --git a/examples/dot-dot-dot.golden b/examples/dot-dot-dot.golden index 8416caf8..e69de29b 100644 --- a/examples/dot-dot-dot.golden +++ b/examples/dot-dot-dot.golden @@ -1 +0,0 @@ -#[dot-dot-dot.kl:242.3-246.6]<(1 (2 3) 4 5 6)> : Syntax diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index 8a11cc2c..0507e47f 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -1,14 +1,20 @@ #lang "prelude.kl" -- GENERATED BY ../bootstrap.rkt, DO NOT EDIT -(import "list-syntax.kl") - -(import (shift "list-syntax.kl" 1)) +(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) @@ -19,31 +25,736 @@ (lambda (stx) (syntax-error '"fancy-... used out of context" + stx))) + (fancy-_ + (lambda (stx) + (syntax-error + '"fancy-_ used out of context" stx))))) (define-macros - ((fancy-quasiquote + ((fancy-syntax-case + (flet + (list-of-keywords? + (xs) + (let (failure-cc-158 + (lambda () + (syntax-error + '"fancy-syntax-case call has invalid syntax" + xs))) + (let (failure-cc-158 + (lambda () (pure (false)))) + (let (failure-cc-158 + (lambda () + (raw-syntax-case + xs + ((cons + head-159 + tail-160) + (let (x head-159) + (let (xs tail-160) + (>>= + (pure + (identifier? + x)) + (lambda (guard-approves) + (if guard-approves + (list-of-keywords? + xs) + (failure-cc-158))))))) + (_ + (failure-cc-158))))) + (let (failure-cc-158 + (lambda () + (raw-syntax-case + xs + (() (pure (true))) + (_ + (failure-cc-158))))) + (failure-cc-158)))))) + (lambda (stx) + (let (failure-cc-187 + (lambda () + (syntax-error + '"fancy-syntax-case call has invalid syntax" + stx))) + (let (failure-cc-187 + (lambda () + (raw-syntax-case + stx + ((cons + head-188 + tail-189) + (raw-syntax-case + tail-189 + ((cons + head-190 + tail-191) + (let (stx-name + head-190) + (raw-syntax-case + tail-191 + ((cons + head-192 + tail-193) + (let (keywords + head-192) + (let (cases + tail-193) + (>>= + (list-of-keywords? + keywords) + (lambda (keywords-are-keywords) + (if keywords-are-keywords + (flet + (is-identifier-in-list? + (identifier + xs) + (let (failure-cc-161 + (lambda () + (syntax-error + '"fancy-syntax-case call has invalid syntax" + xs))) + (let (failure-cc-161 + (lambda () + (raw-syntax-case + xs + ((cons + head-162 + tail-163) + (let (x + head-162) + (let (xs + tail-163) + (>>= + (free-identifier=? + identifier + x) + (lambda (same-identifier) + (if same-identifier + (pure + (true)) + (is-identifier-in-list? + identifier + xs))))))) + (_ + (failure-cc-161))))) + (let (failure-cc-161 + (lambda () + (raw-syntax-case + xs + (() + (pure + (false))) + (_ + (failure-cc-161))))) + (failure-cc-161))))) + (let (keyword? + (lambda (keyword) + (is-identifier-in-list? + keyword + keywords))) + (flet + (fancy-case + (scrutinee-name + case) + (let (failure-cc-179 + (lambda () + (syntax-error + '"fancy-syntax-case call has invalid syntax" + case))) + (let (failure-cc-179 + (lambda () + (raw-syntax-case + case + ((cons + head-180 + tail-181) + (let (pat + head-180) + (raw-syntax-case + tail-181 + ((cons + head-182 + tail-183) + (let (rhs + head-182) + (raw-syntax-case + tail-183 + (() + (let (failure-cc-164 + (lambda () + (syntax-error + '"fancy-syntax-case call has invalid syntax" + pat))) + (let (failure-cc-164 + (lambda () + (pure + (cons-list-syntax + 'failure-cc + '() + stx)))) + (let (failure-cc-164 + (lambda () + (raw-syntax-case + pat + ((cons + head-177 + tail-178) + (let (pat-head + head-177) + (let (pat-tail + tail-178) + (>>= + (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-164))))) + (let (failure-cc-164 + (lambda () + (raw-syntax-case + pat + ((cons + head-169 + tail-170) + (raw-syntax-case + head-169 + ((cons + head-173 + tail-174) + (if (identifier? + head-173) + (>>= + (free-identifier=? + head-173 + 'fancy-unquote) + (lambda (same-identifier) + (if same-identifier + (raw-syntax-case + tail-174 + ((cons + head-175 + tail-176) + (let (x + head-175) + (raw-syntax-case + tail-176 + (() + (raw-syntax-case + tail-170 + ((cons + head-171 + tail-172) + (if (identifier? + head-171) + (>>= + (free-identifier=? + head-171 + 'fancy-...) + (lambda (same-identifier) + (if same-identifier + (raw-syntax-case + tail-172 + (() + (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 + ('"fancy-syntax-case: the syntax for binding lists is (,x ...), found" + pat + '"instead") + stx) + stx))) + (_ + (failure-cc-164))) + (failure-cc-164)))) + (failure-cc-164))) + (_ + (failure-cc-164)))) + (_ + (failure-cc-164))))) + (_ + (failure-cc-164))) + (failure-cc-164)))) + (failure-cc-164))) + (_ + (failure-cc-164)))) + (_ + (failure-cc-164))))) + (let (failure-cc-164 + (lambda () + (raw-syntax-case + pat + ((cons + head-165 + tail-166) + (if (identifier? + head-165) + (>>= + (free-identifier=? + head-165 + 'fancy-unquote) + (lambda (same-identifier) + (if same-identifier + (raw-syntax-case + tail-166 + ((cons + head-167 + tail-168) + (let (x + head-167) + (raw-syntax-case + tail-168 + (() + (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 + ('"fancy-syntax-case: the syntax for binding values is (unquote x), found" + pat + '"instead") + stx) + stx))) + (_ + (failure-cc-164))))) + (_ + (failure-cc-164))) + (failure-cc-164)))) + (failure-cc-164))) + (_ + (failure-cc-164))))) + (let (failure-cc-164 + (lambda () + (let (keyword + pat) + (>>= + (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 + ('"fancy-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-164))))))) + (let (failure-cc-164 + (lambda () + (if (identifier? + pat) + (>>= + (free-identifier=? + pat + 'fancy-_) + (lambda (same-identifier) + (if same-identifier + (pure + rhs) + (failure-cc-164)))) + (failure-cc-164)))) + (let (failure-cc-164 + (lambda () + (raw-syntax-case + pat + (() + (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-164))))) + (failure-cc-164)))))))))) + (_ + (failure-cc-179))))) + (_ + (failure-cc-179))))) + (_ + (failure-cc-179))))) + (failure-cc-179)))) + (flet + (fancy-cases + (cases + inner-cases) + (let (failure-cc-184 + (lambda () + (syntax-error + '"fancy-syntax-case call has invalid syntax" + cases))) + (let (failure-cc-184 + (lambda () + (raw-syntax-case + cases + ((cons + head-185 + tail-186) + (let (case + head-185) + (let (cases + tail-186) + (>>= + (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-184))))) + (let (failure-cc-184 + (lambda () + (raw-syntax-case + cases + (() + (pure + inner-cases)) + (_ + (failure-cc-184))))) + (failure-cc-184))))) + (>>= + (fancy-cases + cases + (cons-list-syntax + 'failure-cc + '() + stx)) + (lambda (outer-cases) + (pure + (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 + '"fancy-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-name + '() + stx) + stx) + stx) + (cons-list-syntax + stx-name + '() + stx) + stx) + stx) + '() + stx) + stx) + stx) + '() + stx) + stx) + (cons-list-syntax + outer-cases + '() + stx) + stx) + stx)))))))) + (syntax-error + (list-syntax + ('"fancy-syntax-case:" + keywords + '"does not look like a list of keywords." + '"did you forget a () between the input and the cases?") + stx-name)))))))) + (_ + (failure-cc-187))))) + (_ + (failure-cc-187)))) + (_ (failure-cc-187))))) + (failure-cc-187)))))) + (fancy-quasiquote (lambda (stx) - (let (failure-cc-174 + (let (failure-cc-209 (lambda () (syntax-error '"fancy-quasiquote call has invalid syntax" stx))) - (let (failure-cc-174 + (let (failure-cc-209 (lambda () (raw-syntax-case stx ((cons - head-175 - tail-176) + head-210 + tail-211) (raw-syntax-case - tail-176 + tail-211 ((cons - head-177 - tail-178) - (let (pat head-177) + head-212 + tail-213) + (let (pat head-212) (raw-syntax-case - tail-178 + tail-213 (() (let (stx-name (cons-list-syntax @@ -58,12 +769,12 @@ (flet (fancy-inside (pat) - (let (failure-cc-156 + (let (failure-cc-194 (lambda () (syntax-error '"fancy-quasiquote call has invalid syntax" pat))) - (let (failure-cc-156 + (let (failure-cc-194 (lambda () (let (x pat) @@ -72,17 +783,17 @@ 'quote x stx))))) - (let (failure-cc-156 + (let (failure-cc-194 (lambda () (raw-syntax-case pat ((cons - head-172 - tail-173) + head-207 + tail-208) (let (head - head-172) + head-207) (let (tail - tail-173) + tail-208) (>>= (fancy-inside head) @@ -106,56 +817,52 @@ stx) stx))))))))) (_ - (failure-cc-156))))) - (let (failure-cc-156 + (failure-cc-194))))) + (let (failure-cc-194 (lambda () (raw-syntax-case pat ((cons - head-162 - tail-163) + head-199 + tail-200) (raw-syntax-case - head-162 + head-199 ((cons - head-167 - tail-168) - (raw-syntax-case - head-167 - ((ident - ident171) + head-203 + tail-204) + (if (identifier? + head-203) (>>= (free-identifier=? - ident171 + head-203 'fancy-unquote) (lambda (same-identifier) (if same-identifier (raw-syntax-case - tail-168 + tail-204 ((cons - head-169 - tail-170) + head-205 + tail-206) (let (head - head-169) + head-205) (raw-syntax-case - tail-170 + tail-206 (() (raw-syntax-case - tail-163 + tail-200 ((cons - head-164 - tail-165) - (raw-syntax-case - head-164 - ((ident - ident166) + head-201 + tail-202) + (if (identifier? + head-201) (>>= (free-identifier=? - ident166 + head-201 'fancy-...) (lambda (same-identifier) (if same-identifier (let (tail - tail-165) + tail-202) (>>= (fancy-inside tail) @@ -174,81 +881,73 @@ stx) stx) stx))))) - (failure-cc-156))))) - (_ - (failure-cc-156)))) + (failure-cc-194)))) + (failure-cc-194))) (_ - (failure-cc-156)))) + (failure-cc-194)))) (_ - (failure-cc-156))))) + (failure-cc-194))))) (_ - (failure-cc-156))) - (failure-cc-156))))) - (_ - (failure-cc-156)))) + (failure-cc-194))) + (failure-cc-194)))) + (failure-cc-194))) (_ - (failure-cc-156)))) + (failure-cc-194)))) (_ - (failure-cc-156))))) - (let (failure-cc-156 + (failure-cc-194))))) + (let (failure-cc-194 (lambda () (raw-syntax-case pat ((cons - head-157 - tail-158) - (raw-syntax-case - head-157 - ((ident - ident161) + head-195 + tail-196) + (if (identifier? + head-195) (>>= (free-identifier=? - ident161 + head-195 'fancy-unquote) (lambda (same-identifier) (if same-identifier (raw-syntax-case - tail-158 + tail-196 ((cons - head-159 - tail-160) + head-197 + tail-198) (let (x - head-159) + head-197) (raw-syntax-case - tail-160 + tail-198 (() (pure x)) (_ - (failure-cc-156))))) + (failure-cc-194))))) (_ - (failure-cc-156))) - (failure-cc-156))))) - (_ - (failure-cc-156)))) + (failure-cc-194))) + (failure-cc-194)))) + (failure-cc-194))) (_ - (failure-cc-156))))) - (failure-cc-156))))))) + (failure-cc-194))))) + (failure-cc-194))))))) (fancy-inside pat)))) (_ - (failure-cc-174))))) - (_ (failure-cc-174)))) - (_ (failure-cc-174))))) - (failure-cc-174))))))) - -(example - (fancy-quasiquote - (1 - (fancy-unquote '(2 3)) - (fancy-unquote '(4 5)) - fancy-... - 6))) + (failure-cc-209))))) + (_ (failure-cc-209)))) + (_ (failure-cc-209))))) + (failure-cc-209))))))) -(export (rename ((fancy-quasiquote +(export (rename ((fancy-syntax-case + syntax-case) + (fancy-quasiquote quasiquote) (fancy-unquote unquote) - (fancy-... ...)) + (fancy-... ...) + (fancy-_ _)) + fancy-syntax-case fancy-quasiquote fancy-unquote - fancy-...)) + fancy-... + fancy-_)) diff --git a/examples/free-identifier-case.kl b/examples/free-identifier-case.kl index 07a8a750..bf073c0f 100644 --- a/examples/free-identifier-case.kl +++ b/examples/free-identifier-case.kl @@ -2,15 +2,9 @@ (import "let.kl") (import (shift "prelude.kl" 1)) +(import (shift "identifier.kl" 1)) (import (shift "quasiquote.kl" 1)) -(meta - (define identifier? - (lambda (x) - (syntax-case x - [(ident x) (true)] - [_ (false)])))) - (define-macros ([free-identifier-case (lambda (stx) 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/pmatch.golden b/examples/pmatch.golden index 1f7724dc..ab065aba 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:99.32-99.33] : Syntax +#[pmatch.kl:100.36-100.37] : Syntax +#[pmatch.kl:101.29-101.30] : Syntax +#[pmatch.kl:102.48-102.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:127.34-127.35]<1> 1) + (:: (pair #[pmatch.kl:127.50-127.51]<2> 2) + (:: (pair #[pmatch.kl:127.66-127.67]<3> 3) (nil)))) : (List (Pair Syntax Integer)) diff --git a/examples/pmatch.kl b/examples/pmatch.kl index d79584a1..1589a69a 100644 --- a/examples/pmatch.kl +++ b/examples/pmatch.kl @@ -5,6 +5,7 @@ (import (shift "prelude.kl" 1)) +(import (shift "identifier.kl" 1)) (import (shift "quasiquote.kl" 1)) (import (shift "defun.kl" 1)) (import (shift "lispy-do.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) From 16838d8c7b17a1808a3dc9aded2f12d60d8bcf92 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sat, 17 Oct 2020 17:13:18 -0400 Subject: [PATCH 28/35] only evaluate syntax-case's input expression once --- bootstrap.rkt | 288 +++---- examples/dot-dot-dot.kl | 1661 ++++++++++++++++++++------------------- 2 files changed, 994 insertions(+), 955 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 6cf32e8b..527a048c 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -79,8 +79,9 @@ ; [() rhs1] ; [_ (failure-cc)]))] ; (failure-cc))))) -(define (generate-syntax-case macro-name stx-name keywords cases) - (letrec ([failure-cc-name (gensym '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 @@ -158,14 +159,15 @@ (lambda () ,(generate-case stx-name case))] ,inner))]))]) - `(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))))) + `(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)))))) (define (generate-define-syntax macro-name stx-name keywords cases) `(group @@ -247,9 +249,9 @@ #''()] [(_ (generate-quasiquote pat stx-name)) #'(generate-quasiquote 'pat 'stx-name)] - [(_ (generate-syntax-case macro-name stx-name (keyword ...) + [(_ (generate-syntax-case macro-name stx-expr (keyword ...) [lhs rhs ...] ...)) - #'(generate-syntax-case 'macro-name 'stx-name (list 'keyword ...) + #'(generate-syntax-case 'macro-name 'stx-expr (list 'keyword ...) (list (list 'lhs (auto-splice rhs) ...) @@ -307,140 +309,142 @@ (pure (false))])] (lambda (stx) (generate-syntax-case fancy-syntax-case stx () - [(_ ,stx-name (,keywords ...) ,cases ...) - (>>= (list-of-keywords? keywords) - (lambda (keywords-are-keywords) - (if keywords-are-keywords - (flet [is-identifier-in-list? (identifier xs) - (generate-syntax-case fancy-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-case (scrutinee-name case) - (generate-syntax-case fancy-syntax-case case () - [(,pat ,rhs) - (generate-syntax-case fancy-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 - ('"fancy-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 - ('"fancy-syntax-case: the syntax for binding values is (unquote x), found" - pat - '"instead") - 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 fancy-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-case (scrutinee-name case) + (generate-syntax-case fancy-syntax-case case () + [(,pat ,rhs) + (generate-syntax-case fancy-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 + ('"fancy-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 + ('"fancy-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 - ('"fancy-syntax-case: the syntax for binding lists is (,x ...), found" - pat - '"instead") - stx) + [((fancy-unquote ,x) fancy-...) + (if (identifier? x) + (pure (generate-quasiquote + (let [,x ,scrutinee-name] + ,rhs) + stx)) + (syntax-error (list-syntax + ('"fancy-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 fancy-syntax-case cases () - [() - (pure inner-cases)] - [(,case ,cases ...) - (>>= (fancy-case stx-name case) - (lambda (inner-case) - (fancy-cases cases - (generate-quasiquote + [(,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 fancy-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 () - ,inner-case)] - ,inner-cases) - stx))))])] - (>>= (fancy-cases cases - (generate-quasiquote - (failure-cc) - stx)) - (lambda (outer-cases) - (pure (generate-quasiquote - (let [failure-cc - (lambda () - (syntax-error (list-syntax - ('"fancy-syntax-case: the input" - ,stx-name - '"does not match any of the following patterns" - ',(map car cases)) - ,stx-name) - ,stx-name))] - ,outer-cases) - stx)))))))) - (syntax-error (list-syntax - ('"fancy-syntax-case:" - keywords - '"does not look like a list of keywords." - '"did you forget a () between the input and the cases?") - stx-name)))))])))] + (syntax-error (list-syntax + ('"fancy-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 + ('"fancy-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 () diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index 0507e47f..96a30f2f 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -37,672 +37,710 @@ (flet (list-of-keywords? (xs) - (let (failure-cc-158 - (lambda () - (syntax-error - '"fancy-syntax-case call has invalid syntax" - xs))) - (let (failure-cc-158 - (lambda () (pure (false)))) - (let (failure-cc-158 + (let (stx-158 xs) + (let (failure-cc-159 + (lambda () + (syntax-error + '"fancy-syntax-case call has invalid syntax" + stx-158))) + (let (failure-cc-159 (lambda () - (raw-syntax-case - xs - ((cons - head-159 - tail-160) - (let (x head-159) - (let (xs tail-160) - (>>= - (pure - (identifier? - x)) - (lambda (guard-approves) - (if guard-approves - (list-of-keywords? - xs) - (failure-cc-158))))))) - (_ - (failure-cc-158))))) - (let (failure-cc-158 + (pure (false)))) + (let (failure-cc-159 (lambda () (raw-syntax-case - xs - (() (pure (true))) + 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-158))))) - (failure-cc-158)))))) + (failure-cc-159))))) + (let (failure-cc-159 + (lambda () + (raw-syntax-case + stx-158 + (() (pure (true))) + (_ + (failure-cc-159))))) + (failure-cc-159))))))) (lambda (stx) - (let (failure-cc-187 - (lambda () - (syntax-error - '"fancy-syntax-case call has invalid syntax" - stx))) - (let (failure-cc-187 + (let (stx-192 stx) + (let (failure-cc-193 (lambda () - (raw-syntax-case - stx - ((cons - head-188 - tail-189) + (syntax-error + '"fancy-syntax-case call has invalid syntax" + stx-192))) + (let (failure-cc-193 + (lambda () (raw-syntax-case - tail-189 + stx-192 ((cons - head-190 - tail-191) - (let (stx-name - head-190) - (raw-syntax-case - tail-191 - ((cons - head-192 - tail-193) - (let (keywords - head-192) - (let (cases - tail-193) - (>>= - (list-of-keywords? - keywords) - (lambda (keywords-are-keywords) - (if keywords-are-keywords - (flet - (is-identifier-in-list? - (identifier - xs) - (let (failure-cc-161 - (lambda () - (syntax-error - '"fancy-syntax-case call has invalid syntax" - xs))) - (let (failure-cc-161 - (lambda () - (raw-syntax-case - xs - ((cons - head-162 - tail-163) - (let (x - head-162) - (let (xs - tail-163) - (>>= - (free-identifier=? - identifier - x) - (lambda (same-identifier) - (if same-identifier - (pure - (true)) - (is-identifier-in-list? - identifier - xs))))))) - (_ - (failure-cc-161))))) - (let (failure-cc-161 - (lambda () - (raw-syntax-case - xs - (() - (pure - (false))) - (_ - (failure-cc-161))))) - (failure-cc-161))))) - (let (keyword? - (lambda (keyword) - (is-identifier-in-list? - keyword - keywords))) - (flet - (fancy-case - (scrutinee-name - case) - (let (failure-cc-179 - (lambda () - (syntax-error - '"fancy-syntax-case call has invalid syntax" - case))) - (let (failure-cc-179 - (lambda () - (raw-syntax-case - case - ((cons - head-180 - tail-181) - (let (pat - head-180) - (raw-syntax-case - tail-181 - ((cons - head-182 - tail-183) - (let (rhs - head-182) - (raw-syntax-case - tail-183 - (() - (let (failure-cc-164 - (lambda () - (syntax-error - '"fancy-syntax-case call has invalid syntax" - pat))) - (let (failure-cc-164 - (lambda () - (pure - (cons-list-syntax - 'failure-cc - '() - stx)))) - (let (failure-cc-164 - (lambda () - (raw-syntax-case - pat - ((cons - head-177 - tail-178) - (let (pat-head - head-177) - (let (pat-tail - tail-178) - (>>= - (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-164))))) - (let (failure-cc-164 - (lambda () - (raw-syntax-case - pat - ((cons - head-169 - tail-170) - (raw-syntax-case - head-169 - ((cons - head-173 - tail-174) - (if (identifier? - head-173) - (>>= - (free-identifier=? - head-173 - 'fancy-unquote) - (lambda (same-identifier) - (if same-identifier - (raw-syntax-case - tail-174 - ((cons - head-175 - tail-176) - (let (x - head-175) - (raw-syntax-case - tail-176 - (() - (raw-syntax-case - tail-170 - ((cons - head-171 - tail-172) - (if (identifier? - head-171) + head-194 + tail-195) + (raw-syntax-case + tail-195 + ((cons + head-196 + tail-197) + (let (stx-expr + head-196) + (raw-syntax-case + tail-197 + ((cons + head-198 + tail-199) + (let (keywords + head-198) + (let (cases + tail-199) + (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 + '"fancy-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-case + (scrutinee-name + case) + (let (stx-182 + case) + (let (failure-cc-183 + (lambda () + (syntax-error + '"fancy-syntax-case call has invalid syntax" + stx-182))) + (let (failure-cc-183 + (lambda () + (raw-syntax-case + stx-182 + ((cons + head-184 + tail-185) + (let (pat + head-184) + (raw-syntax-case + tail-185 + ((cons + head-186 + tail-187) + (let (rhs + head-186) + (raw-syntax-case + tail-187 + (() + (let (stx-166 + pat) + (let (failure-cc-167 + (lambda () + (syntax-error + '"fancy-syntax-case call has invalid syntax" + stx-166))) + (let (failure-cc-167 + (lambda () + (pure + (cons-list-syntax + 'failure-cc + '() + stx)))) + (let (failure-cc-167 + (lambda () + (raw-syntax-case + stx-166 + ((cons + head-180 + tail-181) + (let (pat-head + head-180) + (let (pat-tail + tail-181) + (>>= + (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) (>>= - (free-identifier=? - head-171 - 'fancy-...) - (lambda (same-identifier) - (if same-identifier - (raw-syntax-case - tail-172 - (() - (if (identifier? - x) - (pure + (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 - 'let + 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-167))))) + (let (failure-cc-167 + (lambda () + (raw-syntax-case + stx-166 + ((cons + head-172 + tail-173) + (raw-syntax-case + head-172 + ((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 + (() + (raw-syntax-case + tail-173 + ((cons + head-174 + tail-175) + (if (identifier? + head-174) + (>>= + (free-identifier=? + head-174 + 'fancy-...) + (lambda (same-identifier) + (if same-identifier + (raw-syntax-case + tail-175 + (() + (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 + ('"fancy-syntax-case: the syntax for binding lists is (,x ...), found" + pat + '"instead") + stx) + stx))) + (_ + (failure-cc-167))) + (failure-cc-167)))) + (failure-cc-167))) + (_ + (failure-cc-167)))) + (_ + (failure-cc-167))))) + (_ + (failure-cc-167))) + (failure-cc-167)))) + (failure-cc-167))) + (_ + (failure-cc-167)))) + (_ + (failure-cc-167))))) + (let (failure-cc-167 + (lambda () + (raw-syntax-case + stx-166 + ((cons + head-168 + tail-169) + (if (identifier? + head-168) + (>>= + (free-identifier=? + head-168 + 'fancy-unquote) + (lambda (same-identifier) + (if same-identifier + (raw-syntax-case + tail-169 + ((cons + head-170 + tail-171) + (let (x + head-170) + (raw-syntax-case + tail-171 + (() + (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 + ('"fancy-syntax-case: the syntax for binding values is (unquote x), found" + pat + '"instead") + stx) + stx))) + (_ + (failure-cc-167))))) + (_ + (failure-cc-167))) + (failure-cc-167)))) + (failure-cc-167))) + (_ + (failure-cc-167))))) + (let (failure-cc-167 + (lambda () + (let (keyword + stx-166) + (>>= + (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 - x + 'quote (cons-list-syntax - scrutinee-name + keyword '() stx) stx) + '() + stx) + stx) + stx) + (cons-list-syntax + (cons-list-syntax + 'lambda + (cons-list-syntax (cons-list-syntax - rhs + '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)) - (syntax-error - (list-syntax - ('"fancy-syntax-case: the syntax for binding lists is (,x ...), found" - pat - '"instead") stx) - stx))) - (_ - (failure-cc-164))) - (failure-cc-164)))) - (failure-cc-164))) - (_ - (failure-cc-164)))) - (_ - (failure-cc-164))))) - (_ - (failure-cc-164))) - (failure-cc-164)))) - (failure-cc-164))) - (_ - (failure-cc-164)))) - (_ - (failure-cc-164))))) - (let (failure-cc-164 - (lambda () - (raw-syntax-case - pat - ((cons - head-165 - tail-166) - (if (identifier? - head-165) - (>>= - (free-identifier=? - head-165 - 'fancy-unquote) - (lambda (same-identifier) - (if same-identifier - (raw-syntax-case - tail-166 - ((cons - head-167 - tail-168) - (let (x - head-167) - (raw-syntax-case - tail-168 - (() - (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 - ('"fancy-syntax-case: the syntax for binding values is (unquote x), found" - pat - '"instead") - stx) - stx))) - (_ - (failure-cc-164))))) - (_ - (failure-cc-164))) - (failure-cc-164)))) - (failure-cc-164))) - (_ - (failure-cc-164))))) - (let (failure-cc-164 - (lambda () - (let (keyword - pat) - (>>= - (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 + '() + stx) + stx) + stx) + (cons-list-syntax + (cons-list-syntax + 'failure-cc + '() + stx) + '() + stx) + stx) + stx) + stx)) + (syntax-error + (list-syntax + ('"fancy-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-167))))))) + (let (failure-cc-167 + (lambda () + (if (identifier? + stx-166) + (>>= + (free-identifier=? + stx-166 + 'fancy-_) + (lambda (same-identifier) + (if same-identifier + (pure + rhs) + (failure-cc-167)))) + (failure-cc-167)))) + (let (failure-cc-167 + (lambda () + (raw-syntax-case + stx-166 + (() + (pure (cons-list-syntax - 'identifier? + 'raw-syntax-case (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) + rhs + '() 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) + 'failure-cc '() stx) + '() stx) stx) '() stx) stx) stx) - (cons-list-syntax - (cons-list-syntax - 'failure-cc - '() - stx) - '() - stx) - stx) - stx) - stx)) - (syntax-error - (list-syntax - ('"fancy-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-164))))))) - (let (failure-cc-164 - (lambda () - (if (identifier? - pat) - (>>= - (free-identifier=? - pat - 'fancy-_) - (lambda (same-identifier) - (if same-identifier - (pure - rhs) - (failure-cc-164)))) - (failure-cc-164)))) - (let (failure-cc-164 - (lambda () - (raw-syntax-case - pat - (() - (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-164))))) - (failure-cc-164)))))))))) - (_ - (failure-cc-179))))) - (_ - (failure-cc-179))))) - (_ - (failure-cc-179))))) - (failure-cc-179)))) - (flet - (fancy-cases - (cases - inner-cases) - (let (failure-cc-184 - (lambda () - (syntax-error - '"fancy-syntax-case call has invalid syntax" - cases))) - (let (failure-cc-184 - (lambda () - (raw-syntax-case - cases - ((cons - head-185 - tail-186) - (let (case - head-185) - (let (cases - tail-186) - (>>= - (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 - '() + stx))) + (_ + (failure-cc-167))))) + (failure-cc-167))))))))))) + (_ + (failure-cc-183))))) + (_ + (failure-cc-183))))) + (_ + (failure-cc-183))))) + (failure-cc-183))))) + (flet + (fancy-cases + (cases + inner-cases) + (let (stx-188 + cases) + (let (failure-cc-189 + (lambda () + (syntax-error + '"fancy-syntax-case call has invalid syntax" + stx-188))) + (let (failure-cc-189 + (lambda () + (raw-syntax-case + stx-188 + ((cons + head-190 + tail-191) + (let (case + head-190) + (let (cases + tail-191) + (>>= + (fancy-case + stx-name + case) + (lambda (inner-case) + (fancy-cases + cases (cons-list-syntax - inner-case - '() - stx) - stx) - stx) - '() - stx) - stx) - (cons-list-syntax - inner-cases - '() - stx) - stx) - stx))))))) - (_ - (failure-cc-184))))) - (let (failure-cc-184 - (lambda () - (raw-syntax-case - cases - (() - (pure - inner-cases)) - (_ - (failure-cc-184))))) - (failure-cc-184))))) - (>>= - (fancy-cases - cases - (cons-list-syntax - 'failure-cc - '() - stx)) - (lambda (outer-cases) - (pure - (cons-list-syntax - 'let - (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-189))))) + (let (failure-cc-189 + (lambda () + (raw-syntax-case + stx-188 + (() + (pure + inner-cases)) + (_ + (failure-cc-189))))) + (failure-cc-189)))))) + (>>= + (fancy-cases + cases (cons-list-syntax 'failure-cc - (cons-list-syntax + '() + stx)) + (lambda (outer-cases) + (pure (cons-list-syntax - 'lambda + 'let (cons-list-syntax - '() + (cons-list-syntax + stx-name + (cons-list-syntax + stx-expr + '() + stx) + stx) (cons-list-syntax (cons-list-syntax - 'syntax-error + 'let (cons-list-syntax (cons-list-syntax - 'list-syntax + 'failure-cc (cons-list-syntax (cons-list-syntax + 'lambda (cons-list-syntax - 'quote - (cons-list-syntax - '"fancy-syntax-case: the input" - '() - stx) - stx) - (cons-list-syntax - stx-name + '() (cons-list-syntax (cons-list-syntax - 'quote + 'syntax-error (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) + 'list-syntax + (cons-list-syntax + (cons-list-syntax + (cons-list-syntax + 'quote + (cons-list-syntax + '"fancy-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) - (cons-list-syntax - stx-name - '() - stx) + '() stx) stx) (cons-list-syntax - stx-name + outer-cases '() stx) stx) @@ -710,234 +748,231 @@ '() stx) stx) - stx) - '() - stx) - stx) - (cons-list-syntax - outer-cases - '() - stx) - stx) - stx)))))))) - (syntax-error - (list-syntax - ('"fancy-syntax-case:" - keywords - '"does not look like a list of keywords." - '"did you forget a () between the input and the cases?") - stx-name)))))))) - (_ - (failure-cc-187))))) + stx)))))))) + (syntax-error + (list-syntax + ('"fancy-syntax-case:" + keywords + '"does not look like a list of keywords." + '"did you forget a () between the input and the cases?") + stx))))))))) + (_ + (failure-cc-193))))) + (_ + (failure-cc-193)))) (_ - (failure-cc-187)))) - (_ (failure-cc-187))))) - (failure-cc-187)))))) + (failure-cc-193))))) + (failure-cc-193))))))) (fancy-quasiquote (lambda (stx) - (let (failure-cc-209 - (lambda () - (syntax-error - '"fancy-quasiquote call has invalid syntax" - stx))) - (let (failure-cc-209 + (let (stx-216 stx) + (let (failure-cc-217 (lambda () - (raw-syntax-case - stx - ((cons - head-210 - tail-211) + (syntax-error + '"fancy-quasiquote call has invalid syntax" + stx-216))) + (let (failure-cc-217 + (lambda () (raw-syntax-case - tail-211 + stx-216 ((cons - head-212 - tail-213) - (let (pat head-212) - (raw-syntax-case - tail-213 - (() - (let (stx-name - (cons-list-syntax - 'quote - (cons-list-syntax - (replace-loc - pat - 'here) - '() - 'here) - 'here)) - (flet - (fancy-inside - (pat) - (let (failure-cc-194 - (lambda () - (syntax-error - '"fancy-quasiquote call has invalid syntax" - pat))) - (let (failure-cc-194 - (lambda () - (let (x - pat) - (pure - (pair-list-syntax - 'quote - x - stx))))) - (let (failure-cc-194 + head-218 + tail-219) + (raw-syntax-case + tail-219 + ((cons + head-220 + tail-221) + (let (pat head-220) + (raw-syntax-case + tail-221 + (() + (let (stx-name + (cons-list-syntax + 'quote + (cons-list-syntax + (replace-loc + pat + 'here) + '() + 'here) + 'here)) + (flet + (fancy-inside + (pat) + (let (stx-200 + pat) + (let (failure-cc-201 (lambda () - (raw-syntax-case - pat - ((cons - head-207 - tail-208) - (let (head - head-207) - (let (tail - tail-208) - (>>= - (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-194))))) - (let (failure-cc-194 + (syntax-error + '"fancy-quasiquote call has invalid syntax" + stx-200))) + (let (failure-cc-201 (lambda () - (raw-syntax-case - pat - ((cons - head-199 - tail-200) + (let (x + stx-200) + (pure + (pair-list-syntax + 'quote + x + stx))))) + (let (failure-cc-201 + (lambda () (raw-syntax-case - head-199 + stx-200 ((cons - head-203 - tail-204) - (if (identifier? - head-203) - (>>= - (free-identifier=? - head-203 - 'fancy-unquote) - (lambda (same-identifier) - (if same-identifier - (raw-syntax-case - tail-204 - ((cons - head-205 - tail-206) - (let (head - head-205) + head-214 + tail-215) + (let (head + head-214) + (let (tail + tail-215) + (>>= + (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-201))))) + (let (failure-cc-201 + (lambda () + (raw-syntax-case + stx-200 + ((cons + head-206 + tail-207) + (raw-syntax-case + head-206 + ((cons + head-210 + tail-211) + (if (identifier? + head-210) + (>>= + (free-identifier=? + head-210 + 'fancy-unquote) + (lambda (same-identifier) + (if same-identifier (raw-syntax-case - tail-206 - (() - (raw-syntax-case - tail-200 - ((cons - head-201 - tail-202) - (if (identifier? - head-201) - (>>= - (free-identifier=? - head-201 - 'fancy-...) - (lambda (same-identifier) - (if same-identifier - (let (tail - tail-202) - (>>= - (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-194)))) - (failure-cc-194))) - (_ - (failure-cc-194)))) + tail-211 + ((cons + head-212 + tail-213) + (let (head + head-212) + (raw-syntax-case + tail-213 + (() + (raw-syntax-case + tail-207 + ((cons + head-208 + tail-209) + (if (identifier? + head-208) + (>>= + (free-identifier=? + head-208 + 'fancy-...) + (lambda (same-identifier) + (if same-identifier + (let (tail + tail-209) + (>>= + (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-201)))) + (failure-cc-201))) + (_ + (failure-cc-201)))) + (_ + (failure-cc-201))))) (_ - (failure-cc-194))))) - (_ - (failure-cc-194))) - (failure-cc-194)))) - (failure-cc-194))) - (_ - (failure-cc-194)))) - (_ - (failure-cc-194))))) - (let (failure-cc-194 - (lambda () - (raw-syntax-case - pat - ((cons - head-195 - tail-196) - (if (identifier? - head-195) - (>>= - (free-identifier=? - head-195 - 'fancy-unquote) - (lambda (same-identifier) - (if same-identifier - (raw-syntax-case - tail-196 - ((cons - head-197 - tail-198) - (let (x - head-197) + (failure-cc-201))) + (failure-cc-201)))) + (failure-cc-201))) + (_ + (failure-cc-201)))) + (_ + (failure-cc-201))))) + (let (failure-cc-201 + (lambda () + (raw-syntax-case + stx-200 + ((cons + head-202 + tail-203) + (if (identifier? + head-202) + (>>= + (free-identifier=? + head-202 + 'fancy-unquote) + (lambda (same-identifier) + (if same-identifier (raw-syntax-case - tail-198 - (() - (pure - x)) + tail-203 + ((cons + head-204 + tail-205) + (let (x + head-204) + (raw-syntax-case + tail-205 + (() + (pure + x)) + (_ + (failure-cc-201))))) (_ - (failure-cc-194))))) - (_ - (failure-cc-194))) - (failure-cc-194)))) - (failure-cc-194))) - (_ - (failure-cc-194))))) - (failure-cc-194))))))) - (fancy-inside - pat)))) - (_ - (failure-cc-209))))) - (_ (failure-cc-209)))) - (_ (failure-cc-209))))) - (failure-cc-209))))))) + (failure-cc-201))) + (failure-cc-201)))) + (failure-cc-201))) + (_ + (failure-cc-201))))) + (failure-cc-201)))))))) + (fancy-inside + pat)))) + (_ + (failure-cc-217))))) + (_ + (failure-cc-217)))) + (_ + (failure-cc-217))))) + (failure-cc-217)))))))) (export (rename ((fancy-syntax-case syntax-case) From 9b91b796bd64a95d0a69ea217178f7b41b641b36 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sat, 17 Oct 2020 17:21:34 -0400 Subject: [PATCH 29/35] use the shorter names in error-messages "fancy-syntax-case" is only used in the implementation, to distinguish between the many different variants of syntax-case in bootstrap.rkt; no need to show that name to the user. --- bootstrap.rkt | 22 +++++++++++----------- examples/dot-dot-dot.kl | 22 +++++++++++----------- 2 files changed, 22 insertions(+), 22 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 527a048c..848f6ebc 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -299,7 +299,7 @@ (define-macros ([fancy-syntax-case (flet [list-of-keywords? (xs) - (generate-syntax-case fancy-syntax-case xs () + (generate-syntax-case syntax-case xs () [() (pure (true))] [(,x ,xs ...) @@ -308,14 +308,14 @@ [_ (pure (false))])] (lambda (stx) - (generate-syntax-case fancy-syntax-case 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 fancy-syntax-case xs () + (generate-syntax-case syntax-case xs () [() (pure (false))] [(,x ,xs ...) @@ -328,9 +328,9 @@ (lambda (keyword) (is-identifier-in-list? keyword keywords))] (flet [fancy-case (scrutinee-name case) - (generate-syntax-case fancy-syntax-case case () + (generate-syntax-case syntax-case case () [(,pat ,rhs) - (generate-syntax-case fancy-syntax-case pat (fancy-unquote fancy-... fancy-_) + (generate-syntax-case syntax-case pat (fancy-unquote fancy-... fancy-_) [() (pure (generate-quasiquote (raw-syntax-case ,scrutinee-name @@ -354,7 +354,7 @@ (failure-cc)) stx)) (syntax-error (list-syntax - ('"fancy-syntax-case: naked symbol" + ('"syntax-case: naked symbol" keyword '"did you mean (unquote symbol)?" '"did you mean to add the symbol to the keyword list?") @@ -367,7 +367,7 @@ ,rhs) stx)) (syntax-error (list-syntax - ('"fancy-syntax-case: the syntax for binding values is (unquote x), found" + ('"syntax-case: the syntax for binding values is (unquote x), found" pat '"instead") stx) @@ -379,7 +379,7 @@ ,rhs) stx)) (syntax-error (list-syntax - ('"fancy-syntax-case: the syntax for binding lists is (,x ...), found" + ('"syntax-case: the syntax for binding lists is (,x ...), found" pat '"instead") stx) @@ -408,7 +408,7 @@ (failure-cc) stx))])])] (flet [fancy-cases (cases inner-cases) - (generate-syntax-case fancy-syntax-case cases () + (generate-syntax-case syntax-case cases () [() (pure inner-cases)] [(,case ,cases ...) @@ -431,7 +431,7 @@ (let [failure-cc (lambda () (syntax-error (list-syntax - ('"fancy-syntax-case: the input" + ('"syntax-case: the input" ,stx-name '"does not match any of the following patterns" ',(map car cases)) @@ -440,7 +440,7 @@ ,outer-cases)) stx)))))))) (syntax-error (list-syntax - ('"fancy-syntax-case:" + ('"syntax-case:" keywords '"does not look like a list of keywords." '"did you forget a () between the input and the cases?") diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index 96a30f2f..766a14ed 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -41,7 +41,7 @@ (let (failure-cc-159 (lambda () (syntax-error - '"fancy-syntax-case call has invalid syntax" + '"syntax-case call has invalid syntax" stx-158))) (let (failure-cc-159 (lambda () @@ -80,7 +80,7 @@ (let (failure-cc-193 (lambda () (syntax-error - '"fancy-syntax-case call has invalid syntax" + '"syntax-case call has invalid syntax" stx-192))) (let (failure-cc-193 (lambda () @@ -121,7 +121,7 @@ (let (failure-cc-163 (lambda () (syntax-error - '"fancy-syntax-case call has invalid syntax" + '"syntax-case call has invalid syntax" stx-162))) (let (failure-cc-163 (lambda () @@ -171,7 +171,7 @@ (let (failure-cc-183 (lambda () (syntax-error - '"fancy-syntax-case call has invalid syntax" + '"syntax-case call has invalid syntax" stx-182))) (let (failure-cc-183 (lambda () @@ -197,7 +197,7 @@ (let (failure-cc-167 (lambda () (syntax-error - '"fancy-syntax-case call has invalid syntax" + '"syntax-case call has invalid syntax" stx-166))) (let (failure-cc-167 (lambda () @@ -348,7 +348,7 @@ stx)) (syntax-error (list-syntax - ('"fancy-syntax-case: the syntax for binding lists is (,x ...), found" + ('"syntax-case: the syntax for binding lists is (,x ...), found" pat '"instead") stx) @@ -415,7 +415,7 @@ stx)) (syntax-error (list-syntax - ('"fancy-syntax-case: the syntax for binding values is (unquote x), found" + ('"syntax-case: the syntax for binding values is (unquote x), found" pat '"instead") stx) @@ -519,7 +519,7 @@ stx)) (syntax-error (list-syntax - ('"fancy-syntax-case: naked symbol" + ('"syntax-case: naked symbol" keyword '"did you mean (unquote symbol)?" '"did you mean to add the symbol to the keyword list?") @@ -593,7 +593,7 @@ (let (failure-cc-189 (lambda () (syntax-error - '"fancy-syntax-case call has invalid syntax" + '"syntax-case call has invalid syntax" stx-188))) (let (failure-cc-189 (lambda () @@ -691,7 +691,7 @@ (cons-list-syntax 'quote (cons-list-syntax - '"fancy-syntax-case: the input" + '"syntax-case: the input" '() stx) stx) @@ -751,7 +751,7 @@ stx)))))))) (syntax-error (list-syntax - ('"fancy-syntax-case:" + ('"syntax-case:" keywords '"does not look like a list of keywords." '"did you forget a () between the input and the cases?") From e18f2630c1bb4b1b14841f8a77b56b471d755c0a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sun, 18 Oct 2020 11:15:58 -0400 Subject: [PATCH 30/35] simplify nested syntax-cases raw-syntax-case only supported shallow pattern-matching, thus requiring us to write several nested raw-syntax-case calls in order to destructure the input. with fancy-syntax-case, this can now be done in a single call. --- examples/datatype-macro.kl | 22 ++++++------ examples/define-syntax-rule.golden | 2 +- examples/define-syntax-rule.kl | 54 ++++++++++++++---------------- examples/mcond.kl | 25 ++++++-------- examples/which-problem.kl | 14 ++++---- 5 files changed, 54 insertions(+), 63 deletions(-) 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/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/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))) From 19e933b2fd2cc2441684bdccdf16551892b82728 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sun, 18 Oct 2020 11:37:40 -0400 Subject: [PATCH 31/35] guards --- bootstrap.rkt | 232 ++++++----- examples/dot-dot-dot-test.golden | 8 +- examples/dot-dot-dot-test.kl | 5 + examples/dot-dot-dot.kl | 684 +++++++++++++++++-------------- 4 files changed, 516 insertions(+), 413 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 848f6ebc..249ba03c 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -327,118 +327,130 @@ (let [keyword? (lambda (keyword) (is-identifier-in-list? keyword keywords))] - (flet [fancy-case (scrutinee-name case) - (generate-syntax-case syntax-case case () - [(,pat ,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 + (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 () - ,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: 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 diff --git a/examples/dot-dot-dot-test.golden b/examples/dot-dot-dot-test.golden index 55a0bd41..f298fe40 100644 --- a/examples/dot-dot-dot-test.golden +++ b/examples/dot-dot-dot-test.golden @@ -1,3 +1,5 @@ -#[dot-dot-dot-test.kl:16.17-16.31]<(1 2 3 4)> : Syntax -#[dot-dot-dot-test.kl:18.17-18.58]<(keyword-prefixed bar baz end-of-list)> : Syntax -#[dot-dot-dot-test.kl:20.17-20.52]<(ordinary-list foo bar baz end-of-list)> : Syntax +#[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 index 27ed34b8..8a255585 100644 --- a/examples/dot-dot-dot-test.kl +++ b/examples/dot-dot-dot-test.kl @@ -7,6 +7,7 @@ (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 @@ -14,6 +15,9 @@ (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 ...)) @@ -21,4 +25,5 @@ (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.kl b/examples/dot-dot-dot.kl index 766a14ed..031bf63c 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -76,35 +76,35 @@ (failure-cc-159))))) (failure-cc-159))))))) (lambda (stx) - (let (stx-192 stx) - (let (failure-cc-193 + (let (stx-198 stx) + (let (failure-cc-199 (lambda () (syntax-error '"syntax-case call has invalid syntax" - stx-192))) - (let (failure-cc-193 + stx-198))) + (let (failure-cc-199 (lambda () (raw-syntax-case - stx-192 + stx-198 ((cons - head-194 - tail-195) + head-200 + tail-201) (raw-syntax-case - tail-195 + tail-201 ((cons - head-196 - tail-197) + head-202 + tail-203) (let (stx-expr - head-196) + head-202) (raw-syntax-case - tail-197 + tail-203 ((cons - head-198 - tail-199) + head-204 + tail-205) (let (keywords - head-198) + head-204) (let (cases - tail-199) + tail-205) (let (stx-name 'stx) (>>= @@ -163,60 +163,148 @@ keyword keywords))) (flet - (fancy-case - (scrutinee-name - case) - (let (stx-182 - case) - (let (failure-cc-183 + (fancy-guard-rhs + (guard-rhs) + (let (stx-166 + guard-rhs) + (let (failure-cc-167 (lambda () (syntax-error '"syntax-case call has invalid syntax" - stx-182))) - (let (failure-cc-183 + stx-166))) + (let (failure-cc-167 (lambda () (raw-syntax-case - stx-182 + stx-166 ((cons - head-184 - tail-185) - (let (pat - head-184) + head-172 + tail-173) + (let (rhs + head-172) (raw-syntax-case - tail-185 - ((cons - head-186 - tail-187) - (let (rhs - head-186) - (raw-syntax-case - tail-187 - (() - (let (stx-166 + 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-167 + (let (failure-cc-175 (lambda () (syntax-error '"syntax-case call has invalid syntax" - stx-166))) - (let (failure-cc-167 + stx-174))) + (let (failure-cc-175 (lambda () (pure (cons-list-syntax 'failure-cc '() stx)))) - (let (failure-cc-167 + (let (failure-cc-175 (lambda () (raw-syntax-case - stx-166 + stx-174 ((cons - head-180 - tail-181) + head-188 + tail-189) (let (pat-head - head-180) + head-188) (let (pat-tail - tail-181) + tail-189) (>>= (make-temporary 'tail) @@ -280,52 +368,52 @@ stx) stx))))))))))))) (_ - (failure-cc-167))))) - (let (failure-cc-167 + (failure-cc-175))))) + (let (failure-cc-175 (lambda () (raw-syntax-case - stx-166 + stx-174 ((cons - head-172 - tail-173) + head-180 + tail-181) (raw-syntax-case - head-172 + head-180 ((cons - head-176 - tail-177) + head-184 + tail-185) (if (identifier? - head-176) + head-184) (>>= (free-identifier=? - head-176 + head-184 'fancy-unquote) (lambda (same-identifier) (if same-identifier (raw-syntax-case - tail-177 + tail-185 ((cons - head-178 - tail-179) + head-186 + tail-187) (let (x - head-178) + head-186) (raw-syntax-case - tail-179 + tail-187 (() (raw-syntax-case - tail-173 + tail-181 ((cons - head-174 - tail-175) + head-182 + tail-183) (if (identifier? - head-174) + head-182) (>>= (free-identifier=? - head-174 + head-182 'fancy-...) (lambda (same-identifier) (if same-identifier (raw-syntax-case - tail-175 + tail-183 (() (if (identifier? x) @@ -354,45 +442,45 @@ stx) stx))) (_ - (failure-cc-167))) - (failure-cc-167)))) - (failure-cc-167))) + (failure-cc-175))) + (failure-cc-175)))) + (failure-cc-175))) (_ - (failure-cc-167)))) + (failure-cc-175)))) (_ - (failure-cc-167))))) + (failure-cc-175))))) (_ - (failure-cc-167))) - (failure-cc-167)))) - (failure-cc-167))) + (failure-cc-175))) + (failure-cc-175)))) + (failure-cc-175))) (_ - (failure-cc-167)))) + (failure-cc-175)))) (_ - (failure-cc-167))))) - (let (failure-cc-167 + (failure-cc-175))))) + (let (failure-cc-175 (lambda () (raw-syntax-case - stx-166 + stx-174 ((cons - head-168 - tail-169) + head-176 + tail-177) (if (identifier? - head-168) + head-176) (>>= (free-identifier=? - head-168 + head-176 'fancy-unquote) (lambda (same-identifier) (if same-identifier (raw-syntax-case - tail-169 + tail-177 ((cons - head-170 - tail-171) + head-178 + tail-179) (let (x - head-170) + head-178) (raw-syntax-case - tail-171 + tail-179 (() (if (identifier? x) @@ -421,17 +509,17 @@ stx) stx))) (_ - (failure-cc-167))))) + (failure-cc-175))))) (_ - (failure-cc-167))) - (failure-cc-167)))) - (failure-cc-167))) + (failure-cc-175))) + (failure-cc-175)))) + (failure-cc-175))) (_ - (failure-cc-167))))) - (let (failure-cc-167 + (failure-cc-175))))) + (let (failure-cc-175 (lambda () (let (keyword - stx-166) + stx-174) (>>= (pure (identifier? @@ -525,25 +613,25 @@ '"did you mean to add the symbol to the keyword list?") stx) stx)))) - (failure-cc-167))))))) - (let (failure-cc-167 + (failure-cc-175))))))) + (let (failure-cc-175 (lambda () (if (identifier? - stx-166) + stx-174) (>>= (free-identifier=? - stx-166 + stx-174 'fancy-_) (lambda (same-identifier) (if same-identifier (pure rhs) - (failure-cc-167)))) - (failure-cc-167)))) - (let (failure-cc-167 + (failure-cc-175)))) + (failure-cc-175)))) + (let (failure-cc-175 (lambda () (raw-syntax-case - stx-166 + stx-174 (() (pure (cons-list-syntax @@ -575,180 +663,176 @@ stx) stx))) (_ - (failure-cc-167))))) - (failure-cc-167))))))))))) - (_ - (failure-cc-183))))) - (_ - (failure-cc-183))))) - (_ - (failure-cc-183))))) - (failure-cc-183))))) - (flet - (fancy-cases - (cases - inner-cases) - (let (stx-188 - cases) - (let (failure-cc-189 - (lambda () - (syntax-error - '"syntax-case call has invalid syntax" - stx-188))) - (let (failure-cc-189 - (lambda () - (raw-syntax-case - stx-188 - ((cons - head-190 - tail-191) - (let (case - head-190) - (let (cases - tail-191) - (>>= - (fancy-case - stx-name - case) - (lambda (inner-case) - (fancy-cases - cases - (cons-list-syntax - 'let + (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 - 'failure-cc (cons-list-syntax + 'failure-cc (cons-list-syntax - 'lambda (cons-list-syntax - '() + 'lambda (cons-list-syntax - inner-case '() + (cons-list-syntax + inner-case + '() + stx) stx) stx) + '() stx) + stx) + (cons-list-syntax + inner-cases '() stx) stx) - (cons-list-syntax - inner-cases - '() - stx) - stx) - stx))))))) - (_ - (failure-cc-189))))) - (let (failure-cc-189 - (lambda () - (raw-syntax-case - stx-188 - (() - (pure - inner-cases)) - (_ - (failure-cc-189))))) - (failure-cc-189)))))) - (>>= - (fancy-cases - cases - (cons-list-syntax - 'failure-cc - '() - stx)) - (lambda (outer-cases) - (pure - (cons-list-syntax - 'let + 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 - stx-name (cons-list-syntax - stx-expr - '() + stx-name + (cons-list-syntax + stx-expr + '() + stx) stx) - stx) - (cons-list-syntax (cons-list-syntax - 'let (cons-list-syntax + 'let (cons-list-syntax - 'failure-cc (cons-list-syntax + 'failure-cc (cons-list-syntax - 'lambda (cons-list-syntax - '() + 'lambda (cons-list-syntax + '() (cons-list-syntax - 'syntax-error (cons-list-syntax + 'syntax-error (cons-list-syntax - 'list-syntax (cons-list-syntax + '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 + 'quote (cons-list-syntax - 'quote - (cons-list-syntax - '"does not match any of the following patterns" - '() - stx) + '"syntax-case: the input" + '() stx) + stx) + (cons-list-syntax + stx-name (cons-list-syntax (cons-list-syntax 'quote (cons-list-syntax - (map - car - cases) + '"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) - stx) - (cons-list-syntax - 'stx - '() + (cons-list-syntax + 'stx + '() + stx) stx) stx) - stx) - (cons-list-syntax - 'stx - '() + (cons-list-syntax + 'stx + '() + stx) stx) stx) + '() stx) - '() stx) stx) + '() stx) + stx) + (cons-list-syntax + outer-cases '() stx) stx) - (cons-list-syntax - outer-cases - '() - stx) stx) + '() stx) - '() stx) - stx) - stx)))))))) + stx))))))))) (syntax-error (list-syntax ('"syntax-case:" @@ -757,35 +841,35 @@ '"did you forget a () between the input and the cases?") stx))))))))) (_ - (failure-cc-193))))) + (failure-cc-199))))) (_ - (failure-cc-193)))) + (failure-cc-199)))) (_ - (failure-cc-193))))) - (failure-cc-193))))))) + (failure-cc-199))))) + (failure-cc-199))))))) (fancy-quasiquote (lambda (stx) - (let (stx-216 stx) - (let (failure-cc-217 + (let (stx-222 stx) + (let (failure-cc-223 (lambda () (syntax-error '"fancy-quasiquote call has invalid syntax" - stx-216))) - (let (failure-cc-217 + stx-222))) + (let (failure-cc-223 (lambda () (raw-syntax-case - stx-216 + stx-222 ((cons - head-218 - tail-219) + head-224 + tail-225) (raw-syntax-case - tail-219 + tail-225 ((cons - head-220 - tail-221) - (let (pat head-220) + head-226 + tail-227) + (let (pat head-226) (raw-syntax-case - tail-221 + tail-227 (() (let (stx-name (cons-list-syntax @@ -800,33 +884,33 @@ (flet (fancy-inside (pat) - (let (stx-200 + (let (stx-206 pat) - (let (failure-cc-201 + (let (failure-cc-207 (lambda () (syntax-error '"fancy-quasiquote call has invalid syntax" - stx-200))) - (let (failure-cc-201 + stx-206))) + (let (failure-cc-207 (lambda () (let (x - stx-200) + stx-206) (pure (pair-list-syntax 'quote x stx))))) - (let (failure-cc-201 + (let (failure-cc-207 (lambda () (raw-syntax-case - stx-200 + stx-206 ((cons - head-214 - tail-215) + head-220 + tail-221) (let (head - head-214) + head-220) (let (tail - tail-215) + tail-221) (>>= (fancy-inside head) @@ -850,52 +934,52 @@ stx) stx))))))))) (_ - (failure-cc-201))))) - (let (failure-cc-201 + (failure-cc-207))))) + (let (failure-cc-207 (lambda () (raw-syntax-case - stx-200 + stx-206 ((cons - head-206 - tail-207) + head-212 + tail-213) (raw-syntax-case - head-206 + head-212 ((cons - head-210 - tail-211) + head-216 + tail-217) (if (identifier? - head-210) + head-216) (>>= (free-identifier=? - head-210 + head-216 'fancy-unquote) (lambda (same-identifier) (if same-identifier (raw-syntax-case - tail-211 + tail-217 ((cons - head-212 - tail-213) + head-218 + tail-219) (let (head - head-212) + head-218) (raw-syntax-case - tail-213 + tail-219 (() (raw-syntax-case - tail-207 + tail-213 ((cons - head-208 - tail-209) + head-214 + tail-215) (if (identifier? - head-208) + head-214) (>>= (free-identifier=? - head-208 + head-214 'fancy-...) (lambda (same-identifier) (if same-identifier (let (tail - tail-209) + tail-215) (>>= (fancy-inside tail) @@ -914,65 +998,65 @@ stx) stx) stx))))) - (failure-cc-201)))) - (failure-cc-201))) + (failure-cc-207)))) + (failure-cc-207))) (_ - (failure-cc-201)))) + (failure-cc-207)))) (_ - (failure-cc-201))))) + (failure-cc-207))))) (_ - (failure-cc-201))) - (failure-cc-201)))) - (failure-cc-201))) + (failure-cc-207))) + (failure-cc-207)))) + (failure-cc-207))) (_ - (failure-cc-201)))) + (failure-cc-207)))) (_ - (failure-cc-201))))) - (let (failure-cc-201 + (failure-cc-207))))) + (let (failure-cc-207 (lambda () (raw-syntax-case - stx-200 + stx-206 ((cons - head-202 - tail-203) + head-208 + tail-209) (if (identifier? - head-202) + head-208) (>>= (free-identifier=? - head-202 + head-208 'fancy-unquote) (lambda (same-identifier) (if same-identifier (raw-syntax-case - tail-203 + tail-209 ((cons - head-204 - tail-205) + head-210 + tail-211) (let (x - head-204) + head-210) (raw-syntax-case - tail-205 + tail-211 (() (pure x)) (_ - (failure-cc-201))))) + (failure-cc-207))))) (_ - (failure-cc-201))) - (failure-cc-201)))) - (failure-cc-201))) + (failure-cc-207))) + (failure-cc-207)))) + (failure-cc-207))) (_ - (failure-cc-201))))) - (failure-cc-201)))))))) + (failure-cc-207))))) + (failure-cc-207)))))))) (fancy-inside pat)))) (_ - (failure-cc-217))))) + (failure-cc-223))))) (_ - (failure-cc-217)))) + (failure-cc-223)))) (_ - (failure-cc-217))))) - (failure-cc-217)))))))) + (failure-cc-223))))) + (failure-cc-223)))))))) (export (rename ((fancy-syntax-case syntax-case) From 0b52c86f566b910f09f0ebc5645dfa1decb06195 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sun, 18 Oct 2020 13:08:14 -0400 Subject: [PATCH 32/35] simplify using guards --- examples/free-identifier-case.kl | 49 +++++++--------- examples/pmatch.golden | 14 ++--- examples/pmatch.kl | 98 +++++++++++++------------------- 3 files changed, 67 insertions(+), 94 deletions(-) diff --git a/examples/free-identifier-case.kl b/examples/free-identifier-case.kl index bf073c0f..6c118ed6 100644 --- a/examples/free-identifier-case.kl +++ b/examples/free-identifier-case.kl @@ -3,41 +3,30 @@ (import "let.kl") (import (shift "prelude.kl" 1)) (import (shift "identifier.kl" 1)) -(import (shift "quasiquote.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/pmatch.golden b/examples/pmatch.golden index ab065aba..e3b7f6cb 100644 --- a/examples/pmatch.golden +++ b/examples/pmatch.golden @@ -1,12 +1,12 @@ -#[pmatch.kl:99.32-99.33] : Syntax -#[pmatch.kl:100.36-100.37] : Syntax -#[pmatch.kl:101.29-101.30] : Syntax -#[pmatch.kl:102.48-102.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:127.34-127.35]<1> 1) - (:: (pair #[pmatch.kl:127.50-127.51]<2> 2) - (:: (pair #[pmatch.kl:127.66-127.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 1589a69a..631d1270 100644 --- a/examples/pmatch.kl +++ b/examples/pmatch.kl @@ -6,7 +6,7 @@ (import (shift "prelude.kl" 1)) (import (shift "identifier.kl" 1)) -(import (shift "quasiquote.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)) @@ -21,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) @@ -50,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]))))))))]))])) From f2b31085a1de7eff0db10977eca76218125dcc24 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sun, 18 Oct 2020 14:15:21 -0400 Subject: [PATCH 33/35] remove unsused generate-define-syntax --- bootstrap.rkt | 9 --------- 1 file changed, 9 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index 249ba03c..b24a8302 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -169,15 +169,6 @@ ,stx-name))] ,(generate-cases cases `(,failure-cc-name)))))) -(define (generate-define-syntax macro-name stx-name keywords cases) - `(group - ,(generate-define-keywords keywords) - (define-macros - ([,macro-name - (lambda (,stx-name) - ,(generate-syntax-case macro-name stx-name keywords - cases))])))) - ; `(1 ,(list 2 3) ,@(list 4 5) 6) ; => ; '(1 (2 3) 4 5 6) From a6ea37f71662b994e570c2b7870671ab9bf2b7bb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sun, 18 Oct 2020 14:18:02 -0400 Subject: [PATCH 34/35] inline barely-used generate-define-keywords --- bootstrap.rkt | 30 ++++-------------------------- examples/dot-dot-dot.kl | 12 +++++------- 2 files changed, 9 insertions(+), 33 deletions(-) diff --git a/bootstrap.rkt b/bootstrap.rkt index b24a8302..f48873b0 100644 --- a/bootstrap.rkt +++ b/bootstrap.rkt @@ -13,30 +13,6 @@ ; Racket does have convenient syntax-manipulating macros like match, ; quasiquote, and racket-syntax-case. -; (generate-define-keywords (list 'foo 'bar)) -; => -; '(define-macros -; ([foo -; (lambda (stx) -; (syntax-error '"foo used out of context" stx))] -; [bar -; (lambda (stx) -; (syntax-error '"bar used out of context" stx))])) -(define (generate-define-keywords keywords) - (let* ([error-message - (lambda (symbol) - (string-append (symbol->string symbol) - " used out of context"))] - [undefined-macro - (lambda (keyword) - `[,keyword - (lambda (stx) - (syntax-error ',(error-message keyword) stx))])] - [undefined-macros - (map undefined-macro keywords)]) - `(define-macros - ,undefined-macros))) - ; (generate-syntax-case 'my-macro 'stx (list 'keyword) ; (list ; (list '() @@ -285,10 +261,12 @@ '(import (shift "list-syntax.kl" 1)) '(import (shift "temporaries.kl" 1)) - (generate-define-keywords (list 'fancy-unquote 'fancy-... 'fancy-_)) (auto-splice (define-macros - ([fancy-syntax-case + ([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 () [() diff --git a/examples/dot-dot-dot.kl b/examples/dot-dot-dot.kl index 031bf63c..6b127061 100644 --- a/examples/dot-dot-dot.kl +++ b/examples/dot-dot-dot.kl @@ -19,21 +19,19 @@ ((fancy-unquote (lambda (stx) (syntax-error - '"fancy-unquote used out of context" + '"unquote used out of context" stx))) (fancy-... (lambda (stx) (syntax-error - '"fancy-... used out of context" + '"... used out of context" stx))) (fancy-_ (lambda (stx) (syntax-error - '"fancy-_ used out of context" - stx))))) - -(define-macros - ((fancy-syntax-case + '"_ used out of context" + stx))) + (fancy-syntax-case (flet (list-of-keywords? (xs) From d2f9680d27a1e39d3df5012091cdecf37972c09f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Tue, 9 Mar 2021 09:31:39 -0500 Subject: [PATCH 35/35] explain the new plan --- bootstrap/README.md | 77 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 77 insertions(+) create mode 100644 bootstrap/README.md 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.