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

reorganize honu. provide ellipses properly

Browse Source 
svn: r16530
This commit is contained in:
Jon Rafkind 2009-11-03 21:07:29 +00:00
parent 8886736b76
commit 388a2c99d4
4 changed files with 2301 additions and 2177 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2225
collects/honu/main.ss
View File

File diff suppressed because it is too large Load Diff

14
collects/honu/private/debug.ss Normal file
View File

@ -0,0 +1,14 @@
#lang scheme/base
(require (for-syntax scheme/base))
(provide debug)
(define-for-syntax verbose? #f)
(define-syntax (debug stx)
(if verbose?
(syntax-case stx ()
[(_ str x ...)
#'(printf str x ...)])
#'(void)))

2118
collects/honu/private/honu.ss Normal file
View File

File diff suppressed because it is too large Load Diff

121
collects/honu/private/macro.ss Normal file
View File

@ -0,0 +1,121 @@
#lang scheme/base
(require "honu.ss"
(for-syntax "debug.ss")
(for-syntax scheme/base))
(provide (all-defined-out))
(define-for-syntax (extract-conventions pattern)
(let loop ([out '()]
[in pattern])
(syntax-case in (:)
[(any : attribute rest ...)
;; todo: export honu attributes for syntax/parse
(loop (cons #'(any expr) out)
#'(rest ...))
#;
(loop (cons #'(any attribute) out)
#'(rest ...))]
[(foo rest1 rest ...)
(loop out #'(rest1 rest ...))]
[(foo) out])))
(define-for-syntax (extract-patterns pattern)
(let loop ([out '()]
[in pattern])
(syntax-case in (:)
[(any : attribute rest ...)
(loop (cons #'any out)
#'(rest ...))]
[(foo rest1 rest ...)
(let ([f (if (eq? (syntax->datum #'foo) 'crackers)
#'(... ...)
#'foo)])
(loop (cons f out)
#'(rest1 rest ...)))]
[(foo) (reverse (cons #'foo out))])))
(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 ...))])
(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))
;; (printf "head is ~a\n" (stx-car stx))
;; (printf "= 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
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
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
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
template ...)
#'rrest)])))))
#'rest))])
))