706 lines
29 KiB
Racket
706 lines
29 KiB
Racket
#lang racket/base
|
|
|
|
(define-syntax-rule (require-syntax stuff ...)
|
|
(require (for-syntax stuff ...)))
|
|
|
|
;; phase 0
|
|
(require ;; "macro2.rkt"
|
|
"literals.rkt"
|
|
"debug.rkt"
|
|
"compile.rkt"
|
|
racket/list
|
|
(prefix-in transformer: "transformer.rkt")
|
|
(prefix-in fixture: "fixture.rkt")
|
|
"operator.rkt"
|
|
macro-debugger/emit
|
|
racket/pretty
|
|
syntax/stx
|
|
syntax/parse/experimental/splicing
|
|
syntax/parse)
|
|
;; phase 1
|
|
(require-syntax racket/base
|
|
"debug.rkt")
|
|
|
|
;; phase -1
|
|
(require (for-template racket/base
|
|
racket/splicing
|
|
(only-in "literals.rkt" %racket)
|
|
"compile.rkt"
|
|
"syntax.rkt"
|
|
"extra.rkt"))
|
|
|
|
(provide parse parse-all)
|
|
|
|
#;
|
|
(define-literal-set literals
|
|
[honu-macro])
|
|
|
|
(define (get-value what)
|
|
(syntax-local-value what (lambda () #f)))
|
|
|
|
#;
|
|
(define (get-value what)
|
|
(debug "what is ~a\n" what)
|
|
(with-syntax ([what what])
|
|
(let-syntax ([v (lambda (stx)
|
|
(debug "get ~a\n" #'what)
|
|
(with-syntax ([x (syntax-local-value #'what (lambda () #f))])
|
|
#'x))])
|
|
(v))))
|
|
|
|
#;
|
|
(define (get-value check)
|
|
(eval-syntax
|
|
(with-syntax ([check check])
|
|
#'(syntax-local-value check #'check (lambda () #f)))))
|
|
|
|
(define (bound-to-operator? check)
|
|
(let ([value (get-value check)])
|
|
(debug 2 "operator? ~a ~a\n" check value)
|
|
(transformer:honu-operator? value)))
|
|
|
|
(define (bound-to-fixture? check)
|
|
(let ([value (get-value check)])
|
|
(debug 2 "fixture? ~a ~a\n" check value)
|
|
(fixture:fixture? value)))
|
|
|
|
(define (bound-to-macro? check)
|
|
(let ([value (get-value check)])
|
|
(debug 2 "macro? ~a ~a\n" check value)
|
|
(transformer:honu-transformer? value))
|
|
#;
|
|
(let ([value (syntax-local-value check (lambda () #f))])
|
|
(transformer:honu-transformer? value)))
|
|
|
|
(define (honu-macro? something)
|
|
(and (identifier? something)
|
|
(bound-to-macro? something)))
|
|
|
|
(define (honu-operator? something)
|
|
(and (identifier? something)
|
|
(bound-to-operator? something)))
|
|
|
|
(define (honu-fixture? something)
|
|
(and (identifier? something)
|
|
(bound-to-fixture? something)))
|
|
|
|
(define (semicolon? what)
|
|
(define-literal-set check (semicolon))
|
|
(define is (and (identifier? what)
|
|
((literal-set->predicate check) what)))
|
|
(debug "Semicolon? ~a ~a\n" what is)
|
|
is)
|
|
|
|
(define (comma? what)
|
|
(define-literal-set check (honu-comma))
|
|
(define is (and (identifier? what)
|
|
((literal-set->predicate check) what)))
|
|
(debug 2 "Comma? ~a ~a\n" what is)
|
|
is)
|
|
|
|
(define-literal-set argument-stuff [honu-comma])
|
|
|
|
(define (parse-arguments arguments)
|
|
(define-syntax-class val
|
|
[pattern x:identifier #:when (equal? 'val (syntax-e #'x))])
|
|
(let loop ([out '()]
|
|
[arguments arguments])
|
|
(syntax-parse arguments #:literal-sets (argument-stuff)
|
|
[(x:val name:identifier honu-comma more ...)
|
|
(loop (cons #'name out) #'(more ...))]
|
|
[(name:identifier honu-comma more ...)
|
|
(loop (cons #'name out) #'(more ...))]
|
|
[(x:val name:identifier)
|
|
(loop (cons #'name out) #'())]
|
|
[(name:identifier)
|
|
(loop (cons #'name out) #'())]
|
|
[() (reverse out)])))
|
|
|
|
(define (parse-comma-expression arguments)
|
|
(if (null? (syntax->list arguments))
|
|
'()
|
|
(let loop ([used '()]
|
|
[rest arguments])
|
|
(if (empty-syntax? rest)
|
|
(reverse used)
|
|
(syntax-parse rest #:literal-sets (cruft)
|
|
[(honu-comma more ...)
|
|
(loop used #'(more ...))]
|
|
[else
|
|
(let-values ([(parsed unparsed)
|
|
;; FIXME: don't strip all stops, just comma
|
|
(parse (strip-stops rest))])
|
|
(loop (if parsed
|
|
(cons parsed used)
|
|
used)
|
|
unparsed))])))))
|
|
|
|
(define (stopper? what)
|
|
(define-literal-set check (honu-comma semicolon colon))
|
|
(define is (and (identifier? what)
|
|
((literal-set->predicate check) what)))
|
|
(debug 2 "Comma? ~a ~a\n" what is)
|
|
is)
|
|
|
|
(provide do-parse-rest)
|
|
(define (do-parse-rest stx parse-more)
|
|
(syntax-parse stx #:literal-sets (cruft)
|
|
[(semicolon semicolon ... rest ...)
|
|
(do-parse-rest #'(rest ...) parse-more)]
|
|
[(stuff ...)
|
|
(debug "Parse rest ~a\n" (syntax->datum #'(stuff ...)))
|
|
(define-values (parsed unparsed)
|
|
(parse (strip-stops #'(stuff ...))))
|
|
(debug "Parse more: ~a unparsed ~a\n" parsed unparsed)
|
|
(define output (if parsed
|
|
parsed
|
|
#;
|
|
(honu->racket parsed)
|
|
#'(void)))
|
|
(debug "Output ~a unparsed ~a\n"
|
|
(syntax->datum output)
|
|
(syntax->datum unparsed))
|
|
(with-syntax ([output output]
|
|
[(unparsed-out ...) unparsed]
|
|
[parse-more parse-more])
|
|
(if (null? (syntax->datum #'(unparsed-out ...)))
|
|
(if (parsed-syntax? #'output)
|
|
#'output
|
|
#;
|
|
#'(parse-more output)
|
|
(with-syntax ([(out ...) #'output])
|
|
#'(parse-more out ...)))
|
|
#;
|
|
#'(begin (parse-more output unparsed-out ...))
|
|
(if (parsed-syntax? #'output)
|
|
#'(begin output (parse-more unparsed-out ...))
|
|
#;
|
|
#'(parse-more output unparsed-out ...)
|
|
(with-syntax ([(out ...) #'output])
|
|
#'(begin (parse-more out ...) (parse-more unparsed-out ...))))))]
|
|
[() #'(begin)]))
|
|
|
|
(define (do-parse-rest/local stx)
|
|
(define name (gensym 'local-parser))
|
|
(define local-parser (with-syntax ([name name])
|
|
#'(define-syntax (name stx)
|
|
(syntax-case stx ()
|
|
[(_ stuff (... ...))
|
|
(debug "Properties on first element ~a\n" (syntax-property-symbol-keys (stx-car #'(stuff (... ...)))))
|
|
(do-parse-rest #'(stuff (... ...)) #'name)]))))
|
|
(with-syntax ([local local-parser]
|
|
#;
|
|
[parsed (do-parse-rest stx name)])
|
|
(with-syntax ([stx stx]
|
|
[name name])
|
|
(debug "Create local parser for ~a properties ~a\n" (syntax->datum #'stx) (syntax-property-symbol-keys #'stx))
|
|
;; sort of a hack, if the input is already parsed then don't deconstruct it
|
|
;; otherwise the input is a honu expression so we need to splice it in
|
|
(define with-local
|
|
(if (parsed-syntax? #'stx)
|
|
#'(begin local (unexpand-honu-syntax (name stx)))
|
|
(with-syntax ([(inside ...) #'stx])
|
|
#'(begin local (unexpand-honu-syntax (name inside ...))))))
|
|
(emit-local-step #'stx with-local #:id #'do-parse-rest/local)
|
|
(parsed-syntax with-local))))
|
|
|
|
#|
|
|
(provide do-parse-rest-macro)
|
|
(define-syntax (do-parse-rest-macro stx)
|
|
(syntax-case stx ()
|
|
[(_ stuff ...)
|
|
(do-parse-rest #'(stuff ...) #'do-parse-rest-macro)]))
|
|
|#
|
|
|
|
(provide honu-body)
|
|
(define-syntax-class honu-body
|
|
#:literal-sets (cruft)
|
|
[pattern (#%braces code ...)
|
|
#:with result
|
|
(racket-syntax (let ()
|
|
(define-syntax (parse-more stx)
|
|
(syntax-case stx ()
|
|
[(_ stuff (... ...))
|
|
(do-parse-rest #'(stuff (... ...)) #'parse-more)]))
|
|
(parse-more code ...)))])
|
|
|
|
(provide honu-delayed)
|
|
(define-syntax-class honu-delayed
|
|
[pattern any #:with result (racket-syntax
|
|
(let ()
|
|
(define-syntax (parse-more stx)
|
|
(syntax-case stx ()
|
|
[(_ stuff (... ...))
|
|
(do-parse-rest #'(stuff (... ...)) #'parse-more)]))
|
|
(parse-more any)))])
|
|
|
|
(provide honu-function)
|
|
(define-splicing-syntax-class honu-function #:literal-sets (cruft)
|
|
[pattern (~seq function:identifier (#%parens args ...) body:honu-body)
|
|
#:with result
|
|
(with-syntax ([(parsed-arguments ...)
|
|
(parse-arguments #'(args ...))])
|
|
(racket-syntax (define (function parsed-arguments ...)
|
|
body.result)))])
|
|
|
|
(define (definition? code)
|
|
(define (contains-define? code)
|
|
(syntax-parse code #:literals (define define-honu-syntax)
|
|
[(define x ...) #t]
|
|
[(define-honu-syntax x ...) #t]
|
|
[else #f]))
|
|
(and (parsed-syntax? code)
|
|
(contains-define? code)))
|
|
|
|
;; E = macro
|
|
;; | E operator E
|
|
;; | [...]
|
|
;; | f(...)
|
|
;; | { ... }
|
|
;; | (...)
|
|
|
|
;; 1 + 1
|
|
;; ^
|
|
;; left: identity
|
|
;; current: 1
|
|
;; 1 + 1
|
|
;; ^
|
|
;; left: (lambda (x) (+ 1 x))
|
|
;; current: #f
|
|
;; 1 + 1
|
|
;; ^
|
|
;; left: (lambda (x) (+ 1 x))
|
|
;; current: 1
|
|
;;
|
|
;; 1 + 1 * 2
|
|
;; ^
|
|
;; left: (lambda (x) (left (* 1 x)))
|
|
;; current: #f
|
|
;;
|
|
;; 1 + 1 * 2
|
|
;; ^
|
|
;; left: (lambda (x) (left (* 1 x)))
|
|
;; current: 2
|
|
|
|
;; parse one form
|
|
;; return the parsed stuff and the unparsed stuff
|
|
(define (parse input)
|
|
(define (do-macro head rest precedence left current stream)
|
|
(if current
|
|
(values (left current) stream)
|
|
(begin
|
|
(debug "Honu macro at phase ~a: ~a\n" (syntax-local-phase-level) head)
|
|
(let-values ([(parsed unparsed terminate?)
|
|
((syntax-local-value head)
|
|
(with-syntax ([head head]
|
|
[(rest ...) rest])
|
|
(datum->syntax #'head
|
|
(syntax->list #'(head rest ...))
|
|
#'head #'head))
|
|
#f)])
|
|
#;
|
|
(emit-remark parsed)
|
|
#;
|
|
(emit-local-step stream parsed #:id #'do-macro)
|
|
(with-syntax ([parsed parsed]
|
|
[rest unparsed])
|
|
(debug "Output from macro ~a\n" (pretty-format (syntax->datum #'parsed)))
|
|
#;
|
|
(do-parse #'(parsed ... rest ...)
|
|
precedence left current)
|
|
;; (debug "Remove repeats from ~a\n" #'parsed)
|
|
(define re-parse (remove-repeats #'parsed)
|
|
#;
|
|
(with-syntax ([(x ...) #'parsed])
|
|
(debug "Properties on parsed ~a\n" (syntax-property-symbol-keys #'parsed))
|
|
(do-parse-rest/local #'parsed)))
|
|
(debug "Reparsed ~a\n" (pretty-format (syntax->datum re-parse)))
|
|
#;
|
|
(define re-parse (let-values ([(re-parse re-unparse)
|
|
(parse #'parsed)])
|
|
(with-syntax ([(re-parse* ...) re-parse]
|
|
[(re-unparse* ...) re-unparse])
|
|
(datum->syntax re-parse
|
|
(syntax->list
|
|
#'(%racket
|
|
(begin (re-parse* ...)
|
|
(let ()
|
|
(define-syntax (parse-more stx)
|
|
(do-parse-rest stx #'parse-more))
|
|
(parse-more re-unparse* ...)))))
|
|
re-parse re-parse))))
|
|
#;
|
|
(debug "Reparsed output ~a\n" (pretty-format (syntax->datum re-parse)))
|
|
(define terminate (definition? re-parse))
|
|
(debug "Terminate? ~a\n" terminate)
|
|
(if terminate
|
|
(values (left re-parse)
|
|
#'rest)
|
|
(do-parse #'rest precedence
|
|
left re-parse)))))))
|
|
(define (do-parse stream precedence left current)
|
|
(define-syntax-class atom
|
|
;; [pattern x:identifier #:when (not (stopper? #'x))]
|
|
[pattern x:identifier #:when (not (free-identifier=? #'#%braces #'x))]
|
|
[pattern x:str]
|
|
[pattern x:number])
|
|
|
|
(debug "parse ~a precedence ~a left ~a current ~a properties ~a\n"
|
|
(syntax->datum stream) precedence left current
|
|
(syntax-property-symbol-keys stream))
|
|
(define final (if current current #f))
|
|
(if (parsed-syntax? stream)
|
|
(values (left stream) #'())
|
|
(syntax-parse stream #:literal-sets (cruft)
|
|
#;
|
|
[x:id (values #'x #'())]
|
|
[()
|
|
(values (left final) #'())]
|
|
;; dont reparse pure racket code
|
|
[(%racket racket)
|
|
(debug "Native racket expression ~a\n" #'racket)
|
|
(if current
|
|
(values (left current) stream)
|
|
(values (left #'racket) #'()))
|
|
#;
|
|
(if current
|
|
(values (left current) stream)
|
|
(values (left #'racket) #'(rest ...)))]
|
|
;; for expressions that can keep parsing
|
|
#;
|
|
[((%racket-expression racket) rest ...)
|
|
(if current
|
|
(values (left current) stream)
|
|
(do-parse #'(rest ...)
|
|
precedence left
|
|
#'racket))]
|
|
#;
|
|
[(%racket-expression racket rest ...)
|
|
(if current
|
|
(values (left current) stream)
|
|
(do-parse #'(rest ...)
|
|
precedence left
|
|
#'racket))]
|
|
[(head rest ...)
|
|
(debug 2 "Not a special expression..\n")
|
|
(cond
|
|
[(honu-macro? #'head)
|
|
(debug "Macro ~a\n" #'head)
|
|
(do-macro #'head #'(rest ...) precedence left current stream)]
|
|
[(parsed-syntax? #'head)
|
|
(debug "Parsed syntax ~a\n" #'head)
|
|
(emit-local-step #'head #'head #:id #'do-parse)
|
|
(do-parse #'(rest ...) precedence left #'head)]
|
|
[(honu-fixture? #'head)
|
|
(debug 2 "Fixture ~a\n" #'head)
|
|
(define transformer (fixture:fixture-ref (syntax-local-value #'head) 0))
|
|
(define-values (output rest) (transformer current stream))
|
|
(do-parse rest precedence left output)]
|
|
[(honu-operator? #'head)
|
|
(define new-precedence (transformer:honu-operator-ref (syntax-local-value #'head) 0))
|
|
(define association (transformer:honu-operator-ref (syntax-local-value #'head) 1))
|
|
(define binary-transformer (transformer:honu-operator-ref (syntax-local-value #'head) 2))
|
|
(define unary-transformer (transformer:honu-operator-ref (syntax-local-value #'head) 3))
|
|
(define higher
|
|
(case association
|
|
[(left) >]
|
|
[(right) >=]))
|
|
(debug "precedence old ~a new ~a higher? ~a\n" precedence new-precedence (higher new-precedence precedence))
|
|
(if (higher new-precedence precedence)
|
|
(let-values ([(parsed unparsed)
|
|
(do-parse #'(rest ...) new-precedence
|
|
(lambda (stuff)
|
|
(define right (parse-all stuff))
|
|
(define output
|
|
(if current
|
|
(if binary-transformer
|
|
(binary-transformer (parse-all-expression current) right)
|
|
(error 'binary "cannot be used as a binary operator in ~a" #'head))
|
|
(if unary-transformer
|
|
(unary-transformer right)
|
|
(error 'unary "cannot be used as a unary operator in ~a" #'head))))
|
|
#;
|
|
(debug "Binary transformer ~a\n" binary-transformer)
|
|
#;
|
|
(emit-local-step stuff output #:id binary-transformer)
|
|
(with-syntax ([out (parse-all output)])
|
|
#'out))
|
|
|
|
#f)])
|
|
(do-parse unparsed precedence left parsed))
|
|
;; if we have a unary transformer then we have to keep parsing
|
|
(if unary-transformer
|
|
(if current
|
|
(values (left current) stream)
|
|
(do-parse #'(rest ...) new-precedence
|
|
(lambda (stuff)
|
|
(define right (parse-all stuff))
|
|
(define output (unary-transformer right))
|
|
;; apply the left function because
|
|
;; we just went ahead with parsing without
|
|
;; caring about precedence
|
|
(with-syntax ([out (left (parse-all output))])
|
|
#'out))
|
|
#f))
|
|
;; otherwise we have a binary transformer (or no transformer..??)
|
|
;; so we must have made a recursive call to parse, just return the
|
|
;; left hand
|
|
(values (left current) stream))
|
|
)]
|
|
|
|
#;
|
|
[(stopper? #'head)
|
|
(debug "Parse a stopper ~a\n" #'head)
|
|
(values (left final)
|
|
stream)]
|
|
[else
|
|
(define-splicing-syntax-class no-left
|
|
[pattern (~seq) #:when (and (= precedence 0) (not current))])
|
|
(syntax-parse #'(head rest ...) #:literal-sets (cruft)
|
|
#;
|
|
[(semicolon . rest)
|
|
(debug "Parsed a semicolon, finishing up with ~a\n" current)
|
|
(values (left current) #'rest)]
|
|
[body:honu-body
|
|
(if current
|
|
(values (left current) stream)
|
|
(values (left #'body.result) #'())
|
|
#;
|
|
(do-parse #'(rest ...) precedence left #'body.result))]
|
|
#;
|
|
[((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)]
|
|
#;
|
|
[(left:no-left function:honu-function . rest)
|
|
(values #'function.result #'rest)]
|
|
[else
|
|
(debug "Parse a single thing ~a\n" (syntax->datum #'head))
|
|
(syntax-parse #'head
|
|
#:literal-sets (cruft)
|
|
#;
|
|
[(%racket x)
|
|
(debug 2 "Native racket expression ~a\n" #'x)
|
|
(if current
|
|
(values (left current) stream)
|
|
(do-parse #'(rest ...) precedence left #'head))]
|
|
[x:atom
|
|
(debug 2 "atom ~a current ~a\n" #'x current)
|
|
(if current
|
|
(values (left current) stream)
|
|
(do-parse #'(rest ...) precedence left (racket-syntax x)))]
|
|
;; [1, 2, 3] -> (list 1 2 3)
|
|
[(#%brackets stuff ...)
|
|
(define-literal-set wheres (honu-where))
|
|
(define-literal-set equals (honu-equal))
|
|
(syntax-parse #'(stuff ...) #:literal-sets (cruft wheres equals)
|
|
[(work:honu-expression
|
|
colon (~seq variable:id honu-equal list:honu-expression (~optional honu-comma)) ...
|
|
(~seq honu-where where:honu-expression (~optional honu-comma)) ...)
|
|
(define filter (if (attribute where)
|
|
(with-syntax ([(where.result ...) (map honu->racket (syntax->list #'(where.result ...)))])
|
|
#'((#:when where.result) ...))
|
|
#'()))
|
|
(define comprehension
|
|
(with-syntax ([((filter ...) ...) filter]
|
|
[(list.result ...) (map honu->racket (syntax->list #'(list.result ...)))]
|
|
[work.result (honu->racket #'work.result)])
|
|
(racket-syntax (for/list ([variable list.result]
|
|
...
|
|
filter ... ...)
|
|
work.result))))
|
|
(if current
|
|
(values (left current) stream)
|
|
(do-parse #'(rest ...) precedence left comprehension))]
|
|
[else
|
|
(debug "Current is ~a\n" current)
|
|
(define value (with-syntax ([(data ...)
|
|
(parse-comma-expression #'(stuff ...))])
|
|
(debug "Create list from ~a\n" #'(data ...))
|
|
(racket-syntax (list data ...))))
|
|
(define lookup (with-syntax ([(data ...)
|
|
(parse-comma-expression #'(stuff ...))]
|
|
[current current])
|
|
(racket-syntax (do-lookup current data ...))))
|
|
(if current
|
|
;; (values (left current) stream)
|
|
(do-parse #'(rest ...) precedence left lookup)
|
|
(do-parse #'(rest ...) precedence left value))])]
|
|
;; block of code
|
|
[body:honu-body
|
|
(if current
|
|
(values (left current) stream)
|
|
(do-parse #'(rest ...) precedence left #'body.result))]
|
|
;; expression or function application
|
|
[(#%parens args ...)
|
|
(debug "Maybe function call with ~a\n" #'(args ...))
|
|
(if current
|
|
;; FIXME: 9000 is an arbitrary precedence level for
|
|
;; function calls
|
|
(if (> precedence 9000)
|
|
(let ()
|
|
(debug 2 "higher precedence call ~a\n" current)
|
|
(define call (with-syntax ([current (left current)]
|
|
[(parsed-args ...)
|
|
(parse-comma-expression #'(args ...)) ])
|
|
(racket-syntax (current parsed-args ...))))
|
|
(do-parse #'(rest ...) 9000 (lambda (x) x) call))
|
|
(let ()
|
|
(debug 2 "function call ~a\n" left)
|
|
(define call (with-syntax ([current current]
|
|
[(parsed-args ...)
|
|
(parse-comma-expression #'(args ...)) ])
|
|
(debug "Parsed args ~a\n" #'(parsed-args ...))
|
|
(racket-syntax (current parsed-args ...))))
|
|
(do-parse #'(rest ...) precedence left call)))
|
|
(let ()
|
|
(debug "inner expression ~a\n" #'(args ...))
|
|
(define-values (inner-expression unparsed) (parse #'(args ...)))
|
|
(when (not (empty-syntax? unparsed))
|
|
(error 'parse "expression had unparsed elements ~a" unparsed))
|
|
(do-parse #'(rest ...) precedence left inner-expression)))
|
|
|
|
#;
|
|
(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 (if (not current)
|
|
(error 'what "dont know how to parse ~a" #'head)
|
|
(values (left current) stream))]
|
|
[else (error 'what "dont know how to parse ~a" #'head)])])])])))
|
|
|
|
(define-values (parsed unparsed)
|
|
(do-parse input 0 (lambda (x) x) #f))
|
|
(values ;; (parsed-syntax parsed)
|
|
parsed
|
|
unparsed))
|
|
|
|
(define (empty-syntax? what)
|
|
(syntax-parse what
|
|
[() #t]
|
|
[else #f]))
|
|
|
|
(provide parse-one)
|
|
(define (parse-one code)
|
|
(parse (strip-stops code)))
|
|
|
|
;; keep parsing some expression until only a parsed term remains
|
|
(define (parse-all-expression code)
|
|
(define-values (parsed unparsed)
|
|
(parse code))
|
|
(when (not (empty-syntax? unparsed))
|
|
(raise-syntax-error 'parse-all-expression "expected no more syntax" code))
|
|
(if (parsed-syntax? parsed)
|
|
parsed
|
|
(parse-all-expression parsed)))
|
|
|
|
(define (parse-all code)
|
|
(let loop ([all '()]
|
|
[code code])
|
|
(define-values (parsed-original unparsed)
|
|
(parse (strip-stops code)))
|
|
(define parsed (if (parsed-syntax? parsed-original)
|
|
parsed-original
|
|
(let-values ([(out rest)
|
|
(parse parsed-original)])
|
|
(when (not (empty-syntax? rest))
|
|
(raise-syntax-error 'parse-all "expected no more syntax" parsed-original))
|
|
out)))
|
|
(debug "Parsed ~a unparsed ~a all ~a\n"
|
|
(if parsed (syntax->datum parsed) parsed)
|
|
(if unparsed (syntax->datum unparsed) unparsed)
|
|
all)
|
|
(if (empty-syntax? unparsed)
|
|
(with-syntax ([(use ...) (reverse (if parsed
|
|
(cons parsed all)
|
|
all))])
|
|
(debug "Nothing left to parse. Use ~a\n" #'(use ...))
|
|
;; If multiple things then wrap inside a begin
|
|
(syntax-parse #'(use ...)
|
|
[(x z y ...)
|
|
(emit-remark "Parsed all" #'(begin use ...))
|
|
(racket-syntax (begin use ...))]
|
|
[(x) (racket-syntax x)]))
|
|
(loop (cons parsed all)
|
|
unparsed))))
|
|
|
|
(provide parsed-things)
|
|
;; rest will be some subset of full
|
|
(define (parsed-things full rest)
|
|
(define full-datum (syntax->datum full))
|
|
(define rest-datum (syntax->datum rest))
|
|
(- (length full-datum) (length rest-datum)))
|
|
|
|
(provide honu-expression)
|
|
(define-primitive-splicing-syntax-class (honu-expression)
|
|
#:attributes (result)
|
|
#:description "expression"
|
|
(lambda (stx fail)
|
|
(define context (gensym))
|
|
(debug "[~a] honu expression syntax class on ~a\n" context stx)
|
|
(if (or (stx-null? stx)
|
|
#;
|
|
(stopper? (stx-car stx)))
|
|
(begin
|
|
(debug "[~a] failed\n" context)
|
|
(fail))
|
|
(let ()
|
|
(define-values (parsed unparsed)
|
|
(parse stx))
|
|
(debug "[~a] expression parsed ~a\n" context (if parsed (syntax->datum parsed) parsed))
|
|
(debug 2 "[~a] Parsed things ~a\n" context (parsed-things stx unparsed))
|
|
(if (parsed-syntax? parsed)
|
|
(list (parsed-things stx unparsed)
|
|
parsed)
|
|
(list (parsed-things stx unparsed)
|
|
(parse-all parsed)))))))
|
|
|
|
(provide honu-expression-list)
|
|
(define-splicing-syntax-class (honu-expression-list)
|
|
#:literal-sets (cruft)
|
|
[pattern (~seq (~seq each:honu-expression (~optional honu-comma)) ...)
|
|
#:with (each_result ...)
|
|
#'(each.result ...)
|
|
#;
|
|
(with-syntax ([(each ...) (add-between (syntax->list #'(each.result ...)) #'honu-comma)])
|
|
#'(each ...))
|
|
])
|
|
|
|
(provide honu-identifier)
|
|
(define-splicing-syntax-class honu-identifier
|
|
#:literal-sets (cruft)
|
|
[pattern (~and (~not semicolon)
|
|
x:id) #:with result #'x])
|
|
|
|
(provide honu-number)
|
|
(define-splicing-syntax-class honu-number
|
|
#:literal-sets (cruft)
|
|
[pattern x:number #:with result #'x])
|
|
|
|
|
|
(provide identifier-comma-list)
|
|
(define-splicing-syntax-class identifier-comma-list
|
|
#:literal-sets (cruft)
|
|
[pattern (~seq (~seq name:id (~optional honu-comma) ...) ...)])
|
|
|
|
(provide honu-expression/comma)
|
|
(define-splicing-syntax-class honu-expression/comma
|
|
[pattern (~seq x ...) #:with (result ...) (parse-comma-expression #'(x ...))])
|