361 lines
13 KiB
Racket
361 lines
13 KiB
Racket
#lang racket/base
|
|
|
|
(define-syntax-rule (require-syntax stuff ...)
|
|
(require (for-syntax stuff ...)))
|
|
|
|
;; phase 0
|
|
(require ;; "macro2.rkt"
|
|
"literals.rkt"
|
|
"debug.rkt"
|
|
(prefix-in transformer: "transformer.rkt")
|
|
syntax/stx
|
|
syntax/parse/experimental/splicing
|
|
syntax/parse)
|
|
;; phase 1
|
|
(require-syntax racket/base)
|
|
|
|
;; phase -1
|
|
(require (for-template racket/base
|
|
racket/splicing
|
|
"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 "operator? ~a ~a\n" check value)
|
|
(transformer:honu-operator? value)))
|
|
|
|
(define (bound-to-macro? check)
|
|
(let ([value (get-value check)])
|
|
(debug "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 (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 "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)])))
|
|
|
|
;; 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])
|
|
(syntax-parse code
|
|
[(x:stopper rest ...) (strip-stops #'(rest ...))]
|
|
[else code]))
|
|
|
|
(define (parse-comma-expression arguments)
|
|
(if (null? (syntax->list arguments))
|
|
'()
|
|
(let loop ([used '()]
|
|
[rest arguments])
|
|
(if (empty-syntax? rest)
|
|
(reverse used)
|
|
(let-values ([(parsed unparsed)
|
|
;; FIXME: don't strip all stops, just comma
|
|
(parse (strip-stops rest))])
|
|
(loop (cons parsed used)
|
|
unparsed))))))
|
|
|
|
(define parsed-property (gensym 'honu-parsed))
|
|
(define (parsed-syntax syntax)
|
|
(syntax-property syntax parsed-property #t))
|
|
|
|
(define (parsed-syntax? syntax)
|
|
(syntax-property syntax parsed-property))
|
|
|
|
(define (stopper? what)
|
|
(define-literal-set check (honu-comma semicolon colon))
|
|
(define is (and (identifier? what)
|
|
((literal-set->predicate check) what)))
|
|
(debug "Comma? ~a ~a\n" what is)
|
|
is)
|
|
|
|
;; 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-parse stream precedence left current)
|
|
(define-syntax-class atom
|
|
[pattern x:identifier]
|
|
[pattern x:str]
|
|
[pattern x:number])
|
|
|
|
(debug "parse ~a precedence ~a left ~a current ~a\n" stream precedence left current)
|
|
(define final (if current current #'(void)))
|
|
(syntax-parse stream #:literal-sets (cruft)
|
|
[()
|
|
(values (left final) #'())]
|
|
[(head rest ...)
|
|
(cond
|
|
[(honu-macro? #'head)
|
|
(begin
|
|
(debug "Honu macro ~a\n" #'head)
|
|
(let-values ([(parsed unparsed terminate?)
|
|
((syntax-local-value #'head) #'(head rest ...) #f)])
|
|
(with-syntax ([parsed parsed]
|
|
[rest unparsed])
|
|
(if terminate?
|
|
(values (left #'parsed)
|
|
#'rest)
|
|
(do-parse #'rest precedence
|
|
left #'parsed)))))]
|
|
[(parsed-syntax? #'head)
|
|
(do-parse #'(rest ...) precedence left #'head)]
|
|
[(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)
|
|
(do-parse #'(rest ...) new-precedence
|
|
(lambda (stuff)
|
|
(if current
|
|
(if binary-transformer
|
|
(left (binary-transformer current stuff))
|
|
(error '#'head "cannot be used as a binary operator"))
|
|
(if unary-transformer
|
|
(left (unary-transformer stuff))
|
|
(error '#'head "cannot be used as a unary operator"))))
|
|
#f)
|
|
(do-parse #'(head rest ...)
|
|
0
|
|
(lambda (x) x)
|
|
(left final)))]
|
|
[(stopper? #'head)
|
|
(values (left final)
|
|
stream)]
|
|
[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))]
|
|
;; [1, 2, 3] -> (list 1 2 3)
|
|
[(#%brackets stuff ...)
|
|
(syntax-parse #'(stuff ...) #:literal-sets (cruft)
|
|
[(work:honu-expression colon (~seq variable:id honu-<- list:honu-expression (~optional honu-comma)) ...)
|
|
(define comprehension #'(for/list ([variable list.result]
|
|
...)
|
|
work.result))
|
|
(if current
|
|
(error 'parse "a list comprehension cannot follow an expression")
|
|
(do-parse #'(rest ...) precedence left comprehension))]
|
|
[else
|
|
(define value (with-syntax ([(data ...)
|
|
(parse-comma-expression #'(stuff ...))])
|
|
#'(list data ...)))
|
|
(define lookup (with-syntax ([(data ...)
|
|
(parse-comma-expression #'(stuff ...))]
|
|
[current current])
|
|
#'(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
|
|
[(#%braces stuff ...)
|
|
(if current
|
|
(values (left current) stream)
|
|
(let ()
|
|
(define body (parse-all #'(stuff ...)))
|
|
(do-parse #'(rest ...) precedence left body)))]
|
|
;; expression or function application
|
|
[(#%parens args ...)
|
|
(if current
|
|
(let ()
|
|
(debug "function call ~a\n" left)
|
|
(define call (with-syntax ([current current]
|
|
[(parsed-args ...)
|
|
(parse-comma-expression #'(args ...)) ])
|
|
#'(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 (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)
|
|
unparsed))
|
|
|
|
(define (empty-syntax? what)
|
|
(syntax-parse what
|
|
[() #t]
|
|
[else #f]))
|
|
|
|
(provide parse-one)
|
|
(define (parse-one code)
|
|
(parse (strip-stops code)))
|
|
|
|
(define (parse-all code)
|
|
(let loop ([all '()]
|
|
[code code])
|
|
(define-values (parsed unparsed)
|
|
(parse (strip-stops code)))
|
|
(debug "Parsed ~a unparsed ~a\n" (syntax->datum parsed)
|
|
(syntax->datum unparsed))
|
|
(if (empty-syntax? unparsed)
|
|
(with-syntax ([(use ...) (reverse (cons parsed all))])
|
|
#'(begin use ...))
|
|
(loop (cons parsed all)
|
|
unparsed))))
|
|
|
|
(define (parse2 forms)
|
|
(debug "parse forms ~a\n" forms)
|
|
(when (stx-pair? forms)
|
|
(define head (stx-car forms))
|
|
(if (honu-macro? head)
|
|
(begin
|
|
(debug "honu macro ~a\n" head)
|
|
(let-values ([(parsed rest)
|
|
((syntax-local-value head) forms #f)])
|
|
(with-syntax ([parsed parsed]
|
|
[rest rest])
|
|
#'(splicing-let-syntax ([more-parsing (lambda (stx)
|
|
(debug "more parsing!!\n")
|
|
(parse stx))])
|
|
parsed
|
|
(more-parsing . rest)))))
|
|
#'(debug "regular parsing\n"))))
|
|
|
|
;; 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)
|
|
(debug "honu expression syntax class\n")
|
|
(define-values (parsed unparsed)
|
|
(parse stx))
|
|
(debug "parsed ~a\n" parsed)
|
|
(list (parsed-things stx unparsed) parsed)))
|
|
|
|
(provide identifier-comma-list)
|
|
(define-splicing-syntax-class identifier-comma-list
|
|
#:literal-sets (cruft)
|
|
[pattern (~seq (~seq name:id (~optional honu-comma)) ...)])
|