suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Prune dead code from Honu.

Browse Source 
Approved by Jon Rafkind.
This commit is contained in:
Vincent St-Amour 2011-05-23 17:56:54 -04:00
parent d314331858
commit fcf766c905
8 changed files with 42 additions and 1483 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

83
collects/honu/core/main.rkt
View File

@ -5,7 +5,6 @@
(require racket/class) (require racket/class)
(require "private/honu-typed-scheme.rkt" (require "private/honu-typed-scheme.rkt"
;; "private/honu.ss"
"private/parse.ss" "private/parse.ss"
(for-syntax "private/literals.rkt") (for-syntax "private/literals.rkt")
(for-syntax "private/honu-typed-scheme.rkt") (for-syntax "private/honu-typed-scheme.rkt")
@ -23,19 +22,6 @@
(for-syntax "private/macro.rkt") (for-syntax "private/macro.rkt")
"private/macro.ss") "private/macro.ss")
(define test-x-class
(class object%
(init-field tuna)
(super-new)))
(define x (new test-x-class [tuna 5]))
(define (sql1 . x) #f)
(define (sql2) #f)
(define (sql3) #f)
(define (sql4) #f)
(define (sql5) #f)
(define-for-syntax (syntax-to-string stx) (define-for-syntax (syntax-to-string stx)
(format "original '~a' - ~a" (syntax->datum stx) (to-honu-string stx))) (format "original '~a' - ~a" (syntax->datum stx) (to-honu-string stx)))
@ -51,7 +37,6 @@
(define name (lambda args (apply make-object new-name args)))))])) (define name (lambda args (apply make-object new-name args)))))]))
(provide (rename-out (#%dynamic-honu-module-begin #%module-begin) (provide (rename-out (#%dynamic-honu-module-begin #%module-begin)
;; (honu-top #%top)
(semicolon \; (semicolon \;
) )
(honu-+ +) (honu-+ +)
@ -75,22 +60,10 @@
(expression-comma expression_comma) (expression-comma expression_comma)
) )
#;
(rename-out [honu-print print])
(for-syntax (rename-out [syntax-to-string syntax_to_string])) (for-syntax (rename-out [syntax-to-string syntax_to_string]))
#%top #%top
;; sql nonsense
(rename-out
(sql1 SQL_create_insert)
(sql2 foo)
(sql3 cheese)
(sql4 monkeys)
(sql5 horse))
;; end sql
#%datum #%datum
(for-template #%datum) (for-template #%datum)
datum->syntax datum->syntax
@ -104,7 +77,6 @@
... ...
map map
syntax->list syntax->list
;identifier
expression expression
statement statement
(rename-out (semicolon \; (rename-out (semicolon \;
@ -144,15 +116,10 @@
(for-template #%app) (for-template #%app)
quote quote
... ...
foobar2000
expression expression
str str
;; define-struct
#;
(for-template #%parens #%brackets #%braces)
in-range in-range
honu-struct honu-struct
;; (for-meta 2 (rename-out (honu-syntax syntax)))
(rename-out (rename-out
(struct scheme-struct) (struct scheme-struct)
(syntax real-syntax) (syntax real-syntax)
@ -170,55 +137,5 @@
(honu-syntax syntax) (honu-syntax syntax)
(honu-pattern pattern) (honu-pattern pattern)
(honu-keywords keywords) (honu-keywords keywords)
#;
(honu-scheme scheme2)
(scheme-syntax scheme:syntax) (scheme-syntax scheme:syntax)
)) ))
#;
(provide int real bool obj
function var const
string
-> >->
\;
? :
&& \|\|
/
< > <= >=
!=
cons list
true false
display write newline
#%datum
#%top
#%parens #%brackets #%braces #%angles
#%prefix #%postfix
;; define-honu-syntax
...
(for-syntax ...)
(rename-out (set! =)
(honu-return return)
(honu-if if)
(honu-macro macro)
(honu-time time)
(honu-class class)
(honu+ +)
(honu- -)
(honu* *)
(do do)
(honu-end end)
(modulo %)
(equal? ==)
(string->number stringToNumber)
(number->string numberToString)
(car first)
(cdr rest)
(null empty)
(null? isEmpty)
(pair? isCons)
(#%dynamic-honu-module-begin #%module-begin)
(honu-#%app #%app)
(honu-top #%top-interaction)
(honu-provide provide)
(honu-require require)))

222
collects/honu/core/private/honu-typed-scheme.rkt
View File

@ -28,16 +28,8 @@
(provide (all-defined-out)) (provide (all-defined-out))
;; (define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx))
(begin-for-syntax (begin-for-syntax
;; these functions use parse-block-one
;; (define parse-a-tail-expr #f)
;; (define parse-an-expr #f)
;; (set! parse-a-tail-expr parse-tail-expr)
;; (set! parse-an-expr parse-expr)
(define parse-expr (define parse-expr
;; The given syntax sequence must not be empty ;; The given syntax sequence must not be empty
(let () (let ()
@ -75,15 +67,7 @@
(let ([trans (get-transformer #'pexpr)]) (let ([trans (get-transformer #'pexpr)])
(let-values ([(expr-or-type rest) (trans #'pexpr the-type-or-expression-context)]) (let-values ([(expr-or-type rest) (trans #'pexpr the-type-or-expression-context)])
(cons expr-or-type (cons expr-or-type
(start-operator #'(expr . more))) (start-operator #'(expr . more)))))]
#;
(if (honu-type? expr-or-type)
;; parens as a unary prefix operator
(cons (make-cast-prefix (stx-car (stx-car stx)) expr-or-type)
(start-expr #'(expr . more)))
;; must have been an expression
(cons expr-or-type
(start-operator #'(expr . more))))))]
[((#%braces . pexpr)) [((#%braces . pexpr))
(if (stx-null? #'pexpr) (if (stx-null? #'pexpr)
(raise-syntax-error (raise-syntax-error
@ -165,19 +149,6 @@
(cond (cond
[(null? seq) [(null? seq)
(cond (cond
#;
[(cast-prefix? op)
(let ([after (reverse since)])
(group (append (reverse before)
(list (quasisyntax/loc (op-id op)
(op-cast #,(op-id op)
#,(let ([t (cast-prefix-type op)])
(list (honu-type-stx t)
(honu-type-name-stx t)
(honu-type-pred-stx t)
(honu-type-protect-stx t)))
#,(car after))))
(cdr after))))]
[(prefix? op) [(prefix? op)
(let ([after (reverse since)]) (let ([after (reverse since)])
(group (append (reverse before) (group (append (reverse before)
@ -278,13 +249,6 @@
)) ))
parse-one )])) parse-one )]))
#|
(define-honu-macro (e ... * e ... \;))
(foo . bar ())
x(2)
|#
(define (parse-block stx ctx) (define (parse-block stx ctx)
(let loop ([stx stx]) (let loop ([stx stx])
(parse-block-one ctx (parse-block-one ctx
@ -333,16 +297,6 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
(syntax/loc stx (syntax/loc stx
(define-syntax id (make-honu-infix-transformer rhs)))))) (define-syntax id (make-honu-infix-transformer rhs))))))
#;
(define-honu-syntax honu-provide
(lambda (stx ctx)
(syntax-parse stx
#:literals (semicolon)
[(_ something:id semicolon . rest)
(values #'(provide something)
#'rest)])))
;; (honu-syntax ...)
(define-honu-syntax honu-macro-item (define-honu-syntax honu-macro-item
(lambda (stx ctx) (lambda (stx ctx)
@ -377,23 +331,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
(define (parse-complete-block stx) (define (parse-complete-block stx)
;; (debug "Parsing complete block ~a\n" (syntax->datum stx)) ;; (debug "Parsing complete block ~a\n" (syntax->datum stx))
(with-syntax ([(exprs ...) (parse-block stx the-expression-block-context)]) (with-syntax ([(exprs ...) (parse-block stx the-expression-block-context)])
#'(begin exprs ...)) #'(begin exprs ...)))
#;
(let-values ([(a b)
(parse-block-one
(if (block-context-return? ctx)
the-expression-return-block-context
the-expression-block-context)
stx
(lambda (expr rest)
(values expr rest))
(lambda ()
(raise-syntax-error
#f
"expected a braced block or a statement"
)))])
(debug "Result is ~a and ~a\n" a b)
a))
;; TODO: move these syntax classes to a module ;; TODO: move these syntax classes to a module
(define-syntax-class expr (define-syntax-class expr
[pattern e]) [pattern e])
@ -402,9 +340,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
[pattern (#%parens expr:expression) #:with result #'expr.result]) [pattern (#%parens expr:expression) #:with result #'expr.result])
(define-syntax-class block (define-syntax-class block
[pattern (#%braces statement ...) [pattern (#%braces statement ...)
#:with line #'(honu-unparsed-begin statement ...) #:with line #'(honu-unparsed-begin statement ...)])
#;
(parse-complete-block #'(statement ...))])
;; (debug "Original syntax ~a\n" (syntax->datum stx)) ;; (debug "Original syntax ~a\n" (syntax->datum stx))
(syntax-parse stx (syntax-parse stx
#:literals (else) #:literals (else)
@ -414,80 +350,13 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
(let ([result #'(if condition.result on-true.line on-false.line)]) (let ([result #'(if condition.result on-true.line on-false.line)])
(values (values
(lambda () result) (lambda () result)
#'rest) #'rest))]
#;
(expression-result ctx result (syntax/loc #'rest rest)))]
[(_ condition:paren-expr on-true:block . rest) [(_ condition:paren-expr on-true:block . rest)
;; (debug "used if with no else\n") ;; (debug "used if with no else\n")
(let ([result #'(when condition.result on-true.line)]) (let ([result #'(when condition.result on-true.line)])
(values (values
(lambda () result) (lambda () result)
#'rest) #'rest))])))
#;
(expression-result ctx result #'rest))])))
#|
if (foo){
blah..
} else {
}
|#
#;
(define-honu-syntax honu-if
(lambda (stx ctx)
(define (get-block-or-statement kw rest)
(syntax-parse rest (#%braces)
[((#%braces then ...) . rrest)
(values
#`(honu-unparsed-block #f obj 'obj #f #,(and (block-context-return? ctx)
(stx-null? rest))
. #,(stx-cdr (stx-car rest)))
#'rrest)]
[else
(parse-block-one (if (block-context-return? ctx)
the-expression-return-block-context
the-expression-block-context)
rest
(lambda (expr rest)
(values expr rest))
(lambda ()
(raise-syntax-error
#f
"expected a braced block or a statement"
kw)))]))
(unless (block-context? ctx)
(raise-syntax-error
#f
"allowed only in a block context"
(stx-car stx)))
(syntax-parse stx (#%parens)
[(_ (#%parens test ...) . rest)
(let* ([tests #'(test ...)])
(when (stx-null? tests)
(raise-syntax-error
#f
"missing test expression"
(stx-car stx)
(stx-car (stx-cdr stx))))
(let ([test-expr (parse-expr (syntax->list tests))])
(let-values ([(then-exprs rest) (get-block-or-statement (stx-car stx) #'rest)])
(syntax-case rest (else)
[(else . rest2)
(let-values ([(else-exprs rest) (get-block-or-statement (stx-car rest) #'rest2)])
(expression-result ctx
#`(if (as-test #,test-expr) #,then-exprs #,else-exprs)
rest))]
[_else
(expression-result ctx #`(if (as-test #,test-expr) #,then-exprs (void)) rest)]))))]
[_else
(raise-syntax-error
#f
"expected a parenthesized test after `if' keyword"
(stx-car stx))])))
(define true #t) (define true #t)
(define false #f) (define false #f)
@ -513,11 +382,6 @@ if (foo){
(debug "Honu ~a\n" (syntax->datum stx)) (debug "Honu ~a\n" (syntax->datum stx))
(raise-syntax-error #f "interactive use is not yet supported")) (raise-syntax-error #f "interactive use is not yet supported"))
(define-syntax (foobar2000 stx)
(debug "Called foobar2000 on ~a\n" (syntax->datum stx))
(syntax-case stx ()
[(_ x y ...) #'(debug "foobar2000 ~a\n" x)]))
(define (display2 x y) (define (display2 x y)
(debug "~a ~a" x y)) (debug "~a ~a" x y))
@ -581,88 +445,16 @@ if (foo){
#'(form.result ...)) #'(form.result ...))
body body
body)) body))
#'rest)])
#;
(syntax-parse body #:literals (#%parens honu-for-syntax semicolon)
[(_ (#%parens honu-for-syntax what) semicolon . rest)
(values
(lambda ()
(apply-scheme-syntax
#'(require (for-syntax what))))
#'rest)]))) #'rest)])))
#;
(define-splicing-syntax-class unparsed
[pattern (~seq x ...) #:with result #'(honu-unparsed-begin x ...)])
(define-syntax (honu-unparsed-begin stx) (define-syntax (honu-unparsed-begin stx)
(emit-remark "Honu unparsed begin!" stx) (emit-remark "Honu unparsed begin!" stx)
#;
(emit-remark "Honu unparsed begin" stx)
(debug "honu unparsed begin: ~a at phase ~a\n" (syntax->datum stx) (syntax-local-phase-level)) (debug "honu unparsed begin: ~a at phase ~a\n" (syntax->datum stx) (syntax-local-phase-level))
#'(void) #'(void))
#;
(syntax-case stx ()
[(_) #'(void)]
[(_ . body)
(begin
(debug "Body is ~a\n" #'body)
(let-values ([(code rest) (parse-block-one/2 #'body
the-top-block-context
#;
the-expression-context
#;
the-top-block-context)])
;; (debug "Rest is ~a\n" (syntax->datum rest))
(with-syntax ([code code]
[(rest ...) rest])
(if (stx-null? #'(rest ...))
(syntax/loc stx
code)
#;
(if (raw-scheme? #'code)
(syntax/loc stx
code)
(with-syntax ([(code* ...) #'code])
(syntax/loc stx (honu-unparsed-begin code* ...))))
(syntax/loc stx
(begin code (honu-unparsed-begin rest ...)))
#;
(if (raw-scheme? #'code)
(syntax/loc stx
(begin code (honu-unparsed-begin rest ...)))
(with-syntax ([(code* ...) #'code])
(syntax/loc stx (honu-unparsed-begin code* ... rest ...))))))))]
#;
[(_ . body) (let-values ([(code rest) (parse-block-one the-top-block-context
#'body
values
(lambda ()
(values #'(void) null)))])
(with-syntax ([code code]
[(rest ...) rest])
#'(begin code (honu-unparsed-begin rest ...))))]))
#;
(define-syntax-rule (#%dynamic-honu-module-begin forms ...)
#;
(#%module-begin-typed-scheme
;; (require honu/private/typed-utils)
(honu-unparsed-begin forms ...))
(#%plain-module-begin (honu-unparsed-begin forms ...)))
#;
(define (honu-print arg)
(debug "~a\n" arg))
(define-syntax (#%dynamic-honu-module-begin stx) (define-syntax (#%dynamic-honu-module-begin stx)
(syntax-case stx () (syntax-case stx ()
[(_ forms ...) [(_ forms ...)
(begin (begin
(debug "Module begin ~a\n" (syntax->datum #'(forms ...))) (debug "Module begin ~a\n" (syntax->datum #'(forms ...)))
#'(#%plain-module-begin (honu-unparsed-begin forms ...)) #'(#%plain-module-begin (honu-unparsed-begin forms ...)))]))
#;
(with-syntax ([all (syntax-local-introduce #'(provide (all-defined-out)))])
#'(#%plain-module-begin all (honu-unparsed-begin forms ...))
#;
#'(#%plain-module-begin (provide (all-defined-out)) (honu-unparsed-begin forms ...))))]))

579
collects/honu/core/private/macro.rkt
View File

@ -10,8 +10,6 @@
racket/base) racket/base)
(for-meta -3 (for-meta -3
(only-in "literals.rkt" (#%parens literal-parens))) (only-in "literals.rkt" (#%parens literal-parens)))
#;
(for-template (only-in "literals.rkt" (#%parens literal-parens)))
(for-syntax "debug.ss" (for-syntax "debug.ss"
"contexts.ss" "contexts.ss"
"parse.ss" "parse.ss"
@ -44,9 +42,6 @@
[(any : attribute rest ...) [(any : attribute rest ...)
;; todo: export honu attributes for syntax/parse ;; todo: export honu attributes for syntax/parse
(loop (cons #'(any expr) out) (loop (cons #'(any expr) out)
#'(rest ...))
#;
(loop (cons #'(any attribute) out)
#'(rest ...))] #'(rest ...))]
[(foo rest1 rest ...) [(foo rest1 rest ...)
(loop out #'(rest1 rest ...))] (loop out #'(rest1 rest ...))]
@ -67,24 +62,6 @@
#'(rest1 rest ...)))] #'(rest1 rest ...)))]
[(foo) (reverse (cons #'foo out))]))) [(foo) (reverse (cons #'foo out))])))
#|
(define-for-syntax (convert stx)
(syntax-case stx (...)
[(_ x ...)
|#
#;
(define-for-syntax (get-attributes stx)
(define (attach name attributes)
(list))
(syntax-parse stx #:literals (honu-:)
[(variable:identifier honu-: class:identifier rest ...)
(let ([vs (attach #'variable (syntax-class-attributes (attribute class)))])
(append vs (get-attributes #'(rest ...))))]
[(one rest ...) (append (get-attributes #'one)
(get-attributes #'(rest ...)))]
[else (list)]))
(define-for-syntax (fix-template stx) (define-for-syntax (fix-template stx)
(define (fix-classes stx) (define (fix-classes stx)
(syntax-parse stx #:literals (honu-:) (syntax-parse stx #:literals (honu-:)
@ -92,17 +69,13 @@
(with-syntax ([(rest* ...) (fix-template #'(rest ...))]) (with-syntax ([(rest* ...) (fix-template #'(rest ...))])
(datum->syntax stx (cons #'(~var variable class #:attr-name-separator "_") (datum->syntax stx (cons #'(~var variable class #:attr-name-separator "_")
#'(rest* ...)) #'(rest* ...))
stx) stx))]
#;
#'((~var variable class) rest* ...))]
[(one rest ...) [(one rest ...)
(with-syntax ([one* (fix-template #'one)] (with-syntax ([one* (fix-template #'one)]
[(rest* ...) (fix-template #'(rest ...))]) [(rest* ...) (fix-template #'(rest ...))])
(datum->syntax stx (cons #'one* (datum->syntax stx (cons #'one*
#'(rest* ...)) #'(rest* ...))
stx) stx))]
#;
#'(one* rest* ...))]
[else stx])) [else stx]))
;; removes commas from a pattern ;; removes commas from a pattern
(define (fix-commas stx) (define (fix-commas stx)
@ -114,14 +87,6 @@
[(rest* ...) (fix-commas #'(rest ...))]) [(rest* ...) (fix-commas #'(rest ...))])
(datum->syntax stx (datum->syntax stx
`((~seq ,#'a* (~optional |,|)) ... ,@#'(rest* ...)) `((~seq ,#'a* (~optional |,|)) ... ,@#'(rest* ...))
stx stx)
#;
(datum->syntax stx
(cons
#'a*
(cons
#'(... ...)
#'(rest* ...)))
stx stx))] stx stx))]
[(z rest ...) [(z rest ...)
(with-syntax ([z* (fix-commas #'z)] (with-syntax ([z* (fix-commas #'z)]
@ -133,114 +98,10 @@
(define all-fixes (compose fix-commas fix-classes)) (define all-fixes (compose fix-commas fix-classes))
(all-fixes stx)) (all-fixes stx))
#|
(define-for-syntax (fix-template stx)
[(any \;
(... ...) rest1 rest ...)
(loop (cons #'(semicolon any (... ..)))
#'(rest1 rest ...))]
[((any1 any ...) rest1 rest ...)
(loop (loop out #'(any1 any ...))
#'(rest1 rest ...))]
|#
;; x = 1 + y; ...
#;
(define-honu-syntax honu-macro
(lambda (stx ctx)
(debug "Original macro: ~a\n" (syntax->datum stx))
(syntax-case stx (#%parens #%braces)
[(_ (#%parens honu-literal ...)
(#%braces (#%braces name pattern ...))
(#%braces (#%braces template ...))
. rest)
(with-syntax ([(conventions ...)
(extract-conventions #'(pattern ...))]
[(raw-patterns ...)
(extract-patterns #'(pattern ...))]
[(fixed-template ...)
(fix-template #'(template ...))])
(debug "new template ~a\n" (syntax->datum #'(fixed-template ...)))
(values
(syntax/loc
stx
(begin
#|
(define honu-literal (lambda () (error 'honu-literal "cant use this")))
...
|#
(define-honu-syntax name
(lambda (stx ctx)
(debug "Try to match against pattern ~a. Literals ~a\n" '(name raw-patterns ... . rrest) '(honu-literal ...))
(debug "stx is ~a\n" (syntax->datum stx))
;; (debug "head is ~a\n" (stx-car stx))
;; (debug "= is ~a\n" =)
(debug "my matcher ~a\n"
(syntax-case stx (to set! do honu-end honu-literal ...)
[(name q set! v to m do bb (... ...) honu-end) (syntax->datum #'(bb (... ...)))]
[(name raw-patterns ...)
'ok2]
[(name pattern ...) 'ok5]
[(name v (... ...) honu-literal ...) 'ok4]
[(name v (... ...)) 'ok3]
#;
[(name v (... ...)) (syntax->datum #'(v (... ...)))]
[else 'bad]))
#;
(debug "case pattern ~a\n"
#'(syntax-case stx
(honu-literal ...)
[(name pattern ...)
#'(honu-unparsed-block
#f obj 'obj #f ctx
fixed-template ...)]))
(let ([result (syntax-case stx
#;
(to set! do honu-end)
(honu-literal ...)
#;
[(name q set! v to m do bb (... ...) honu-end) (syntax->datum #'(bb (... ...)))]
[(name pattern ...) 'ok]
[(name raw-patterns ...)
#'(honu-unparsed-block
#f obj 'obj #f ctx
fixed-template ...)]
[else 'fail-boat])])
(debug "result was ~a\n" result))
(syntax-case stx (honu-literal ...)
[(name raw-patterns ... . rrest)
(values
#'(honu-unparsed-block
#f obj 'obj #f ctx
fixed-template ...)
#'rrest)])))
#;
(define-honu-syntax name
(lambda (stx ctx)
(define-conventions honu-conventions conventions ...)
#;
(debug "Hello from ~a transformer. Syntax is ~a\n" 'name (syntax->datum stx))
(syntax-parse stx
#:literals (honu-literal ...)
#:conventions (honu-conventions)
[(name raw-patterns ... . rrest)
(values
#'(honu-unparsed-block
#f obj 'obj #f ctx
fixed-template ...)
#'rrest)])))))
#'rest))])
))
(define-for-syntax (delimiter? x) (define-for-syntax (delimiter? x)
(or (free-identifier=? x #'\;))) (or (free-identifier=? x #'\;)))
(define-syntax (my-ellipses stx) (raise-syntax-error 'my-ellipses "dont use this"))
;; (define-syntax (wrapped stx) (raise-syntax-error 'wrapped "dont use wrap"))
;; just a phase 0 identifier
(define wrapped #f) (define wrapped #f)
(define unwrap #f) (define unwrap #f)
@ -265,9 +126,7 @@
(loop (cons #'(... ...) ellipses) body (cdr stx))] (loop (cons #'(... ...) ellipses) body (cdr stx))]
[(and (identifier? (car stx)) [(and (identifier? (car stx))
(free-identifier=? (car stx) #'\;)) (free-identifier=? (car stx) #'\;))
;; (debug "Found a ; in ~a\n" (syntax->datum stx))
(with-syntax ([all (cdr stx)]) (with-syntax ([all (cdr stx)])
;; (debug "Found a ; -- ~a\n" (syntax->datum #'all))
(syntax-parse #'all (syntax-parse #'all
[((~and x (~not _:stop-class)) ... stop:stop-class y ...) [((~and x (~not _:stop-class)) ... stop:stop-class y ...)
(with-syntax ([(ellipses ...) ellipses] (with-syntax ([(ellipses ...) ellipses]
@ -292,67 +151,12 @@
(loop (cons (reverse-syntax wrapped) all) (syntax->list rest)))] (loop (cons (reverse-syntax wrapped) all) (syntax->list rest)))]
[else (loop (cons head all) tail)]))))) [else (loop (cons head all) tail)])))))
;; rename this to wrap
#;
(define-for-syntax (pull stx)
(define (reverse-syntax stx)
(with-syntax ([(x ...) (reverse (syntax->list stx))])
#'(x ...)))
(define-syntax-class delimiter-class
(pattern x:id #:when (delimiter? #'x)))
(define-syntax-class ellipses-class
(pattern x:id #:when (free-identifier=? #'x #'(... ...))))
(define-syntax-class not-ellipses-class
(pattern x:id #:when (not (free-identifier=? #'x #'(... ...)))))
;; use this if you are defining your own ellipses identifier
#;
(define-syntax-class ellipses-class
#:literals (...)
(pattern my-ellipses))
(if (not (stx-pair? stx))
stx
(let ([stx (reverse (syntax->list stx))])
;; (debug-parse stx (ellipses1:ellipses-class ellipses:ellipses-class ... x ...))
;; (debug "stx is ~a\n" stx)
;; (debug "... = ~a\n" (free-identifier=? #'(... ...) (stx-car stx)))
(syntax-parse stx
[(before:not-ellipses-class ... ellipses1:ellipses-class ellipses:ellipses-class ... delimiter:delimiter-class x ...)
(with-syntax ([(x* ...) (reverse-syntax (pull #'(delimiter x ...)))])
(reverse-syntax
(with-syntax ([wrapped #'wrapped]
[original
(with-syntax ([(ellipses* ...) (map (lambda (_)
#'((... ...) (... ...)))
(syntax->list #'(ellipses1 ellipses ...)))]
[(x-new ...) (generate-temporaries #'(delimiter x ...))])
(reverse-syntax #'(before ... ellipses* ... x-new ...)))]
#;
[original (syntax->datum (reverse-syntax #'(ellipses1 ellipses ... x ...)))])
#'(ellipses1 ellipses ... (wrapped x* ...) unwrap))))]
[(ellipses1:ellipses-class ellipses:ellipses-class ... x ...)
(with-syntax ([(x* ...) (reverse-syntax (pull #'(x ...)))])
(reverse-syntax
(with-syntax ([wrapped #'wrapped]
[original
(with-syntax ([(ellipses* ...) (map (lambda (_)
#'((... ...) (... ...)))
(syntax->list #'(ellipses1 ellipses ...)))]
[(x-new ...) (generate-temporaries #'(x ...))])
(reverse-syntax #'(ellipses* ... x-new ...)))]
#;
[original (syntax->datum (reverse-syntax #'(ellipses1 ellipses ... x ...)))])
#'(ellipses1 ellipses ... (wrapped x* ...) unwrap))))]
[(x ...) (with-syntax ([(x* ...) (map pull (syntax->list #'(x ...)))])
(reverse-syntax #'(x* ...)))]))))
;; (begin-for-syntax (trace pull))
(define-for-syntax (unpull stx) (define-for-syntax (unpull stx)
(define-syntax-class ellipses-class (define-syntax-class ellipses-class
(pattern x:id #:when (free-identifier=? #'x #'(... ...)))) (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
(define-syntax-class delimiter-class (define-syntax-class delimiter-class
(pattern x:id #:when (delimiter? #'x))) (pattern x:id #:when (delimiter? #'x)))
;; (debug "unpull ~a\n" (syntax->datum stx))
(syntax-parse stx (syntax-parse stx
#:literals (wrapped unwrap) #:literals (wrapped unwrap)
[((~and z (~not (unwrap _ ...))) ... (unwrap (wrapped x ... delimiter:delimiter-class) ...) rest ...) [((~and z (~not (unwrap _ ...))) ... (unwrap (wrapped x ... delimiter:delimiter-class) ...) rest ...)
@ -372,95 +176,9 @@
#'(x* ...))] #'(x* ...))]
[else stx])) [else stx]))
;; rename this to unwrap
#;
(define-syntax (unpull stx)
(define-syntax-class ellipses-class
(pattern x:id #:when (free-identifier=? #'x #'(... ...))))
(define (do-it stx)
(syntax-parse stx
#:literals (wrapped)
[((wrapped x ... y) ...)
(with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))])
#'(x1 ... y ...))]
[((wrapped x ...) ellipses1:ellipses-class ellipses:ellipses-class ...)
(with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
#'(x* ... ellipses1 ellipses ...))]
[(x ...) (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
#'(x* ...))]
[else stx]))
(syntax-case stx ()
[(_ x ...) (do-it #'(x ...))]))
(provide (for-syntax unpull)) (provide (for-syntax unpull))
#;
(define-honu-syntax unpull
(lambda (stx ctx)
(define-syntax-class ellipses-class
(pattern x:id #:when (free-identifier=? #'x #'(... ...))))
(define (do-it stx)
(syntax-parse stx
#:literals (wrapped)
[((wrapped x ... y) ...)
(with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))])
#'(x1 ... y ...))]
[((wrapped x ...) ellipses1:ellipses-class ellipses:ellipses-class ...)
(with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
#'(x* ... ellipses1 ellipses ...))]
[(x ...) (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
(debug "x* is ~a\n" #'(x* ...))
#'(x* ...))]
[else stx]))
(syntax-case stx ()
[(_ x ...) (values (do-it #'(x ...))
#'())])))
#;
(define-syntax (test stx)
(syntax-case stx ()
[(_ x ...)
(begin
(pretty-print (syntax->datum (pull #'(x ...))))
(pretty-print (syntax->datum (unpull (pull #'(x ...)))))
#'1)]))
(define-syntax (my-syntax stx)
(syntax-case stx ()
[(_ name pattern template)
(with-syntax ([wrap-it (pull #'template)])
#'(define-syntax (name stx)
(syntax-case stx ()
[pattern #'wrap-it]
[else (raise-syntax-error 'name (format "~a does not match pattern ~a"
(syntax->datum stx)
'pattern))]
)))]))
#;
(define-syntax (honu-unparsed-expr stx)
(define (fix stx)
(debug "Fix ~a\n" (syntax->datum stx))
(syntax-parse stx #:literals (honu-syntax #%parens)
[(honu-syntax (#%parens x ...) y ...)
(with-syntax ([(y* ...) (fix #'(y ...))])
#'(x ... y* ...))]
[(z x ...)
(with-syntax ([z* (fix #'z)]
[(x* ...) (fix #'(x ...))])
#'(z* x* ...))]
[else stx]
))
(debug "unparsed expr ~a\n" stx)
(fix (stx-cdr stx)))
(define-syntax (test2 stx)
(syntax-case stx ()
[(_ x ...)
(begin
(with-syntax ([pulled (pull #'(x ...))])
#'(unpull pulled)))]))
(define-honu-syntax honu-pattern (define-honu-syntax honu-pattern
(lambda (stx ctx) (lambda (stx ctx)
(syntax-parse stx #:literal-sets ([cruft #:at stx]) (syntax-parse stx #:literal-sets ([cruft #:at stx])
@ -493,28 +211,11 @@
final-pattern))))) final-pattern)))))
#'rest)]))) #'rest)])))
(define foobar 0)
(define-honu-syntax honu-infix-macro (define-honu-syntax honu-infix-macro
(lambda (stx ctx) (lambda (stx ctx)
(debug "Infix macro!\n") (debug "Infix macro!\n")
(define-splicing-syntax-class patterns (define-splicing-syntax-class patterns
#:literal-sets ([cruft #:phase (syntax-local-phase-level)]) #:literal-sets ([cruft #:phase (syntax-local-phase-level)])
#;
[pattern (~seq x ...)
#:with (template ...) '()
#:with (code ...) '()
#:with (fixed ...) '()
#:when (begin
(debug "Trying to parse ~a\n" (syntax->datum #'(x ...)))
#f)]
#;
[pattern (~seq (#%braces template ...)
(#%braces code ...))
#:with (fixed ...) '()
#:when (begin
(debug "Got template as ~a. Code is ~a\n" (syntax->datum #'(template ...)) (syntax->datum #'(code ...)))
#f)]
[pattern (~seq (#%braces template ...) [pattern (~seq (#%braces template ...)
(#%braces code ...)) (#%braces code ...))
#:with (fixed ...) (fix-template #'(template ...))]) #:with (fixed ...) (fix-template #'(template ...))])
@ -528,38 +229,19 @@
. rest) . rest)
#:with result #:with result
(list (list
(with-syntax ( (with-syntax ()
#;
[(fixed ...) (fix-template #'(template ...))]
#;
[first-pattern (stx-car #'(template ...))]
#;
[your-bracket (datum->syntax #'name '#%brackets #'name)]
#;
[your-braces (datum->syntax #'name '#%braces #'name)]
#;
[your-parens (datum->syntax #'name '#%parens #'name)])
(apply-scheme-syntax (apply-scheme-syntax
(syntax/loc stx (syntax/loc stx
(define-honu-infix-syntax name (define-honu-infix-syntax name
(lambda (stx ctx) (lambda (stx ctx)
#;
(debug "Executing macro `~a' on input `~a'\n" 'name (syntax->datum stx))
(debug "~a pattern is ~a\n" 'name '(pattern.fixed ... ...)) (debug "~a pattern is ~a\n" 'name '(pattern.fixed ... ...))
(syntax-parse stx (syntax-parse stx
#:literal-sets ([cruft #:at name]) #:literal-sets ([cruft #:at name])
#:literals (foobar literals ...) #:literals (literals ...)
[(pattern.fixed ... rrest (... ...)) [(pattern.fixed ... rrest (... ...))
(values (values
#;
(with-syntax ([(real-out (... ...)) #'(code ...)])
(let ([result (let ()
(honu-unparsed-begin #'(real-out (... ...))))])
(lambda () result)))
(begin (begin
(emit-remark "Do macro transformer" (quote-syntax (pattern.code ...))) (emit-remark "Do macro transformer" (quote-syntax (pattern.code ...)))
#;
(debug "Macro transformer `~a'\n" (syntax->datum (quote-syntax (code ...))))
(let ([result (let () (let ([result (let ()
(honu-unparsed-begin pattern.code ...))]) (honu-unparsed-begin pattern.code ...))])
(lambda () (lambda ()
@ -574,82 +256,14 @@
(syntax-parse stx (syntax-parse stx
[out:honu-macro3 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))] [out:honu-macro3 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))]
#;
[(_ (#%parens honu-literal ...)
(#%braces (#%braces name pattern ...))
(#%braces (#%braces template ...))
. rest)
(with-syntax ([pulled (pull #'(template ...))]
[(pattern* ...) (map (lambda (stx)
(if (and (identifier? stx)
(not (ormap (lambda (f)
(free-identifier=? stx f))
(syntax->list #'(honu-literal ...))))
(not (free-identifier=? stx #'(... ...))))
(with-syntax ([x stx])
#'(~and x (~not (~or honu-literal ...))))
stx))
(syntax->list #'(pattern ...)))]
)
(values
(syntax/loc stx
(define-honu-syntax name
(lambda (stx ctx)
;; (define-literal-set literals (honu-literal ...))
(syntax-parse stx
;; #:literal-sets (literals)
#:literals (honu-literal ...)
[(name pattern* ... . rrest)
(with-syntax ([(out (... ...)) (unpull #'pulled)])
(define (X) (raise-syntax-error (syntax->datum #'name) "implement for this context"))
(values
(syntax/loc stx (honu-unparsed-expr (honu-syntax (#%parens out (... ...)))))
;; this is sort of ugly, is there a better way?
#;
(cond
[(type-context? ctx) (X)]
[(type-or-expression-context? ctx) (X)]
[(expression-context? ctx) (syntax/loc stx (honu-unparsed-expr (out (... ...))))]
[(expression-block-context? ctx)
(syntax/loc stx
(honu-unparsed-begin (honu-syntax #%parens (out (... ...)))))]
[(block-context? ctx)
(syntax/loc stx
(honu-unparsed-begin out (... ...)))]
[(variable-definition-context? ctx) (X)]
[(constant-definition-context? ctx) (X)]
[(function-definition-context? ctx) (X)]
[(prototype-context? ctx) (X)]
[else (syntax/loc stx (honu-syntax (#%parens (out (... ...)))))])
#;
#'(honu-unparsed-begin out (... ...))
#'rrest)
#;
#'(honu-unparsed-block
#f obj 'obj #f ctx
out (... ...))
#;
(values
#;
#'(honu-unparsed-expr out (... ...))
#'(honu-unparsed-block
#f obj 'obj #f ctx
out (... ...) rrest)
#;
#'rrest))]))))
#'rest))]
[(_ (m x ...) [(_ (m x ...)
(z y ...) (z y ...)
#;
(#%braces (#%braces name pattern ...))
. rest) . rest)
(begin (begin
(debug "Got literals ~a\n" #'(x ...)) (debug "Got literals ~a\n" #'(x ...))
(debug "M is ~a, = to #%parens is ~a\n" #'m (free-identifier=? #'#%parens #'m)) (debug "M is ~a, = to #%parens is ~a\n" #'m (free-identifier=? #'#%parens #'m))
(debug "Z is ~a, = to #%braces is ~a\n" #'z (free-identifier=? #'#%braces #'z)) (debug "Z is ~a, = to #%braces is ~a\n" #'z (free-identifier=? #'#%braces #'z))
(debug "Rest is ~a\n" (syntax->datum #'rest)) (debug "Rest is ~a\n" (syntax->datum #'rest))
#;
(debug "Got name ~a pattern ~a\n" #'name #'(pattern ...))
(raise-syntax-error 'honu-macro "f1" stx))] (raise-syntax-error 'honu-macro "f1" stx))]
[else (raise-syntax-error 'honu-macro "fail" stx)] [else (raise-syntax-error 'honu-macro "fail" stx)]
))) )))
@ -658,21 +272,6 @@
(lambda (stx ctx) (lambda (stx ctx)
(define-splicing-syntax-class patterns (define-splicing-syntax-class patterns
#:literal-sets ([cruft #:phase (syntax-local-phase-level)]) #:literal-sets ([cruft #:phase (syntax-local-phase-level)])
#;
[pattern (~seq x ...)
#:with (template ...) '()
#:with (code ...) '()
#:with (fixed ...) '()
#:when (begin
(debug "Trying to parse ~a\n" (syntax->datum #'(x ...)))
#f)]
#;
[pattern (~seq (#%braces template ...)
(#%braces code ...))
#:with (fixed ...) '()
#:when (begin
(debug "Got template as ~a. Code is ~a\n" (syntax->datum #'(template ...)) (syntax->datum #'(code ...)))
#f)]
[pattern (~seq (#%braces template ...) [pattern (~seq (#%braces template ...)
(#%braces code ...)) (#%braces code ...))
#:with (fixed ...) (fix-template #'(template ...))]) #:with (fixed ...) (fix-template #'(template ...))])
@ -686,54 +285,19 @@
. rest) . rest)
#:with result #:with result
(list (list
(with-syntax ( (with-syntax ()
#;
[(fixed ...) (fix-template #'(template ...))]
#;
[first-pattern (stx-car #'(template ...))]
#;
[your-bracket (datum->syntax #'name '#%brackets #'name)]
#;
[your-braces (datum->syntax #'name '#%braces #'name)]
#;
[your-parens (datum->syntax #'name '#%parens #'name)])
;;(debug "Ok macro3 go!\n")
#;
#'(define-honu-syntax name
(lambda (stx ctx)
(syntax-parse stx #:literals (your-parens your-bracket literals ...)
[(fixed ... rrest (... ...))
(values
#;
(with-syntax ([(real-out (... ...)) #'(code ...)])
(let ([result (honu-unparsed-begin #'(real-out (... ...)))])
(lambda () result)))
(let ([result (honu-unparsed-begin code ...)])
(lambda () result))
#'(rrest (... ...)))])))
#;
(debug "Original pattern ~a\n" (syntax->datum #'(pattern.fixed ... rrest (... ...))))
(apply-scheme-syntax (apply-scheme-syntax
(syntax/loc stx (syntax/loc stx
(define-honu-syntax name (define-honu-syntax name
(lambda (stx ctx) (lambda (stx ctx)
#;
(debug "Executing macro `~a' on input `~a'\n" 'name (syntax->datum stx))
(debug "~a pattern is ~a\n" 'name '(pattern.fixed ... ...)) (debug "~a pattern is ~a\n" 'name '(pattern.fixed ... ...))
(syntax-parse stx (syntax-parse stx
#:literal-sets ([cruft #:at name]) #:literal-sets ([cruft #:at name])
#:literals (foobar literals ...) #:literals (literals ...)
[(pattern.fixed ... rrest (... ...)) [(pattern.fixed ... rrest (... ...))
(values (values
#;
(with-syntax ([(real-out (... ...)) #'(code ...)])
(let ([result (let ()
(honu-unparsed-begin #'(real-out (... ...))))])
(lambda () result)))
(begin (begin
(emit-remark "Do macro transformer" (quote-syntax (pattern.code ...))) (emit-remark "Do macro transformer" (quote-syntax (pattern.code ...)))
#;
(debug "Macro transformer `~a'\n" (syntax->datum (quote-syntax (code ...))))
(let ([result (let () (let ([result (let ()
(honu-unparsed-begin pattern.code ...))]) (honu-unparsed-begin pattern.code ...))])
(lambda () (lambda ()
@ -743,15 +307,6 @@
... ...
[else (raise-syntax-error 'name "bad syntax")] [else (raise-syntax-error 'name "bad syntax")]
)))))) ))))))
#;
(with-syntax ([parsed (let-values ([(out rest*)
(parse-block-one/2 #'(code ...)
the-expression-context)])
out)])
(syntax/loc stx
(define-honu-syntax name
(lambda (stx ctx)
parsed))))
#'rest)]) #'rest)])
(define-syntax-class honu-macro2 (define-syntax-class honu-macro2
#:literals (#%parens #%braces) #:literals (#%parens #%braces)
@ -769,15 +324,6 @@
(syntax-parse stx #:literals (semicolon) (syntax-parse stx #:literals (semicolon)
[(_ semicolon rrest (... ...)) [(_ semicolon rrest (... ...))
#'(rrest (... ...))])))))) #'(rrest (... ...))]))))))
#;
(with-syntax ([parsed (let-values ([(out rest*)
(parse-block-one/2 #'(code ...)
the-expression-context)])
out)])
(syntax/loc stx
(define-honu-syntax name
(lambda (stx ctx)
parsed))))
#'rest)]) #'rest)])
(define-syntax-class honu-macro1 (define-syntax-class honu-macro1
@ -812,39 +358,8 @@
(define (X) (raise-syntax-error (syntax->datum #'name) "implement for this context")) (define (X) (raise-syntax-error (syntax->datum #'name) "implement for this context"))
(values (values
(syntax/loc stx (honu-unparsed-expr (honu-syntax (#%parens out (... ...))))) (syntax/loc stx (honu-unparsed-expr (honu-syntax (#%parens out (... ...)))))
;; this is sort of ugly, is there a better way?
#;
(cond
[(type-context? ctx) (X)]
[(type-or-expression-context? ctx) (X)]
[(expression-context? ctx) (syntax/loc stx (honu-unparsed-expr (out (... ...))))]
[(expression-block-context? ctx)
(syntax/loc stx
(honu-unparsed-begin (honu-syntax #%parens (out (... ...)))))]
[(block-context? ctx)
(syntax/loc stx
(honu-unparsed-begin out (... ...)))]
[(variable-definition-context? ctx) (X)]
[(constant-definition-context? ctx) (X)]
[(function-definition-context? ctx) (X)]
[(prototype-context? ctx) (X)]
[else (syntax/loc stx (honu-syntax (#%parens (out (... ...)))))])
#;
#'(honu-unparsed-begin out (... ...))
#'rrest) #'rrest)
#; )]))))
#'(honu-unparsed-block
#f obj 'obj #f ctx
out (... ...))
#;
(values
#;
#'(honu-unparsed-expr out (... ...))
#'(honu-unparsed-block
#f obj 'obj #f ctx
out (... ...) rrest)
#;
#'rrest))]))))
#'rest))]) #'rest))])
(debug "Executing honu macro\n") (debug "Executing honu macro\n")
(syntax-parse stx (syntax-parse stx
@ -852,94 +367,14 @@
[out:honu-macro3 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))] [out:honu-macro3 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))]
[out:honu-macro2 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))] [out:honu-macro2 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))]
#;
[(_ (#%parens honu-literal ...)
(#%braces (#%braces name pattern ...))
(#%braces (#%braces template ...))
. rest)
(with-syntax ([pulled (pull #'(template ...))]
[(pattern* ...) (map (lambda (stx)
(if (and (identifier? stx)
(not (ormap (lambda (f)
(free-identifier=? stx f))
(syntax->list #'(honu-literal ...))))
(not (free-identifier=? stx #'(... ...))))
(with-syntax ([x stx])
#'(~and x (~not (~or honu-literal ...))))
stx))
(syntax->list #'(pattern ...)))]
)
(values
(syntax/loc stx
(define-honu-syntax name
(lambda (stx ctx)
;; (define-literal-set literals (honu-literal ...))
(syntax-parse stx
;; #:literal-sets (literals)
#:literals (honu-literal ...)
[(name pattern* ... . rrest)
(with-syntax ([(out (... ...)) (unpull #'pulled)])
(define (X) (raise-syntax-error (syntax->datum #'name) "implement for this context"))
(values
(syntax/loc stx (honu-unparsed-expr (honu-syntax (#%parens out (... ...)))))
;; this is sort of ugly, is there a better way?
#;
(cond
[(type-context? ctx) (X)]
[(type-or-expression-context? ctx) (X)]
[(expression-context? ctx) (syntax/loc stx (honu-unparsed-expr (out (... ...))))]
[(expression-block-context? ctx)
(syntax/loc stx
(honu-unparsed-begin (honu-syntax #%parens (out (... ...)))))]
[(block-context? ctx)
(syntax/loc stx
(honu-unparsed-begin out (... ...)))]
[(variable-definition-context? ctx) (X)]
[(constant-definition-context? ctx) (X)]
[(function-definition-context? ctx) (X)]
[(prototype-context? ctx) (X)]
[else (syntax/loc stx (honu-syntax (#%parens (out (... ...)))))])
#;
#'(honu-unparsed-begin out (... ...))
#'rrest)
#;
#'(honu-unparsed-block
#f obj 'obj #f ctx
out (... ...))
#;
(values
#;
#'(honu-unparsed-expr out (... ...))
#'(honu-unparsed-block
#f obj 'obj #f ctx
out (... ...) rrest)
#;
#'rrest))]))))
#'rest))]
[(_ (m x ...) [(_ (m x ...)
(z y ...) (z y ...)
#;
(#%braces (#%braces name pattern ...))
. rest) . rest)
(begin (begin
(debug "Got literals ~a\n" #'(x ...)) (debug "Got literals ~a\n" #'(x ...))
(debug "M is ~a, = to #%parens is ~a\n" #'m (free-identifier=? #'#%parens #'m)) (debug "M is ~a, = to #%parens is ~a\n" #'m (free-identifier=? #'#%parens #'m))
(debug "Z is ~a, = to #%braces is ~a\n" #'z (free-identifier=? #'#%braces #'z)) (debug "Z is ~a, = to #%braces is ~a\n" #'z (free-identifier=? #'#%braces #'z))
(debug "Rest is ~a\n" (syntax->datum #'rest)) (debug "Rest is ~a\n" (syntax->datum #'rest))
#;
(debug "Got name ~a pattern ~a\n" #'name #'(pattern ...))
(raise-syntax-error 'honu-macro "f1" stx))] (raise-syntax-error 'honu-macro "f1" stx))]
[else (raise-syntax-error 'honu-macro "fail" stx)] [else (raise-syntax-error 'honu-macro "fail" stx)]
))) )))
;; (my-syntax guz (_ display (#%parens x ...)) (+ x ...))
;; (guz display (#%parens 1 2 3 4))
;; (local-expand stx 'expression (list #'wrapped))
#|
(begin-for-syntax
(trace pull))
(test display (#%parens x))
(test display (#%parens x ... ...) ...)
|#

196
collects/honu/core/private/more.rkt
View File

@ -29,40 +29,23 @@
(datum->syntax lexical consed lexical)) (datum->syntax lexical consed lexical))
(define (replace-commas stuff) (define (replace-commas stuff)
;; (debug "Replace commas with: ~a\n" (syntax->datum stuff))
(syntax-parse stuff #:literals (ellipses-comma ellipses-comma*) (syntax-parse stuff #:literals (ellipses-comma ellipses-comma*)
[((ellipses-comma* z ...) thing blah ...) [((ellipses-comma* z ...) thing blah ...)
#;
(debug "Thing ~a and blah ~a replaced ~a\n" #'thing #'(blah ...) (replace-commas #'(thing blah ...)))
(with-syntax ([(rest ...) (replace-commas #'(thing blah ...))]) (with-syntax ([(rest ...) (replace-commas #'(thing blah ...))])
(datum->syntax stuff (datum->syntax stuff
#'(z ... honu-comma rest ...) #'(z ... honu-comma rest ...)
;; `(1 ,#'(z ...) ,#'honu-comma ,#'(rest ...)) ;; `(1 ,#'(z ...) ,#'honu-comma ,#'(rest ...))
#;
(append (syntax->list #'(z ...)) (cons #'honu-comma #'(rest ...)))
stuff stuff
stuff) stuff))]
#;
#'(z honu-comma rest ...))]
[((ellipses-comma z) thing blah ...) [((ellipses-comma z) thing blah ...)
#;
(debug "Thing ~a and blah ~a replaced ~a\n" #'thing #'(blah ...) (replace-commas #'(thing blah ...)))
(with-syntax ([(rest ...) (replace-commas #'(thing blah ...))]) (with-syntax ([(rest ...) (replace-commas #'(thing blah ...))])
#;
(combine-syntax stuff #'z #'honu-comma #'(rest ...))
(datum->syntax stuff (cons #'z (cons #'honu-comma #'(rest ...))) (datum->syntax stuff (cons #'z (cons #'honu-comma #'(rest ...)))
stuff stuff
stuff) stuff))]
#;
#'(z honu-comma rest ...))]
[(front (ellipses-comma* z ...) thing more ...) [(front (ellipses-comma* z ...) thing more ...)
(with-syntax ([front* (replace-commas #'front)] (with-syntax ([front* (replace-commas #'front)]
[(rest* ...) (replace-commas #'(thing more ...))]) [(rest* ...) (replace-commas #'(thing more ...))])
(datum->syntax stuff #'(front z ... honu-comma rest* ...) stuff stuff) (datum->syntax stuff #'(front z ... honu-comma rest* ...) stuff stuff))]
#;
(datum->syntax stuff (cons #'front* (cons #'(z ...) (cons #'honu-comma #'(rest* ...))))
stuff
stuff))]
[(front (ellipses-comma z) thing more ...) [(front (ellipses-comma z) thing more ...)
(define (maybe-apply-raw stx) (define (maybe-apply-raw stx)
(syntax-parse stuff #:literals (ellipses-comma) (syntax-parse stuff #:literals (ellipses-comma)
@ -75,35 +58,14 @@
(datum->syntax stuff (cons #'front* (cons #'z (cons #'honu-comma #'(rest* ...)))) (datum->syntax stuff (cons #'front* (cons #'z (cons #'honu-comma #'(rest* ...))))
stuff stuff
stuff))] stuff))]
#;
[(front (ellipses-comma (z ...)) thing more ...)
(define (maybe-apply-raw stx)
(syntax-parse stuff #:literals (ellipses-comma)
[(front (ellipses-comma x) . rest)
(if (raw-scheme? #'x)
(apply-scheme-syntax stx)
stx)]))
(with-syntax ([front* (replace-commas #'front)]
[(rest* ...) (replace-commas #'(thing more ...))])
(datum->syntax stuff (cons #'front*
(cons (datum->syntax stuff #'(z ...) stuff stuff)
(cons #'honu-comma #'(rest* ...))))
stuff
stuff))]
#;
[((ellipses-comma (z ...))) (datum->syntax stuff #'(z ...) stuff stuff)]
[((ellipses-comma* z ...)) (datum->syntax stuff #'(z ...) stuff stuff)] [((ellipses-comma* z ...)) (datum->syntax stuff #'(z ...) stuff stuff)]
[((ellipses-comma z)) (datum->syntax stuff #'(z) stuff stuff)] [((ellipses-comma z)) (datum->syntax stuff #'(z) stuff stuff)]
[(z rest ...) [(z rest ...)
(with-syntax ([z* (replace-commas #'z)] (with-syntax ([z* (replace-commas #'z)]
[(rest* ...) (replace-commas #'(rest ...))]) [(rest* ...) (replace-commas #'(rest ...))])
#;
(combine-syntax stuff #'z #'(rest* ...))
(datum->syntax stuff (datum->syntax stuff
(cons #'z* #'(rest* ...)) (cons #'z* #'(rest* ...))
stuff stuff) stuff stuff))]
#;
#'(z* rest* ...))]
[else stuff])) [else stuff]))
;; (trace replace-commas) ;; (trace replace-commas)
@ -128,9 +90,7 @@
[(rest* ...) (fix #'(rest ...))]) [(rest* ...) (fix #'(rest ...))])
(datum->syntax stuff (cons #'one* (datum->syntax stuff (cons #'one*
#'(rest* ...)) #'(rest* ...))
stuff stuff) stuff stuff))]
#;
#'(one* rest* ...))]
[else stuff])) [else stuff]))
(define (replace2 stuff) (define (replace2 stuff)
(syntax-parse stuff #:literals (ellipses-comma ellipses-repeat #%parens) (syntax-parse stuff #:literals (ellipses-comma ellipses-repeat #%parens)
@ -142,9 +102,7 @@
(cons (cons
#'(... ...) #'(... ...)
#'(rest* ...))) #'(rest* ...)))
stuff stuff)) stuff stuff))]
#;
#'((ellipses-comma a*) (... ...) rest* ...)]
[(a ellipses-comma rest ...) [(a ellipses-comma rest ...)
(with-syntax ([a* (replace #'a)] (with-syntax ([a* (replace #'a)]
[(rest* ...) (replace #'(rest ...))]) [(rest* ...) (replace #'(rest ...))])
@ -154,31 +112,16 @@
(cons (cons
#'(... ...) #'(... ...)
#'(rest* ...))) #'(rest* ...)))
stuff stuff) stuff stuff))]
#;
#'((ellipses-comma a*) (... ...) rest* ...))]
[(z rest ...) [(z rest ...)
(with-syntax ([z* (replace #'z)] (with-syntax ([z* (replace #'z)]
[(rest* ...) (replace #'(rest ...))]) [(rest* ...) (replace #'(rest ...))])
(datum->syntax stuff (datum->syntax stuff
(cons #'z* #'(rest* ...)) (cons #'z* #'(rest* ...))
stuff stuff) stuff stuff))]
#;
#'(z* rest* ...))]
[else stuff])) [else stuff]))
(define (replace stuff) (define (replace stuff)
#|
(debug "Replacing ~a\n" (syntax->datum stuff))
(debug "Local phase level ~a\n" (syntax-local-phase-level))
(debug "Checking..\n")
(syntax-parse stuff
[(a b c rest ...)
(debug "a: ~a\n" #'a)
(debug "b: ~a identifier ~a = , is ~a. honu-comma at ~a\n" #'b (identifier? #'b) (and (identifier? #'b) (free-identifier=? #'b #'honu-comma)) (identifier-binding #'honu-comma))
(debug "c: ~a = ... is ~a\n" #'c (and (identifier? #'c) (free-identifier=? #'c #'(... ...))))]
[else (void)])
|#
(syntax-parse stuff (syntax-parse stuff
#:literals (;; honu-comma #:literals (;; honu-comma
;; FIXME! Use a literal-set and #:at instead of this ;; FIXME! Use a literal-set and #:at instead of this
@ -211,9 +154,7 @@
(with-syntax ([out2 replaced]) (with-syntax ([out2 replaced])
(let ([x #'(apply-scheme-syntax (replace-commas #'out2))]) (let ([x #'(apply-scheme-syntax (replace-commas #'out2))])
(debug "Final syntax ~a\n" (syntax->datum x)) (debug "Final syntax ~a\n" (syntax->datum x))
x)))] x)))]))
#;
[(_ blah ...) (fix #'(blah ...))]))
(define-syntax-rule (honu-syntax-maker maker unparsed) (define-syntax-rule (honu-syntax-maker maker unparsed)
(define-honu-syntax maker (define-honu-syntax maker
@ -228,129 +169,12 @@
[(stx-pair? what) (for-each show-pattern-variables (syntax->list what))] [(stx-pair? what) (for-each show-pattern-variables (syntax->list what))]
[else (debug "~a is *not* a pattern variable\n" what)])) [else (debug "~a is *not* a pattern variable\n" what)]))
#;
(debug "Original code is ~a\n" (syntax->datum #'(expr ...)))
#;
(debug "Expanded is ~a\n" (syntax->datum (expand-syntax-once #'(expr ...))))
#;
(for-each show-pattern-variables (syntax->list #'(expr ...)))
;; outer is relative phase 1, inner is relative phase 0
#|
#'#'(honu-unparsed-begin expr ...)
|#
#;
(syntax (fix-template (syntax (honu-unparsed-begin expr ...))))
#;
(with-syntax ([a #'(fix-template #'(honu-unparsed-begin expr ...))])
#'a)
(debug "Making unparsed syntax with `~a'\n" (syntax->datum #'(expr (... ...)))) (debug "Making unparsed syntax with `~a'\n" (syntax->datum #'(expr (... ...))))
#; #'(fix-template (unparsed expr (... ...))))
(with-syntax ([unparsed (make-unparsed #'(expr ...))])
#'(fix-template unparsed))
#;
(datum->syntax stx
(cons #'fix-template
(cons #'unparsed #'(expr (... ...))))
stx stx)
#;
(let ([original #'(expr (... ...))])
(datum->syntax original
(cons #'fix-template
(cons #'unparsed #'(expr (... ...))))
original original))
#'(fix-template (unparsed expr (... ...)))
#;
#'(fix-template (expr ...))
#;
(apply-scheme-syntax #'(fix-template (expr ...)))
#;
(let ([x #'(fix-template (honu-unparsed-begin expr ...))])
(debug "Final syntax ~a\n" (syntax->datum x))
x)
#;
#'(fix-template 1 2 3)
#;
(with-syntax ([(out ...) (local-expand #'(expr ...) 'expression '())])
#'(honu-unparsed-begin out ...)))
#'rest)] #'rest)]
[else (raise-syntax-error 'maker "you have used this incorrectly")] [else (raise-syntax-error 'maker "you have used this incorrectly")]
)))) ))))
(honu-syntax-maker honu-syntax honu-unparsed-begin) (honu-syntax-maker honu-syntax honu-unparsed-begin)
(honu-syntax-maker honu-expression-syntax honu-unparsed-expr) (honu-syntax-maker honu-expression-syntax honu-unparsed-expr)
#;
(define-honu-syntax honu-syntax
(lambda (stx ctx)
(syntax-parse stx #:literals (semicolon #%parens)
[(_ (#%parens expr ...) semicolon . rest)
(values
(lambda ()
(define (show-pattern-variables what)
(cond
[(syntax-pattern-variable? what) (debug "~a is a pattern variable\n") what]
[(stx-pair? what) (for-each show-pattern-variables (syntax->list what))]
[else (debug "~a is *not* a pattern variable\n" what)]))
(define (make-unparsed code)
(debug "Make unparsed in ~a. expression-context? ~a\n" ctx (expression-context? ctx))
(with-syntax ([(code ...) code])
(cond
[(expression-context? ctx)
(syntax/loc stx (honu-unparsed-expr code ...))]
[else #'(honu-unparsed-begin code ...)])))
#;
(debug "Original code is ~a\n" (syntax->datum #'(expr ...)))
#;
(debug "Expanded is ~a\n" (syntax->datum (expand-syntax-once #'(expr ...))))
#;
(for-each show-pattern-variables (syntax->list #'(expr ...)))
;; outer is relative phase 1, inner is relative phase 0
#|
#'#'(honu-unparsed-begin expr ...)
|#
#;
(syntax (fix-template (syntax (honu-unparsed-begin expr ...))))
#;
(with-syntax ([a #'(fix-template #'(honu-unparsed-begin expr ...))])
#'a)
(debug "Making unparsed syntax???\n")
(with-syntax ([unparsed (make-unparsed #'(expr ...))])
#'(fix-template unparsed))
;; #'(fix-template (honu-unparsed-begin expr ...))
#;
#'(fix-template (expr ...))
#;
(apply-scheme-syntax #'(fix-template (expr ...)))
#;
(let ([x #'(fix-template (honu-unparsed-begin expr ...))])
(debug "Final syntax ~a\n" (syntax->datum x))
x)
#;
#'(fix-template 1 2 3)
#;
(with-syntax ([(out ...) (local-expand #'(expr ...) 'expression '())])
#'(honu-unparsed-begin out ...)))
#'rest)])))

3
collects/honu/core/private/mzscheme.rkt
View File

@ -1,3 +0,0 @@
(module mzscheme mzscheme
(provide (all-from-except mzscheme
string)))

395
collects/honu/core/private/parse.rkt
View File

@ -27,13 +27,6 @@
(provide (all-defined-out)) (provide (all-defined-out))
#;
(begin-for-syntax
(current-failure-handler
(lambda (_ f)
(debug "Failure is ~a\n" (failure->sexpr (simplify-failure f)))
(error 'failed "whatever"))))
(define-syntax-class block (define-syntax-class block
#:literals (#%braces) #:literals (#%braces)
[pattern (#%braces statement ...) [pattern (#%braces statement ...)
@ -47,18 +40,7 @@
body.result)]) body.result)])
(define (syntax-object-position mstart end) (define (syntax-object-position mstart end)
(- (length (syntax->list mstart)) (length (syntax->list end))) (- (length (syntax->list mstart)) (length (syntax->list end))))
#;
(if (stx-null? end)
(length (syntax->list mstart))
(let loop ([start mstart]
[count 0])
;; (debug "Checking ~a vs ~a\n" start end)
(cond
[(stx-null? start) (raise-syntax-error 'honu-macro "the `rest' syntax returned by a honu macro did not return objects at the same syntactic nesting level as the head of the pattern. this is probably because it returned syntax from some inner nesting level such as (if (x + 1 2) more-stuff) where `rest' was (+ 1 2) instead of `more-stuff'" end mstart)]
[(equal? (stx-car start) (stx-car end)) count]
;; [(equal? start end) count]
[else (loop (stx-cdr start) (add1 count))]))))
(define-primitive-splicing-syntax-class (infix-macro-class left-expression context) (define-primitive-splicing-syntax-class (infix-macro-class left-expression context)
#:attributes (result) #:attributes (result)
@ -87,20 +69,6 @@
(debug "Honu expr from transformer `~a' in context ~a transformer ~a\n" (syntax->datum stx) context (get-transformer stx)) (debug "Honu expr from transformer `~a' in context ~a transformer ~a\n" (syntax->datum stx) context (get-transformer stx))
(cond (cond
[(stx-null? stx) (fail)] [(stx-null? stx) (fail)]
#;
[(syntax-parse stx #:literals (honu-syntax #%parens semicolon)
[(honu-syntax (#%parens expr ...) semicolon . rest)
(debug "Parsed honu-syntax rest ~a position ~a out ~a\n"
#'rest (syntax-object-position stx #'rest)
#'(honu-unparsed-begin expr ...))
(list (syntax-object-position stx #'rest)
#'(honu-unparsed-begin expr ...))]
[else #f]
#;
[else #f => (lambda (exprs)
(debug "Ignoring honu-syntax 1!\n")
(list 0 #''()))]
)]
[(get-transformer stx) => (lambda (transformer) [(get-transformer stx) => (lambda (transformer)
(define introducer (make-syntax-introducer)) (define introducer (make-syntax-introducer))
(debug "Transforming honu macro ~a\n" (stx-car stx)) (debug "Transforming honu macro ~a\n" (stx-car stx))
@ -109,9 +77,7 @@
(debug "Result is ~a. Object position is ~a out of expression ~a\n\n" used (syntax-object-position stx (introducer rest)) (syntax->datum stx)) (debug "Result is ~a. Object position is ~a out of expression ~a\n\n" used (syntax-object-position stx (introducer rest)) (syntax->datum stx))
(debug "Used is ~a\n" (syntax->datum (introducer (used)))) (debug "Used is ~a\n" (syntax->datum (introducer (used))))
(list (syntax-object-position stx (introducer rest)) (list (syntax-object-position stx (introducer rest))
(list #f) (list #f))))]
#;
(introducer (used)))))]
[else (fail)]))) [else (fail)])))
@ -122,23 +88,6 @@
(debug "Honu expr ~a\n" stx) (debug "Honu expr ~a\n" stx)
(cond (cond
[(stx-null? stx) (fail)] [(stx-null? stx) (fail)]
#;
[(syntax-parse stx #:literals (honu-syntax #%parens semicolon)
[(honu-syntax (#%parens expr ...) semicolon . rest)
(list #'rest (syntax-object-position stx #'rest)
#'(honu-unparsed-begin expr ...))]
[else #f]
#;
[else #f => (lambda (exprs)
(debug "Ignoring honu-syntax 1!\n")
(list 0 #''()))]
)]
#;
[(syntax-parse stx #:literals (honu-syntax)
[(honu-syntax expr ...) #'(expr ...)]
[else #f]) => (lambda (exprs)
(debug "Ignoring honu-syntax 2!\n")
(list '() 0 exprs))]
[(get-transformer stx) => (lambda (transformer) [(get-transformer stx) => (lambda (transformer)
(define introducer (make-syntax-introducer)) (define introducer (make-syntax-introducer))
(debug "Transforming honu macro ~a\n" (car stx)) (debug "Transforming honu macro ~a\n" (car stx))
@ -150,23 +99,9 @@
[else (syntax-case stx () [else (syntax-case stx ()
[(f . rest) (list 1 #'f)])]))) [(f . rest) (list 1 #'f)])])))
#;
(define-splicing-syntax-class expr
[pattern (~seq f ...) #:with result])
(define-splicing-syntax-class (call context) (define-splicing-syntax-class (call context)
#:literals (honu-comma #%parens) #:literals (honu-comma #%parens)
#;
[pattern (~seq (~var e identifier)
(x (~var arg (expression-1 context)) ...)
#;
(#%parens (~var arg (expression-1 context)) ...))
#:with call
(begin
(debug "Resulting call. e is ~a -- ~a\n" #'e (syntax->datum #'(e arg.result ...)))
#'(e.x arg.result ...))]
[pattern (~seq (~var e honu-identifier) (#%parens rest ...)) #:with call #f [pattern (~seq (~var e honu-identifier) (#%parens rest ...)) #:with call #f
#:when (begin #:when (begin
(debug "Trying a call on ~a and ~a\n" #'e #'(rest ...)) (debug "Trying a call on ~a and ~a\n" #'e #'(rest ...))
@ -183,38 +118,18 @@
#:with call #:with call
(begin (begin
(debug "Resulting call is ~a\n" (syntax->datum #'(e.result arg.result ...))) (debug "Resulting call is ~a\n" (syntax->datum #'(e.result arg.result ...)))
#'(e.result arg.result ...))] #'(e.result arg.result ...))])
#;
[pattern (~seq (~var e honu-identifier
#;
(honu-expr context))
(~var d1 (debug-here (format "call 1 ~a\n" #'e)))
(x
(~var d2 (debug-here (format "call 2 ~a\n" #'x)))
;;#%parens
(~seq (~var arg (ternary context))
(~var d3 (debug-here (format "call 3 ~a\n" #'arg)))
(~optional honu-comma))
...))
#:with call
(begin
(debug "Resulting call is ~a\n" (syntax->datum #'(e.x arg.result ...)))
#'(e.x arg.result ...))])
(define-splicing-syntax-class honu-identifier (define-splicing-syntax-class honu-identifier
[pattern (~seq x:identifier) #:when (not (or (free-identifier=? #'honu-comma #'x) [pattern (~seq x:identifier) #:when (not (or (free-identifier=? #'honu-comma #'x)
(free-identifier=? #'semicolon #'x)) (free-identifier=? #'semicolon #'x)))
)
#:with result #'x]) #:with result #'x])
(define-splicing-syntax-class (expression-simple context) (define-splicing-syntax-class (expression-simple context)
#:literals (#%parens) #:literals (#%parens)
[pattern (~seq (#%parens (~var e (expression-1 context)))) #:with result #'e.result] [pattern (~seq (#%parens (~var e (expression-1 context)))) #:with result #'e.result]
[pattern (~seq (~var e (honu-transformer [pattern (~seq (~var e (honu-transformer
the-expression-context the-expression-context))) #:with result #'e.result]
#;
context))) #:with result #'e.result]
[pattern (~seq x:number) #:with result (begin (debug "got a number ~a\n" #'x) #'x)] [pattern (~seq x:number) #:with result (begin (debug "got a number ~a\n" #'x) #'x)]
[pattern (~seq x:str) #:with result #'x] [pattern (~seq x:str) #:with result #'x]
[pattern (~seq x:honu-identifier) #:with result #'x.x]) [pattern (~seq x:honu-identifier) #:with result #'x.x])
@ -222,17 +137,9 @@
(define-splicing-syntax-class (expression-last context) (define-splicing-syntax-class (expression-last context)
#:literals (#%parens honu-:) #:literals (#%parens honu-:)
#;
[pattern (~seq a 1 2 3 b 4 5 6)]
[pattern (~seq x) #:with result #f #:when (begin (debug "Expression last ~a. Raw? ~a\n" #'x (raw-scheme? #'x)) #f)] [pattern (~seq x) #:with result #f #:when (begin (debug "Expression last ~a. Raw? ~a\n" #'x (raw-scheme? #'x)) #f)]
[pattern (~seq raw:raw-scheme-syntax) #:with result #'raw.x [pattern (~seq raw:raw-scheme-syntax) #:with result #'raw.x]
#;
(begin (debug "raw syntax ~a\n" #'raw)
(if (stx-pair? #'raw)
(stx-car #'raw)
#'raw))]
[pattern (~seq (#%braces code:statement)) [pattern (~seq (#%braces code:statement))
#:with result #'(begin code.result)] #:with result #'(begin code.result)]
@ -240,18 +147,13 @@
[pattern (~seq (#%parens (~var e (expression-1 context)))) #:with result #'e.result] [pattern (~seq (#%parens (~var e (expression-1 context)))) #:with result #'e.result]
[pattern (~seq (~var call (call context))) #:with result #'call.call] [pattern (~seq (~var call (call context))) #:with result #'call.call]
[pattern (~seq (~var e (honu-transformer [pattern (~seq (~var e (honu-transformer
the-expression-context the-expression-context)))
#;
context)))
#:with result #'e.result #:with result #'e.result
#:with rest #'e.rest] #:with rest #'e.rest]
[pattern (~seq x:number) #:with result (begin (debug "got a number ~a\n" #'x) #'x)] [pattern (~seq x:number) #:with result (begin (debug "got a number ~a\n" #'x) #'x)]
[pattern (~seq honu-: id:honu-identifier) #:with result #''id.result] [pattern (~seq honu-: id:honu-identifier) #:with result #''id.result]
[pattern (~seq x:str) #:with result #'x] [pattern (~seq x:str) #:with result #'x]
[pattern (~seq x:honu-identifier) #:with result #'x.x] [pattern (~seq x:honu-identifier) #:with result #'x.x])
#;
[pattern (~seq (~var e (honu-expr context))) #:with result #'e.result]
)
(define-syntax-rule (define-infix-operator name next [operator reducer] ...) (define-syntax-rule (define-infix-operator name next [operator reducer] ...)
(begin (begin
@ -267,37 +169,15 @@
#:with result #:with result
(begin (begin
(debug "Left was ~a\n" left) (debug "Left was ~a\n" left)
#;
(attribute new-right.result)
(apply-scheme-syntax (attribute new-right.result)))) (apply-scheme-syntax (attribute new-right.result))))
(pattern (~seq) #:with result (begin #;(debug "Left is still ~a\n" left) (pattern (~seq) #:with result left))
left)))
(define-splicing-syntax-class (name context) (define-splicing-syntax-class (name context)
(pattern (~seq (~var left2 (next context)) (pattern (~seq (~var left2 (next context))
(~var rest (do-rest context (attribute left2.result)))) (~var rest (do-rest context (attribute left2.result))))
#:with result #:with result
(attribute rest.result))) (attribute rest.result)))))
#;
(define-splicing-syntax-class (name context)
(pattern (~seq (~var left (next context))
(~var op operator-class)
(~var right (name context)))
#:with result
(cond [(attribute right)
((attribute op.func) #'left.result #'right.result)]
[else
#'left.result]))
#;
(pattern (~seq (~var left (next context))
(~optional (~seq (~var op operator-class) (~var right (name context)))))
#:with result
(cond [(attribute right)
((attribute op.func) #'left.result #'right.result)]
[else
#'left.result])))))
@ -376,9 +256,7 @@
(define-splicing-syntax-class (ternary context) (define-splicing-syntax-class (ternary context)
#:literals (honu-? honu-:) #:literals (honu-? honu-:)
[pattern (~seq (~var condition [pattern (~seq (~var condition
(infix-macro context) (infix-macro context))
#;
(expression-1 context))
(~var x1 (debug-here (format "ternary 1 ~a\n" (syntax->datum #'condition.result)))) (~var x1 (debug-here (format "ternary 1 ~a\n" (syntax->datum #'condition.result))))
(~optional (~seq honu-? (~var on-true (ternary context)) (~optional (~seq honu-? (~var on-true (ternary context))
honu-: (~var on-false (ternary context)))) honu-: (~var on-false (ternary context))))
@ -423,12 +301,7 @@
#:with rest #'assignment.rest] #:with rest #'assignment.rest]
[pattern ((#%braces stuff ...) . rest) [pattern ((#%braces stuff ...) . rest)
#:with result #:with result
(do-parse-block #'(stuff ...)) (do-parse-block #'(stuff ...))]
#;
(let-values ([(parsed dont-care)
(parse-block-one/2 #'(stuff ...) context)])
(debug "Parsed ~a. Dont care rest ~a\n" parsed dont-care)
parsed)]
[pattern ((~var x0 (debug-here (format "expression top\n"))) [pattern ((~var x0 (debug-here (format "expression top\n")))
(~var e (ternary context)) (~var e (ternary context))
(~var x1 (debug-here (format "expression top 1 ~a\n" (syntax->datum #'e)))) (~var x1 (debug-here (format "expression top 1 ~a\n" (syntax->datum #'e))))
@ -474,154 +347,28 @@
proc)) proc))
(make-honu-infix-trans proc)) (make-honu-infix-trans proc))
#;
(define-honu-syntax honu-scheme
(lambda (stx ctx)
(syntax-parse stx
[(_ template rest ...) (values #'template #'(rest ...))])))
(define (fix-output stx)
#f
#|
(debug "Fix output ~a\n" (syntax->datum stx))
(when (and (stx-pair? stx) (equal? 'honu-syntax (syntax->datum (stx-car stx))))
(debug "syntax == honu-syntax? ~a\n" (free-identifier=? (stx-car stx) #'honu-syntax)))
(when (identifier? stx)
(debug "Current phase ~a stx at ~a honu-scheme ~a same? ~a\n" (syntax-local-phase-level) (identifier-binding stx)
(identifier-transformer-binding #'honu-scheme)
(free-identifier=? stx #'honu-scheme)
))
|#
#;
(syntax-parse stx #:literals (honu-syntax #%parens syntax)
#;
[((honu-syntax (#%parens x ...) y ...) rest ...)
#;
(debug "a1\n")
(with-syntax ([(y* ...) (fix-output #'(y ... rest ...))])
(syntax/loc stx
((honu-syntax x ...) y* ...)))]
#;
[(start ... (honu-scheme code ...) rest ...)
(with-syntax ([(rest* ...) (fix-output #'(rest ...))])
(syntax/loc stx
(start ... honu-scheme (code ...) rest* ...)))]
#;
[(honu-syntax (#%parens x ...) y ...)
#;
(debug "a2\n")
(with-syntax ([(y* ...) (fix-output #'(y ...))])
(syntax/loc stx
(x ... y* ...)))]
;; dont touch real syntax
[(syntax stuff ...)
#;
(debug " aa\n")
stx]
#;
[honu-scheme (raise-syntax-error 'asdfioj "got honu-scheme")]
[(z x ...)
#;
(debug "a3\n")
(datum->syntax stx (cons (fix-output #'z)
(fix-output #'(x ...)))
stx)
#;
(with-syntax ([z* (fix-output #'z)]
[(x* ...) (fix-output #'(x ...))])
(syntax/loc stx
(z* x* ...)))]
#;
[(honu-syntax . rest)
(raise-syntax-error 'fix-output "invalid use of honu-syntax")]
[else
#;
(debug " no change\n")
stx]))
(define-splicing-syntax-class expression (define-splicing-syntax-class expression
[pattern (~seq (~var x (expression-1 the-expression-context))) [pattern (~seq (~var x (expression-1 the-expression-context)))
#:with result (apply-scheme-syntax #'x.result)]) #:with result (apply-scheme-syntax #'x.result)])
(define-splicing-syntax-class (whats-here? hm)
[pattern (~seq x ...)
#:when (begin (debug "Whats at `~a': `~a'\n" hm (syntax->datum #'(x ...)))
#f)])
#;
(define-syntax-class statement
[pattern ((~var f (whats-here? "statement1"))
(~var x (expression-top the-top-block-context)))
#:with result (apply-scheme-syntax (attribute x.result))
#:with rest #'x.rest])
(define-splicing-syntax-class statement (define-splicing-syntax-class statement
#:literals (semicolon) #:literals (semicolon)
[pattern (~seq (~var x (ternary the-top-block-context)) [pattern (~seq (~var x (ternary the-top-block-context)))
(~var q (debug-here "statement 2"))
#;
(~var qq (whats-here? "statement 2.1"))
(~var z (debug-here "statement 3"))
)
#:with result (apply-scheme-syntax (attribute x.result)) #:with result (apply-scheme-syntax (attribute x.result))
#:with rest #'x.rest]
#;
[pattern ((~var f (debug-here "statement1"))
(~var x (expression-top the-top-block-context)))
#:with result (apply-scheme-syntax (attribute x.result))
#:with rest #'x.rest]
#;
[pattern (~seq (~var f (whats-here? "statement1"))
(~var f1 (whats-here? "statement2"))
(~seq
(~var x (expression-top the-top-block-context))))
#:with result (apply-scheme-syntax (attribute x.result))
#:with rest #'x.rest])
#;
(define-splicing-syntax-class statement
[pattern (~seq
(~optional (~var zz (whats-here? "statement")))
(~var d1 (debug-here (format "statement 1\n")))
(~var x (expression-top the-top-block-context))
(~var d2 (debug-here (format "statement 2\n")))
)
#:with result (apply-scheme-syntax #'x.result)
#:with rest #'x.rest]) #:with rest #'x.rest])
(define-splicing-syntax-class expression-comma (define-splicing-syntax-class expression-comma
#:literals (honu-comma) #:literals (honu-comma)
#;
[pattern ;; ((~seq x) ...)
(x ...)
#:with (expr ...) (filter (lambda (n)
(not (free-identifier=? #'honu-comma n)))
(syntax->list #'(x ...)))]
#;
[pattern ((~seq (~var expr honu-identifier) (~optional honu-comma)) ...)]
#;
[pattern (~seq (~var expr honu-identifier) (~optional honu-comma))]
[pattern (~seq (~var expr (expression-1 the-expression-context)) [pattern (~seq (~var expr (expression-1 the-expression-context))
(~optional honu-comma)) (~optional honu-comma))
#:with result (apply-scheme-syntax #'expr.result)] #:with result (apply-scheme-syntax #'expr.result)])
#;
[pattern ((~seq (~var expr (expression-1 the-expression-context)) (~optional honu-comma)) ...)])
(define (parse-an-expr stx) (define (parse-an-expr stx)
(debug "Parse an expr ~a\n" (syntax->datum stx)) (debug "Parse an expr ~a\n" (syntax->datum stx))
(syntax-parse (with-syntax ([(s ...) stx]) (syntax-parse (with-syntax ([(s ...) stx])
#'(s ...)) #'(s ...))
#;
[(raw:raw-scheme-syntax . rest) #'raw]
[((~var expr (expression-1 the-expression-context)) . rest) #'expr.result] [((~var expr (expression-1 the-expression-context)) . rest) #'expr.result]
[else (raise-syntax-error 'parse-an-expr "cant parse" stx)] [else (raise-syntax-error 'parse-an-expr "can't parse" stx)]))
))
(define-splicing-syntax-class honu-body:class (define-splicing-syntax-class honu-body:class
#:literals (#%braces) #:literals (#%braces)
@ -629,93 +376,12 @@
(define (parse-block-one/2 stx context) (define (parse-block-one/2 stx context)
(define (parse-one stx context) (define (parse-one stx context)
#;
(let-values ([(a b) (debug-parse #'(SQL_create_insert) ((~seq x:expression)))])
(debug "debug parse for ~a is ~a and ~a\n" 'SQL_create_insert a b))
#;
(let-values ([(a b) (debug-parse stx ((~seq (~var x (expression-top context)))))])
(debug "debug parse for ~a is ~a and ~a\n" (syntax->datum stx) a b))
;; (debug "~a\n" (syntax-class-parse function stx))
(syntax-parse stx (syntax-parse stx
#; [(~var expr (expression-top context)) (values #'expr.result #'expr.rest)]))
[(raw:raw-scheme-syntax . rest) (values #'raw #'rest)]
#;
[function:function (values #'function.result #'function.rest)]
[(~var expr (expression-top context)) (values #'expr.result #'expr.rest)]
#;
[(x:number . rest) (values #'x #'rest)]
))
(debug "Parsing ~a\n" (syntax->datum stx)) (debug "Parsing ~a\n" (syntax->datum stx))
(cond (cond
[(stx-null? stx) (values stx '())] [(stx-null? stx) (values stx '())]
#; [else (parse-one stx context)]))
[(syntax-parse stx #:literals (honu-syntax #%parens semicolon)
[(honu-syntax (#%parens expr ...) semicolon . rest)
(list #'(expr ...)
#'rest)
#;
(debug "Parsed honu-syntax rest ~a position ~a out ~a\n"
#'rest (syntax-object-position stx #'rest)
#'(honu-unparsed-begin expr ...))
#;
(list #'rest (syntax-object-position stx #'rest)
#'(honu-unparsed-begin expr ...))]
[else #f]
#;
[else #f => (lambda (exprs)
(debug "Ignoring honu-syntax 1!\n")
(list 0 #''()))]
) => (lambda (all)
(let ([to-parse (car all)]
[rest (cadr all)])
(let-values ([(out rest2)
(with-syntax ([(more ...) rest]
[(stuff ...) to-parse])
(parse-block-one/2 #'(stuff ... more ...) context))])
(values out rest2))))
]
#;
[(get-transformer stx) => (lambda (transformer)
(define introducer (make-syntax-introducer))
(define introduce introducer)
(define unintroduce introducer)
#;
(define introduce (compose introducer syntax-local-introduce))
#;
(define unintroduce (compose syntax-local-introduce introducer))
(debug "Parse one: execute transformer ~a ~a\n" (stx-car stx) transformer)
#;
(debug "output of transformer is ~a\n" (let-values ([(a b) (transformer stx context)]) (list a b)))
(let-values ([(output rest)
(transformer (introduce stx) context)])
(values (unintroduce (output)) (unintroduce rest)))
#;
(call-values (transformer stx context)
(lambda (reparse rest)
;; (define fixed (fix-output reparse))
(define fixed reparse)
(debug "Transformer gave us ~a\n" (syntax->datum reparse))
#;
(values reparse rest)
#;
(values (fix-output reparse) rest)
#;
(debug "Macroized ~a and ~a\n" reparse rest)
(debug "Fixed syntax ~a\n" (syntax->datum fixed))
(syntax-parse fixed #:literals (honu-unparsed-expr)
[(honu-unparsed-expr stuff ...)
(let-values ([(out rest2)
(with-syntax ([(more ...) rest])
(parse-block-one/2 #'(stuff ... more ...) context))])
(values out rest2))]
[else (values fixed rest)]))
))]
[else (parse-one stx context)]
#;
[else (let-values ([(a b) (parse-one stx context)])
(values (apply-scheme-syntax a) b))]
))
(define operator? (define operator?
(let ([sym-chars (string->list "+-_=?:<>.!%^&*/~|")]) (let ([sym-chars (string->list "+-_=?:<>.!%^&*/~|")])
@ -767,29 +433,7 @@
(let ([v (syntax-local-value (stx-car first) (lambda () #f))]) (let ([v (syntax-local-value (stx-car first) (lambda () #f))])
(and (honu-transformer? v) v))] (and (honu-transformer? v) v))]
[else #f])))) [else #f]))))
#; (bound-transformer stx))
(debug "~a bound transformer? ~a at phase level ~a identifiers: ~a\n" stx (bound-transformer stx) (syntax-local-phase-level)
(if (and (stx-pair? stx)
(identifier? (stx-car stx)))
(let ([id (stx-car stx)])
(for/list ([phase (in-range -2 2)])
(format "~a : ~a." phase (identifier-binding id phase))))
'not-an-id))
(bound-transformer stx)
#;
(or (bound-transformer stx)
(special-transformer stx)))
#;
(define-honu-syntax honu-syntax
(lambda (stx ctx)
(syntax-case stx ()
[(_ expr ...)
(begin
(debug "Honu syntax on ~a\n" #'(expr ...))
(raise-syntax-error 'honu-syntax "should have been handled already")
#;
(parse-block-one/2 #'(expr ...) the-expression-context))])))
(define (do-parse-block block) (define (do-parse-block block)
(define parsed (define parsed
@ -802,6 +446,3 @@
rest*))))) rest*)))))
(with-syntax ([(out ...) (reverse parsed)]) (with-syntax ([(out ...) (reverse parsed)])
#'(begin out ...))) #'(begin out ...)))
(define (cheetos) 1)
; (define cheetos "foo")

30
collects/honu/core/private/syntax.rkt
View File

@ -2,40 +2,10 @@
(provide (all-defined-out)) (provide (all-defined-out))
#;
(define-syntax (honu-syntax stx)
(syntax-case stx ()
[(_ expr)
#'(honu-unparsed-expr expr)
#;
(begin
(debug "honu syntax ~a\n" stx)
(raise-syntax-error 'honu-syntax "dont call this")
#'(make-honu-transformer (lambda (stx ctx)
(debug "honu syntax ~a\n" stx)
#'(expr ...))))]))
#;
(define-syntax honu-unparsed-expr
(lambda (stx) (raise-syntax-error 'honu-unparsed-expr "dont use this")))
(define honu-scheme-syntax 'honu-scheme-syntax) (define honu-scheme-syntax 'honu-scheme-syntax)
#;
(define honu-scheme-syntax (gensym))
#;
(define-syntax-rule (scheme-syntax stx)
(syntax-property (syntax stx) honu-scheme-syntax #t))
(define (raw-scheme? stx) (define (raw-scheme? stx)
(syntax-property stx honu-scheme-syntax)) (syntax-property stx honu-scheme-syntax))
(define (apply-scheme-syntax stx) (define (apply-scheme-syntax stx)
(syntax-property stx honu-scheme-syntax #t)) (syntax-property stx honu-scheme-syntax #t))
#;
(define-syntax (scheme-syntax stx)
(syntax-case stx ()
[(_ x ...)
(lambda () '(syntax-property #'(x ...) honu-scheme-syntax #t))]))

17
collects/honu/core/private/util.rkt
View File

@ -8,11 +8,6 @@
syntax/stx syntax/stx
racket/list) racket/list)
#;
(provide delim-identifier=?
extract-until
call-values)
(define (delim-identifier=? a b) (define (delim-identifier=? a b)
(eq? (syntax-e a) (syntax-e b))) (eq? (syntax-e a) (syntax-e b)))
@ -74,9 +69,6 @@
(debug " delimiter expected ~a actual ~a\n" (syntax->datum expected-delimiter) (syntax->datum hit)) (debug " delimiter expected ~a actual ~a\n" (syntax->datum expected-delimiter) (syntax->datum hit))
)))) ))))
#;
(test)
;; better version of caddadadr-type functions ;; better version of caddadadr-type functions
(define-syntax (list-match stx) (define-syntax (list-match stx)
(define (convert-pattern pattern) (define (convert-pattern pattern)
@ -103,12 +95,3 @@
[match-variable (extract-variable #'pattern)]) [match-variable (extract-variable #'pattern)])
#'(match expression #'(match expression
[match-pattern match-variable]))])) [match-pattern match-variable]))]))
#;
(test
(list-match a '(1 2 3)) => '(1 2 3)
(list-match (a _ ...) '(1 2 3)) => 1
(list-match (_ _ a ...) '(1 2 3 4)) => '(3 4)
(list-match ((_ a _ ...) _ ...) '((1 2 3 4) 5 6)) => 2
(list-match ((_ _ a _ ...) _ ...) '((7 6 5 4 3 2 1) 8 9)) => 5
)