From 08711175388208e07998e0360a8b24e29bccf955 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 9 Aug 2011 16:04:39 -0600 Subject: [PATCH] [honu] add [] as a list form --- collects/honu/core/main.rkt | 1 + collects/honu/core/private/debug.rkt | 7 +- collects/honu/core/private/parse2.rkt | 121 ++++++++++++++------------ collects/honu/core/read.rkt | 2 +- 4 files changed, 72 insertions(+), 59 deletions(-) diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index cba733b1dc..00336ca1ac 100644 --- a/collects/honu/core/main.rkt +++ b/collects/honu/core/main.rkt @@ -22,6 +22,7 @@ [literal:honu-= =] [literal:semicolon |;|] [literal:honu-comma |,|] + [literal:#%brackets #%brackets] [literal:#%braces #%braces] [literal:#%parens #%parens]) ) diff --git a/collects/honu/core/private/debug.rkt b/collects/honu/core/private/debug.rkt index ccd1cf6655..5eb9ad0c72 100644 --- a/collects/honu/core/private/debug.rkt +++ b/collects/honu/core/private/debug.rkt @@ -4,12 +4,17 @@ (provide debug) +(define-for-syntax (filename path) + (define-values (base name dir?) + (split-path (build-path path))) + name) + (define-for-syntax verbose? (getenv "HONU_DEBUG")) (define-syntax (debug stx) (if verbose? (syntax-case stx () [(_ str x ...) - (with-syntax ([file (syntax-source #'str)] + (with-syntax ([file (filename (syntax-source #'str))] [line (syntax-line #'str)] [column (syntax-column #'str)]) #'(printf (string-append "~a at ~a:~a " str) file line column x ...))]) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index 14951b8b10..08dc56b1a3 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -96,17 +96,17 @@ (loop (cons #'name out) #'())] [() (reverse out)]))) -(define (parse-call-arguments arguments) +(define (parse-comma-expression arguments) (if (null? (syntax->list arguments)) '() (let loop ([used '()] - [rest arguments]) + [rest arguments]) (if (empty-syntax? rest) - (reverse used) - (let-values ([(parsed unparsed) - (parse rest)]) + (reverse used) + (let-values ([(parsed unparsed) + (parse rest)]) (loop (cons parsed used) - unparsed)))))) + unparsed)))))) ;; 1 + 1 ;; ^ @@ -189,12 +189,12 @@ 0 (lambda (x) x) (left final)))] - [(comma? #'head) - (values (left final) - #'(rest ...))] - [(semicolon? #'head) - (values (left final) - #'(rest ...)) + [(comma? #'head) + (values (left final) + #'(rest ...))] + [(semicolon? #'head) + (values (left final) + #'(rest ...)) #; (do-parse #'(rest ...) 0 (lambda (stuff) @@ -202,54 +202,61 @@ [current (left current)]) #'(begin current stuff))) #'(void)) - #; + #; (with-syntax ([so-far (left current)]) #'(splicing-let-syntax ([more (lambda (stx) (parse #'(rest ...)))]) - so-far (more)))] - [else - (syntax-parse #'(head rest ...) #:literal-sets (cruft) - [(function:identifier (#%parens args ...) (#%braces code ...) . rest) - (values (with-syntax ([(parsed-arguments ...) - (parse-arguments #'(args ...))]) - #'(define (function parsed-arguments ...) - (let-syntax ([parse-more (lambda (stx) - (parse-all #'(code ...)))]) - (parse-more)))) - #'rest)] - [else (syntax-parse #'head - #:literal-sets (cruft) - [x:atom - (debug "atom ~a current ~a\n" #'x current) - (if current - (values (left current) stream) - (do-parse #'(rest ...) precedence left #'x))] - [(#%braces stuff ...) - (if current - (values (left current) stream) - (let () - (define body (parse-all #'(stuff ...))) - (do-parse #'(rest ...) precedence left body)))] - [(#%parens args ...) - (debug "function call ~a\n" left) - (values (left (with-syntax ([current current] - [(parsed-args ...) - (parse-call-arguments #'(args ...)) ]) - #'(current parsed-args ...))) - #'(rest ...)) - #; - (do-parse #'(rest ...) - 0 - (lambda (x) x) - (left (with-syntax ([current current] - [(parsed-args ...) - (if (null? (syntax->list #'(args ...))) - '() - (list (parse #'(args ...))))]) - #'(current parsed-args ...)))) - #; - (error 'parse "function call")] - [else (error 'what "dont know how to parse ~a" #'head)])])])])) + so-far (more)))] + [else + (syntax-parse #'(head rest ...) #:literal-sets (cruft) + [(function:identifier (#%parens args ...) (#%braces code ...) . rest) + (values (with-syntax ([(parsed-arguments ...) + (parse-arguments #'(args ...))]) + #'(define (function parsed-arguments ...) + (let-syntax ([parse-more (lambda (stx) + (parse-all #'(code ...)))]) + (parse-more)))) + #'rest)] + [else (syntax-parse #'head + #:literal-sets (cruft) + [x:atom + (debug "atom ~a current ~a\n" #'x current) + (if current + (values (left current) stream) + (do-parse #'(rest ...) precedence left #'x))] + [(#%brackets stuff ...) + (define value (with-syntax ([(data ...) + (parse-comma-expression #'(stuff ...))]) + #'(list data ...))) + (if current + (values (left current) stream) + (do-parse #'(rest ...) precedence left value))] + [(#%braces stuff ...) + (if current + (values (left current) stream) + (let () + (define body (parse-all #'(stuff ...))) + (do-parse #'(rest ...) precedence left body)))] + [(#%parens args ...) + (debug "function call ~a\n" left) + (values (left (with-syntax ([current current] + [(parsed-args ...) + (parse-comma-expression #'(args ...)) ]) + #'(current parsed-args ...))) + #'(rest ...)) + #; + (do-parse #'(rest ...) + 0 + (lambda (x) x) + (left (with-syntax ([current current] + [(parsed-args ...) + (if (null? (syntax->list #'(args ...))) + '() + (list (parse #'(args ...))))]) + #'(current parsed-args ...)))) + #; + (error 'parse "function call")] + [else (error 'what "dont know how to parse ~a" #'head)])])])])) (do-parse input 0 (lambda (x) x) #f)) diff --git a/collects/honu/core/read.rkt b/collects/honu/core/read.rkt index c2131c06aa..298e558fc1 100644 --- a/collects/honu/core/read.rkt +++ b/collects/honu/core/read.rkt @@ -329,7 +329,7 @@ (do-parse (cons sub-tree current) unparsed table))) (define do-left-parens (make-encloser '#%parens ")" right-parens?)) - (define do-left-bracket (make-encloser '#%bracket "}" right-bracket?)) + (define do-left-bracket (make-encloser '#%brackets "}" right-bracket?)) (define do-left-brace (make-encloser '#%braces "]" right-brace?)) (define dispatch-table (list [list atom? do-atom]