bring over honu parsers
svn: r17314
This commit is contained in:
Jon Rafkind
parent
b9fd34b925
commit
881b34dd80
|
|
@ -0,0 +1,347 @@
|
||||||
|
#lang scheme/base
|
||||||
|
|
||||||
|
(require (for-syntax scheme/base
|
||||||
|
syntax/stx
|
||||||
|
syntax/parse
|
||||||
|
"contexts.ss"
|
||||||
|
"util.ss"
|
||||||
|
"ops.ss"
|
||||||
|
))
|
||||||
|
|
||||||
|
(provide (all-defined-out))
|
||||||
|
|
||||||
|
;; macro for defining literal tokens that can be used in macros
|
||||||
|
(define-syntax-rule (define-literal name)
|
||||||
|
(define-syntax name (lambda (stx)
|
||||||
|
(raise-syntax-error 'name
|
||||||
|
"this is a literal and cannot be used outside a macro"))))
|
||||||
|
|
||||||
|
(define-literal honu-return)
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
|
|
||||||
|
(define-values (prop:honu-transformer honu-transformer? honu-transformer-ref)
|
||||||
|
(make-struct-type-property 'honu-transformer))
|
||||||
|
|
||||||
|
|
||||||
|
(define-values (struct:honu-trans make-honu-trans honu-trans? honu-trans-ref honu-trans-set!)
|
||||||
|
(make-struct-type 'honu-trans #f 1 0 #f
|
||||||
|
(list (list prop:honu-transformer #t))
|
||||||
|
(current-inspector) 0))
|
||||||
|
|
||||||
|
(define (make-honu-transformer proc)
|
||||||
|
(unless (and (procedure? proc)
|
||||||
|
(procedure-arity-includes? proc 2))
|
||||||
|
(raise-type-error
|
||||||
|
'define-honu-syntax
|
||||||
|
"procedure (arity 2)"
|
||||||
|
proc))
|
||||||
|
(make-honu-trans proc))
|
||||||
|
|
||||||
|
(define operator?
|
||||||
|
(let ([sym-chars (string->list "+-_=?:<>.!%^&*/~|")])
|
||||||
|
(lambda (stx)
|
||||||
|
(and (identifier? stx)
|
||||||
|
(let ([str (symbol->string (syntax-e stx))])
|
||||||
|
(and (positive? (string-length str))
|
||||||
|
(memq (string-ref str 0) sym-chars)))))))
|
||||||
|
|
||||||
|
(define (get-transformer stx)
|
||||||
|
;; if its an identifier and bound to a transformer return it
|
||||||
|
(define (bound-transformer stx)
|
||||||
|
(and (stx-pair? stx)
|
||||||
|
(identifier? (stx-car stx))
|
||||||
|
(let ([v (syntax-local-value (stx-car stx) (lambda () #f))])
|
||||||
|
(and (honu-transformer? v) v))))
|
||||||
|
(define (special-transformer stx)
|
||||||
|
(and (stx-pair? stx)
|
||||||
|
(let ([first (stx-car stx)])
|
||||||
|
(cond
|
||||||
|
[(and (stx-pair? first)
|
||||||
|
(identifier? (stx-car first))
|
||||||
|
(delim-identifier=? #'#%parens (stx-car first)))
|
||||||
|
;; If the stx-car is a list with just one operator symbol,
|
||||||
|
;; try using the operator as a transformer
|
||||||
|
(let ([l (cdr (stx->list first))])
|
||||||
|
(let loop ([l l])
|
||||||
|
(cond
|
||||||
|
[(null? l) #f]
|
||||||
|
[(operator? (car l))
|
||||||
|
(if (ormap operator? (cdr l))
|
||||||
|
#f
|
||||||
|
(let ([v (syntax-local-value (car l) (lambda () #f))])
|
||||||
|
(and (honu-transformer? v)
|
||||||
|
v)))]
|
||||||
|
[else (loop (cdr l))])))]
|
||||||
|
[(and (stx-pair? first)
|
||||||
|
(identifier? (stx-car first))
|
||||||
|
(free-identifier=? #'#%angles (stx-car first)))
|
||||||
|
(let ([v (syntax-local-value (stx-car first) (lambda () #f))])
|
||||||
|
(and (honu-transformer? v) v))]
|
||||||
|
[else #f]))))
|
||||||
|
;; (printf "~a bound transformer? ~a\n" stx (bound-transformer stx))
|
||||||
|
(or (bound-transformer stx)
|
||||||
|
(special-transformer stx)))
|
||||||
|
|
||||||
|
(define (call-values function values-producing)
|
||||||
|
(call-with-values (lambda () values-producing) function))
|
||||||
|
|
||||||
|
;; these functions use parse-block-one
|
||||||
|
;; (define parse-a-tail-expr #f)
|
||||||
|
;; (define parse-an-expr #f)
|
||||||
|
;; (set! parse-a-tail-expr parse-tail-expr)
|
||||||
|
;; (set! parse-an-expr parse-expr)
|
||||||
|
|
||||||
|
(define parse-expr
|
||||||
|
;; The given syntax sequence must not be empty
|
||||||
|
(let ()
|
||||||
|
(define (parse-expr-seq stx)
|
||||||
|
(define (start-expr stx)
|
||||||
|
(let ([trans (get-transformer stx)])
|
||||||
|
(if trans
|
||||||
|
(let-values ([(expr rest) (trans stx the-expression-context)])
|
||||||
|
(if (stx-null? rest)
|
||||||
|
(list expr)
|
||||||
|
(cons expr (start-operator rest))))
|
||||||
|
(syntax-case* stx (#%parens #%braces #%angles) delim-identifier=?
|
||||||
|
[(v)
|
||||||
|
(or (number? (syntax-e #'v))
|
||||||
|
(identifier? #'v)
|
||||||
|
(string? (syntax-e #'v)))
|
||||||
|
(if (operator? #'v)
|
||||||
|
(raise-syntax-error
|
||||||
|
#f
|
||||||
|
"operator alone is not an expression and cannot start an expression"
|
||||||
|
#'v)
|
||||||
|
(list #'v))]
|
||||||
|
[((#%parens . pexpr))
|
||||||
|
;; parens as an expression
|
||||||
|
(if (stx-null? #'pexpr)
|
||||||
|
(raise-syntax-error
|
||||||
|
#f
|
||||||
|
"missing expression inside parentheses as expression"
|
||||||
|
(stx-car stx))
|
||||||
|
(list (parse-expr #'pexpr)))]
|
||||||
|
[((#%parens . pexpr) expr . more)
|
||||||
|
(get-transformer #'pexpr)
|
||||||
|
;; Expand pexpr in an expression-or-type context, and make a cast
|
||||||
|
;; if it's a type.
|
||||||
|
(let ([trans (get-transformer #'pexpr)])
|
||||||
|
(let-values ([(expr-or-type rest) (trans #'pexpr the-type-or-expression-context)])
|
||||||
|
(cons expr-or-type
|
||||||
|
(start-operator #'(expr . more)))
|
||||||
|
#;
|
||||||
|
(if (honu-type? expr-or-type)
|
||||||
|
;; parens as a unary prefix operator
|
||||||
|
(cons (make-cast-prefix (stx-car (stx-car stx)) expr-or-type)
|
||||||
|
(start-expr #'(expr . more)))
|
||||||
|
;; must have been an expression
|
||||||
|
(cons expr-or-type
|
||||||
|
(start-operator #'(expr . more))))))]
|
||||||
|
[((#%braces . pexpr))
|
||||||
|
(if (stx-null? #'pexpr)
|
||||||
|
(raise-syntax-error
|
||||||
|
#f
|
||||||
|
"missing expression inside braces as expression"
|
||||||
|
(stx-car stx))
|
||||||
|
(list #'(honu-unparsed-block #f obj 'obj #f #f . pexpr)))]
|
||||||
|
[(op . more)
|
||||||
|
(and (identifier? #'op)
|
||||||
|
(memq (syntax-e #'op) unary-prefix-ops))
|
||||||
|
(cons (make-prefix (stx-car stx)) (start-expr #'more))]
|
||||||
|
[(expr then . more)
|
||||||
|
(append (start-expr (list #'expr))
|
||||||
|
(start-operator #'(then . more)))]
|
||||||
|
[(bad . rest)
|
||||||
|
(raise-syntax-error
|
||||||
|
'expression
|
||||||
|
"unknown expression form"
|
||||||
|
#'bad)]))))
|
||||||
|
(define (start-operator stx)
|
||||||
|
(unless (or (and (stx-pair? (stx-car stx))
|
||||||
|
(let ([id (stx-car (stx-car stx))])
|
||||||
|
(or (delim-identifier=? #'#%brackets id)
|
||||||
|
(delim-identifier=? #'#%parens id)
|
||||||
|
(delim-identifier=? #'#%angles id))))
|
||||||
|
(and (identifier? (stx-car stx))
|
||||||
|
(hash-ref op-table
|
||||||
|
(syntax-e (stx-car stx))
|
||||||
|
(lambda () #f))))
|
||||||
|
(raise-syntax-error
|
||||||
|
'expression
|
||||||
|
"expected an operator, but found something else"
|
||||||
|
(stx-car stx)))
|
||||||
|
;; Check for postfix operator, first (or parens as a
|
||||||
|
;; an "infix" operator)
|
||||||
|
(cond
|
||||||
|
[(stx-pair? (stx-car stx))
|
||||||
|
;; Convert vector index or application to a binary operator:
|
||||||
|
(let ([opl (let ([id (stx-car (stx-car stx))])
|
||||||
|
;; Note that we don't check for whether #%brackets, etc. is
|
||||||
|
;; bound as a transformer, which means that you can't
|
||||||
|
;; change the parsing of [], (), or <> as an "infix" operator.
|
||||||
|
(cond
|
||||||
|
[(delim-identifier=? #'#%brackets id)
|
||||||
|
(let ([index-expr (parse-expr (stx-cdr (stx-car stx)))])
|
||||||
|
(list (make-infix id)
|
||||||
|
index-expr))]
|
||||||
|
[(delim-identifier=? #'#%parens id)
|
||||||
|
(let ([arg-exprs (parse-arg-list (stx-cdr (stx-car stx)))])
|
||||||
|
(list (make-infix id)
|
||||||
|
arg-exprs))]
|
||||||
|
[(delim-identifier=? #'#%angles id)
|
||||||
|
(list (make-infix id)
|
||||||
|
;; These are normally type expressions, so
|
||||||
|
;; leave parsing to honu-type-ap:
|
||||||
|
(stx-cdr (stx-car stx)))]
|
||||||
|
[else (error "internal error parsing expr")]))])
|
||||||
|
(if (stx-null? (stx-cdr stx))
|
||||||
|
opl
|
||||||
|
(append opl (start-operator (stx-cdr stx)))))]
|
||||||
|
[(memq (syntax-e (stx-car stx)) unary-postfix-ops)
|
||||||
|
(if (stx-null? (stx-cdr stx))
|
||||||
|
(list (make-postfix (stx-car stx)))
|
||||||
|
(cons (make-postfix (stx-car stx))
|
||||||
|
(start-operator (stx-cdr stx))))]
|
||||||
|
[else
|
||||||
|
;; Otherwise, must be infix
|
||||||
|
(cons (make-infix (stx-car stx))
|
||||||
|
(start-expr (stx-cdr stx)))]))
|
||||||
|
(start-expr stx))
|
||||||
|
|
||||||
|
(define (parse-expr stx)
|
||||||
|
(let group ([seq (parse-expr-seq stx)])
|
||||||
|
;; seq is a list that mixes exprs with ops.
|
||||||
|
;; Find leftmost oper with maximal precedence
|
||||||
|
(if (null? (cdr seq))
|
||||||
|
(car seq)
|
||||||
|
(let loop ([seq seq][before null][op #f][since null])
|
||||||
|
(cond
|
||||||
|
[(null? seq)
|
||||||
|
(cond
|
||||||
|
#;
|
||||||
|
[(cast-prefix? op)
|
||||||
|
(let ([after (reverse since)])
|
||||||
|
(group (append (reverse before)
|
||||||
|
(list (quasisyntax/loc (op-id op)
|
||||||
|
(op-cast #,(op-id op)
|
||||||
|
#,(let ([t (cast-prefix-type op)])
|
||||||
|
(list (honu-type-stx t)
|
||||||
|
(honu-type-name-stx t)
|
||||||
|
(honu-type-pred-stx t)
|
||||||
|
(honu-type-protect-stx t)))
|
||||||
|
#,(car after))))
|
||||||
|
(cdr after))))]
|
||||||
|
[(prefix? op)
|
||||||
|
(let ([after (reverse since)])
|
||||||
|
(group (append (reverse before)
|
||||||
|
(list (quasisyntax/loc (op-id op)
|
||||||
|
(op-app #,(op-id op) #%prefix #,(car after))))
|
||||||
|
(cdr after))))]
|
||||||
|
[(postfix? op)
|
||||||
|
(let ([after (reverse since)]
|
||||||
|
[before (reverse before)])
|
||||||
|
(group (append (cdr before)
|
||||||
|
(list (quasisyntax/loc (op-id op)
|
||||||
|
(op-app #,(op-id op) #%postfix #,(car before))))
|
||||||
|
after)))]
|
||||||
|
[(infix? op)
|
||||||
|
(let ([after (reverse since)])
|
||||||
|
(group (append (reverse (cdr before))
|
||||||
|
(list (quasisyntax/loc (op-id op)
|
||||||
|
(op-app #,(op-id op) #,(car before) #,(car after))))
|
||||||
|
(cdr after))))]
|
||||||
|
[else (error 'parse-expr "not an op!: ~s ~s ~s" op before since)])]
|
||||||
|
[(not (op? (stx-car seq)))
|
||||||
|
(loop (cdr seq) before op (cons (car seq) since))]
|
||||||
|
[((if (prefix? op) >= >)
|
||||||
|
(hash-ref precedence-table (prec-key (car seq)) (lambda () 0))
|
||||||
|
(hash-ref precedence-table (prec-key op) (lambda () 0)))
|
||||||
|
(loop (cdr seq)
|
||||||
|
(if op
|
||||||
|
(append since (list op) before)
|
||||||
|
since)
|
||||||
|
(car seq) null)]
|
||||||
|
[else
|
||||||
|
(loop (cdr seq) before op (cons (car seq) since))])))))
|
||||||
|
|
||||||
|
(define (parse-arg-list stxs)
|
||||||
|
(if (stx-null? stxs)
|
||||||
|
stxs
|
||||||
|
(let-values ([(val-stxs after-expr terminator) (extract-until stxs (list #'\,))])
|
||||||
|
(when (and val-stxs
|
||||||
|
(stx-null? (stx-cdr after-expr)))
|
||||||
|
(raise-syntax-error
|
||||||
|
'procedure\ call
|
||||||
|
"missing expression after comma"
|
||||||
|
(stx-car after-expr)))
|
||||||
|
(when (null? val-stxs)
|
||||||
|
(raise-syntax-error
|
||||||
|
'procedure\ call
|
||||||
|
"missing expression before token"
|
||||||
|
(stx-car after-expr)))
|
||||||
|
(if val-stxs
|
||||||
|
(cons (parse-expr val-stxs)
|
||||||
|
(parse-arg-list (stx-cdr after-expr)))
|
||||||
|
(list (parse-expr stxs))))))
|
||||||
|
|
||||||
|
parse-expr))
|
||||||
|
|
||||||
|
(define (parse-tail-expr expr-stxs)
|
||||||
|
(syntax-parse expr-stxs
|
||||||
|
#:literals (honu-return)
|
||||||
|
[(honu-return expr ...)
|
||||||
|
#:fail-when (stx-null? #'(expr ...)) "missing expression"
|
||||||
|
(parse-expr (syntax->list #'(expr ...)))]
|
||||||
|
[else (parse-expr expr-stxs)]))
|
||||||
|
|
||||||
|
(define (parse-block-one context body combine-k done-k)
|
||||||
|
(define (parse-one expr-stxs after-expr terminator)
|
||||||
|
(define (checks)
|
||||||
|
(unless expr-stxs
|
||||||
|
(raise-syntax-error
|
||||||
|
#f
|
||||||
|
"expected a semicolon to terminate form"
|
||||||
|
(stx-car body)))
|
||||||
|
(when (null? expr-stxs)
|
||||||
|
(raise-syntax-error
|
||||||
|
#f
|
||||||
|
"missing expression before terminator"
|
||||||
|
terminator)))
|
||||||
|
(checks)
|
||||||
|
(let* ([parser (if (block-context-return? context)
|
||||||
|
parse-tail-expr
|
||||||
|
parse-expr)]
|
||||||
|
[code (parser expr-stxs)])
|
||||||
|
(with-syntax ([top-expr ((if (top-block-context? context)
|
||||||
|
(lambda (x)
|
||||||
|
`(show-top-result ,x))
|
||||||
|
values)
|
||||||
|
code)])
|
||||||
|
(combine-k #'(#%expression top-expr)
|
||||||
|
(stx-cdr after-expr)))))
|
||||||
|
(cond
|
||||||
|
[(stx-null? body) (done-k)]
|
||||||
|
[(get-transformer body) =>
|
||||||
|
(lambda (transformer)
|
||||||
|
(let-values ([(code rest) (transformer body context)])
|
||||||
|
(combine-k code rest)))]
|
||||||
|
[else (call-values parse-one (extract-until body (list #'\;
|
||||||
|
)))]))
|
||||||
|
|
||||||
|
)
|
||||||
|
|
||||||
|
(define-syntax (honu-unparsed-begin stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_) #'(begin)]
|
||||||
|
[(_ . body) (let-values ([(code rest) (parse-block-one the-top-block-context
|
||||||
|
#'body
|
||||||
|
values
|
||||||
|
(lambda ()
|
||||||
|
(values #'(void) null)))])
|
||||||
|
(with-syntax ([code code]
|
||||||
|
[(rest ...) rest])
|
||||||
|
#'(begin code (honu-unparsed-begin rest ...))))]))
|
||||||
|
|
||||||
|
(define-syntax-rule (#%dynamic-honu-module-begin forms ...)
|
||||||
|
(#%plain-module-begin (honu-unparsed-begin forms ...)))
|
||||||
Loading…
Reference in New Issue
Block a user