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

[honu] wrap expressions with a semicolon at the end of them in (%semicolon ...)

Browse Source
This commit is contained in:
Jon Rafkind 2011-10-23 13:25:43 -06:00
parent b055ce9fe0
commit dccdcb0550
6 changed files with 105 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -36,7 +36,7 @@
[literal:honu-<- <-]
[honu-map map]
[honu-flow \|]
[honu-dot |.|]
[honu-dot %dot]
[honu-string=? string_equal]
[honu-cons ::]
[honu-and and] [honu-and &&]
@ -46,10 +46,10 @@
[honu-structure struct]
[literal:honu-prefix prefix]
[literal:honu-then then]
[literal:colon :]
[literal:colon %colon]
[literal:honu-in in]
[literal:semicolon |;|]
[literal:honu-comma |,|]
[literal:semicolon %semicolon]
[literal:honu-comma %comma]
[literal:#%brackets #%brackets]
[literal:#%braces #%braces]
[literal:#%parens #%parens])

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

@ -9,6 +9,7 @@
syntax/parse/experimental/splicing
scheme/splicing
macro-debugger/emit
racket/pretty
"debug.rkt"
"contexts.rkt"
"util.rkt"
@ -474,5 +475,5 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
(syntax-case stx ()
[(_ forms ...)
(begin
(debug "Module begin ~a\n" (syntax->datum #'(forms ...)))
(debug "Module begin ~a\n" (pretty-format (syntax->datum #'(forms ...))))
#'(#%module-begin (honu-unparsed-begin forms ...)))]))

7
collects/honu/core/private/honu2.rkt
View File

@ -38,10 +38,15 @@
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
#:literals (honu-=)
[(_ name:id honu-= . rest)
[(_ name:id honu-= one:honu-expression . rest)
(values #'(define name one.result)
#'rest
#t)
;; parse one expression
#;
(define-values (parsed unparsed)
(parse #'rest))
#;
(values
(with-syntax ([parsed parsed])
#'(define name parsed))

13
collects/honu/core/private/parse2.rkt
View File

@ -100,6 +100,7 @@
;; removes syntax that causes expression parsing to stop
(define (strip-stops code)
(define-syntax-class stopper #:literal-sets (cruft)
#;
[pattern semicolon]
[pattern honu-comma]
[pattern colon])
@ -227,11 +228,23 @@
0
(lambda (x) x)
(left final)))]
[(stopper? #'head)
(values (left final)
stream)]
[else
(syntax-parse #'(head rest ...) #:literal-sets (cruft)
[((semicolon more ...) . rest)
#;
(define-values (parsed unparsed)
(do-parse #'(more ...)
0
(lambda (x) x)
#f))
#;
(when (not (stx-null? unparsed))
(raise-syntax-error 'parse "found unparsed input" unparsed))
(values (parse-all #'(more ...)) #'rest)]
[(function:honu-function . rest)
(values #'function.result #'rest)]
#;

72
collects/honu/core/read.rkt
View File

@ -20,6 +20,7 @@
parse-error
left-bracket right-bracket
left-brace right-brace
semicolon
block-comment
end-of-line-comment])
@ -67,13 +68,13 @@
#;
[block-comment (token-whitespace)]
["/*" (token-block-comment)]
["." (token-identifier '|.|)]
["," (token-identifier '|,|)]
[":" (token-identifier ':)]
["." (token-identifier '%dot)]
["," (token-identifier '%comma)]
[":" (token-identifier '%colon)]
["'" (token-identifier 'quote)]
["`" (token-identifier 'quasiquote)]
[operator (token-identifier (string->symbol lexeme))]
[";" (token-identifier '|;|)]
[";" (token-semicolon)]
;; strip the quotes from the resulting string
;; TODO: find a more optimal way
[string (let ()
@ -109,7 +110,8 @@
block-comment parse-error
identifier left-parens right-parens
left-bracket right-bracket
left-brace right-brace)
left-brace right-brace
semicolon)
;; returns #t if an entire comment was read (with an ending newline)
(define (read-until-end-of-line input)
@ -294,6 +296,63 @@
(define (do-empty current tokens table)
(reverse current))
(define (contains-semicolon? syntax)
(syntax-case syntax (%semicolon #%braces #%parens)
[(%semicolon x ...) #t]
[#%braces #t]
[(#%braces x ...) #t]
#;
[(#%parens x ...) #t]
[else #f]))
;; wraps syntax objects with (%semicolon ...)
;; it will search backwards through the list of already created syntax objects
;; until it either runs out of syntax objects or finds one already wrapped with
;; (%semicolon ...)
;;
;; if the original input is '1 + 2; 3 + 4;' this will get read as
;; (1 + 2 %semicolon 3 + 4 %semicolon)
;; then parsing will start from the front. when %semicolon is reached we will have
;; the following (current is always backwards).
;; current: (2 + 1)
;; do-semicolon will search this for a syntax object containing (%semicolon ...) but
;; since one doesn't appear the entire expression will be reversed and wrapped thus
;; resulting in
;; (%semicolon 1 + 2)
;;
;; Now parsing continues with (3 + 4 %semicolon). When the next %semicolon is hit we
;; will have
;; current: (4 + 3 (%semicolon 1 + 2))
;;
;; So do-semicolon will find (%semicolon 1 + 2) and leave stop processing there,
;; resulting in
;; ((%semicolon 3 + 4) (%semicolon 1 + 2))
;;
;; The entire list will be reversed at the end of parsing.
(define (do-semicolon current tokens table)
;; (debug "Do semicolon on ~a\n" current)
(define-values (wrap ok)
(let loop ([found '()]
[rest current])
(match rest
[(list) (values found rest)]
[(list (and (? contains-semicolon?) head) rest* ...)
(values found rest)]
[(list head rest ...)
(loop (cons head found) rest)])))
(define semicolon (make-syntax `(%semicolon ,@wrap)
;; FIXME: this is probably the wrong token
;; to get source location from
(car tokens)
source))
(do-parse (cons semicolon ok)
(cdr tokens)
table))
(define (semicolon? tokens)
(is-first-token token-semicolon? tokens))
(define (left-parens? tokens)
(is-first-token token-left-parens? tokens))
@ -334,7 +393,8 @@
(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]
(define dispatch-table (list [list semicolon? do-semicolon]
[list atom? do-atom]
[list left-parens? do-left-parens]
[list left-bracket? do-left-bracket]
[list left-brace? do-left-brace]

28
collects/tests/honu/linq.honu
View File

@ -9,24 +9,24 @@ class Xml(data){
}
Element(name){
new Xml(get_element(data, name));
new Xml(get_element(data, name))
}
Value(){
get_text(data);
get_text(data)
}
getData(){ data }
};
}
read_xml(){
xml_permissive_xexprs(true);
xml_xml_to_xexpr(xml_document_element(xml_read_xml()));
xml_permissive_xexprs(true)
xml_xml_to_xexpr(xml_document_element(xml_read_xml()))
}
loadXml(file){
with_input_from_file(file){
new Xml(read_xml());
new Xml(read_xml())
}
}
@ -34,23 +34,23 @@ starts_with(start, what){
substring(what, 0, string_length(start)) string_equal start
}
var xml = loadXml("test.xml");
printf("xml ~a\n", xml);
printf("data: ~a\n", xml.getData());
printf("table1: ~a\n", xml.Descendants("Table1"));
var xml = loadXml("test.xml")
printf("xml ~a\n", xml)
printf("data: ~a\n", xml.getData())
printf("table1: ~a\n", xml.Descendants("Table1"))
struct test{name, address};
struct test{name, address}
var addresses = linq from add in xml.Descendants("Table1")
where true
orderby add.Element("familyName").Value()
select test(add.Element("familyName").Value(),
add.Element("address").Value());
add.Element("address").Value())
printf("addresses ~a\n", addresses);
printf("addresses ~a\n", addresses)
for add in addresses do {
printf("name ~a address ~a\n", add.name, add.address);
printf("name ~a address ~a\n", add.name, add.address)
}
for xs in linq from foo in xml.Descendants("Table1")