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

implement syntax-rules in honu using syntax/parse for now

Browse Source 
svn: r16332
This commit is contained in:
Jon Rafkind 2009-10-15 23:37:20 +00:00
parent 8bd7de80e3
commit 5daa334ab7
1 changed files with 225 additions and 162 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

387
collects/honu/main.ss
View File

@ -7,6 +7,8 @@
syntax/define syntax/define
syntax/context syntax/context
syntax/name syntax/name
syntax/parse
scheme/pretty
"private/ops.ss" "private/ops.ss"
"private/util.ss" "private/util.ss"
"private/contexts.ss" "private/contexts.ss"
@ -213,190 +215,190 @@
;; The given syntax sequence must not be empty ;; The given syntax sequence must not be empty
(let () (let ()
(define (parse-expr-seq stx) (define (parse-expr-seq stx)
(define (start-expr stx) (define (start-expr stx)
(let ([trans (get-transformer stx)]) (let ([trans (get-transformer stx)])
(if trans (if trans
(let-values ([(expr rest) (trans stx the-expression-context)]) (let-values ([(expr rest) (trans stx the-expression-context)])
(if (stx-null? rest) (if (stx-null? rest)
(list expr) (list expr)
(cons expr (start-operator rest)))) (cons expr (start-operator rest))))
(syntax-case* stx (#%parens #%braces #%angles) delim-identifier=? (syntax-case* stx (#%parens #%braces #%angles) delim-identifier=?
[(v) [(v)
(or (number? (syntax-e #'v)) (or (number? (syntax-e #'v))
(identifier? #'v) (identifier? #'v)
(string? (syntax-e #'v))) (string? (syntax-e #'v)))
(if (operator? #'v) (if (operator? #'v)
(raise-syntax-error (raise-syntax-error
#f #f
"operator alone is not an expression and cannot start an expression" "operator alone is not an expression and cannot start an expression"
#'v) #'v)
(list #'v))] (list #'v))]
[((#%parens . pexpr)) [((#%parens . pexpr))
;; parens as an expression ;; parens as an expression
(if (stx-null? #'pexpr) (if (stx-null? #'pexpr)
(raise-syntax-error (raise-syntax-error
#f #f
"missing expression inside parentheses as expression" "missing expression inside parentheses as expression"
(stx-car stx)) (stx-car stx))
(list (parse-expr #'pexpr)))] (list (parse-expr #'pexpr)))]
[((#%parens . pexpr) expr . more) [((#%parens . pexpr) expr . more)
(get-transformer #'pexpr) (get-transformer #'pexpr)
;; Expand pexpr in an expression-or-type context, and make a cast ;; Expand pexpr in an expression-or-type context, and make a cast
;; if it's a type. ;; if it's a type.
(let ([trans (get-transformer #'pexpr)]) (let ([trans (get-transformer #'pexpr)])
(let-values ([(expr-or-type rest) (trans #'pexpr the-type-or-expression-context)]) (let-values ([(expr-or-type rest) (trans #'pexpr the-type-or-expression-context)])
(if (honu-type? expr-or-type) (if (honu-type? expr-or-type)
;; parens as a unary prefix operator ;; parens as a unary prefix operator
(cons (make-cast-prefix (stx-car (stx-car stx)) expr-or-type) (cons (make-cast-prefix (stx-car (stx-car stx)) expr-or-type)
(start-expr #'(expr . more))) (start-expr #'(expr . more)))
;; must have been an expression ;; must have been an expression
(cons expr-or-type (cons expr-or-type
(start-operator #'(expr . more))))))] (start-operator #'(expr . more))))))]
[((#%braces . pexpr)) [((#%braces . pexpr))
(if (stx-null? #'pexpr) (if (stx-null? #'pexpr)
(raise-syntax-error (raise-syntax-error
#f #f
"missing expression inside braces as expression" "missing expression inside braces as expression"
(stx-car stx)) (stx-car stx))
(list #'(honu-unparsed-block #f obj 'obj #f #f . pexpr)))] (list #'(honu-unparsed-block #f obj 'obj #f #f . pexpr)))]
[(op . more) [(op . more)
(and (identifier? #'op) (and (identifier? #'op)
(memq (syntax-e #'op) unary-prefix-ops)) (memq (syntax-e #'op) unary-prefix-ops))
(cons (make-prefix (stx-car stx)) (start-expr #'more))] (cons (make-prefix (stx-car stx)) (start-expr #'more))]
[(expr then . more) [(expr then . more)
(append (start-expr (list #'expr)) (append (start-expr (list #'expr))
(start-operator #'(then . more)))] (start-operator #'(then . more)))]
[(bad . rest) [(bad . rest)
(raise-syntax-error (raise-syntax-error
'expression 'expression
"unknown expression form" "unknown expression form"
#'bad)])))) #'bad)]))))
(define (start-operator stx) (define (start-operator stx)
(unless (or (and (stx-pair? (stx-car stx)) (unless (or (and (stx-pair? (stx-car stx))
(let ([id (stx-car (stx-car stx))]) (let ([id (stx-car (stx-car stx))])
(or (delim-identifier=? #'#%brackets id) (or (delim-identifier=? #'#%brackets id)
(delim-identifier=? #'#%parens id) (delim-identifier=? #'#%parens id)
(delim-identifier=? #'#%angles id)))) (delim-identifier=? #'#%angles id))))
(and (identifier? (stx-car stx)) (and (identifier? (stx-car stx))
(hash-ref op-table (hash-ref op-table
(syntax-e (stx-car stx)) (syntax-e (stx-car stx))
(lambda () #f)))) (lambda () #f))))
(raise-syntax-error (raise-syntax-error
'expression 'expression
"expected an operator, but found something else" "expected an operator, but found something else"
(stx-car stx))) (stx-car stx)))
;; Check for postfix operator, first (or parens as a ;; Check for postfix operator, first (or parens as a
;; an "infix" operator) ;; an "infix" operator)
(cond (cond
[(stx-pair? (stx-car stx)) [(stx-pair? (stx-car stx))
;; Convert vector index or application to a binary operator: ;; Convert vector index or application to a binary operator:
(let ([opl (let ([id (stx-car (stx-car stx))]) (let ([opl (let ([id (stx-car (stx-car stx))])
;; Note that we don't check for whether #%brackets, etc. is ;; Note that we don't check for whether #%brackets, etc. is
;; bound as a transformer, which means that you can't ;; bound as a transformer, which means that you can't
;; change the parsing of [], (), or <> as an "infix" operator. ;; change the parsing of [], (), or <> as an "infix" operator.
(cond (cond
[(delim-identifier=? #'#%brackets id) [(delim-identifier=? #'#%brackets id)
(let ([index-expr (parse-expr (stx-cdr (stx-car stx)))]) (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) (list (make-infix id)
index-expr))] ;; These are normally type expressions, so
[(delim-identifier=? #'#%parens id) ;; leave parsing to honu-type-ap:
(let ([arg-exprs (parse-arg-list (stx-cdr (stx-car stx)))]) (stx-cdr (stx-car stx)))]
(list (make-infix id) [else (error "internal error parsing expr")]))])
arg-exprs))] (if (stx-null? (stx-cdr stx))
[(delim-identifier=? #'#%angles id) opl
(list (make-infix id) (append opl (start-operator (stx-cdr stx)))))]
;; These are normally type expressions, so [(memq (syntax-e (stx-car stx)) unary-postfix-ops)
;; leave parsing to honu-type-ap: (if (stx-null? (stx-cdr stx))
(stx-cdr (stx-car stx)))] (list (make-postfix (stx-car stx)))
[else (error "internal error parsing expr")]))]) (cons (make-postfix (stx-car stx))
(if (stx-null? (stx-cdr stx)) (start-operator (stx-cdr stx))))]
opl [else
(append opl (start-operator (stx-cdr stx)))))] ;; Otherwise, must be infix
[(memq (syntax-e (stx-car stx)) unary-postfix-ops) (cons (make-infix (stx-car stx))
(if (stx-null? (stx-cdr stx)) (start-expr (stx-cdr stx)))]))
(list (make-postfix (stx-car stx))) (start-expr 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) (define (parse-expr stx)
(let group ([seq (parse-expr-seq stx)]) (let group ([seq (parse-expr-seq stx)])
;; seq is a list that mixes exprs with ops. ;; seq is a list that mixes exprs with ops.
;; Find leftmost oper with maximal precedence ;; Find leftmost oper with maximal precedence
(if (null? (cdr seq)) (if (null? (cdr seq))
(car seq) (car seq)
(let loop ([seq seq][before null][op #f][since null]) (let loop ([seq seq][before null][op #f][since null])
(cond (cond
[(null? seq) [(null? seq)
(cond (cond
[(cast-prefix? op) [(cast-prefix? op)
(let ([after (reverse since)]) (let ([after (reverse since)])
(group (append (reverse before) (group (append (reverse before)
(list (quasisyntax/loc (op-id op) (list (quasisyntax/loc (op-id op)
(op-cast #,(op-id op) (op-cast #,(op-id op)
#,(let ([t (cast-prefix-type op)]) #,(let ([t (cast-prefix-type op)])
(list (honu-type-stx t) (list (honu-type-stx t)
(honu-type-name-stx t) (honu-type-name-stx t)
(honu-type-pred-stx t) (honu-type-pred-stx t)
(honu-type-protect-stx t))) (honu-type-protect-stx t)))
#,(car after)))) #,(car after))))
(cdr after))))] (cdr after))))]
[(prefix? op) [(prefix? op)
(let ([after (reverse since)]) (let ([after (reverse since)])
(group (append (reverse before) (group (append (reverse before)
(list (quasisyntax/loc (op-id op) (list (quasisyntax/loc (op-id op)
(op-app #,(op-id op) #%prefix #,(car after)))) (op-app #,(op-id op) #%prefix #,(car after))))
(cdr after))))] (cdr after))))]
[(postfix? op) [(postfix? op)
(let ([after (reverse since)] (let ([after (reverse since)]
[before (reverse before)]) [before (reverse before)])
(group (append (cdr before) (group (append (cdr before)
(list (quasisyntax/loc (op-id op) (list (quasisyntax/loc (op-id op)
(op-app #,(op-id op) #%postfix #,(car before)))) (op-app #,(op-id op) #%postfix #,(car before))))
after)))] after)))]
[(infix? op) [(infix? op)
(let ([after (reverse since)]) (let ([after (reverse since)])
(group (append (reverse (cdr before)) (group (append (reverse (cdr before))
(list (quasisyntax/loc (op-id op) (list (quasisyntax/loc (op-id op)
(op-app #,(op-id op) #,(car before) #,(car after)))) (op-app #,(op-id op) #,(car before) #,(car after))))
(cdr after))))] (cdr after))))]
[else (error 'parse-expr "not an op!: ~s ~s ~s" op before since)])] [else (error 'parse-expr "not an op!: ~s ~s ~s" op before since)])]
[(not (op? (stx-car seq))) [(not (op? (stx-car seq)))
(loop (cdr seq) before op (cons (car seq) since))] (loop (cdr seq) before op (cons (car seq) since))]
[((if (prefix? op) >= >) [((if (prefix? op) >= >)
(hash-ref precedence-table (prec-key (car seq)) (lambda () 0)) (hash-ref precedence-table (prec-key (car seq)) (lambda () 0))
(hash-ref precedence-table (prec-key op) (lambda () 0))) (hash-ref precedence-table (prec-key op) (lambda () 0)))
(loop (cdr seq) (loop (cdr seq)
(if op (if op
(append since (list op) before) (append since (list op) before)
since) since)
(car seq) null)] (car seq) null)]
[else [else
(loop (cdr seq) before op (cons (car seq) since))]))))) (loop (cdr seq) before op (cons (car seq) since))])))))
(define (parse-arg-list stxs) (define (parse-arg-list stxs)
(if (stx-null? stxs) (if (stx-null? stxs)
stxs stxs
(let-values ([(val-stxs after-expr terminator) (extract-until stxs (list #'\,))]) (let-values ([(val-stxs after-expr terminator) (extract-until stxs (list #'\,))])
(when (and val-stxs (when (and val-stxs
(stx-null? (stx-cdr after-expr))) (stx-null? (stx-cdr after-expr)))
(raise-syntax-error (raise-syntax-error
'procedure\ call 'procedure\ call
"missing expression after comma" "missing expression after comma"
(stx-car after-expr))) (stx-car after-expr)))
(when (null? val-stxs) (when (null? val-stxs)
(raise-syntax-error (raise-syntax-error
'procedure\ call 'procedure\ call
"missing expression before token" "missing expression before token"
(stx-car after-expr))) (stx-car after-expr)))
(if val-stxs (if val-stxs
(cons (parse-expr val-stxs) (cons (parse-expr val-stxs)
(parse-arg-list (stx-cdr after-expr))) (parse-arg-list (stx-cdr after-expr)))
(list (parse-expr stxs)))))) (list (parse-expr stxs))))))
parse-expr)) parse-expr))
@ -1907,6 +1909,64 @@
(h-return expr)) (h-return expr))
(stx-cdr after-expr)))))) (stx-cdr after-expr))))))
(define-for-syntax (extract-conventions pattern)
(let loop ([out '()]
[in pattern])
(syntax-case in (:)
[(any : attribute rest ...)
(loop (cons #'(any expr) out)
#'(rest ...))
#;
(loop (cons #'(any attribute) out)
#'(rest ...))]
[(foo rest1 rest ...)
(loop out #'(rest1 rest ...))]
[(foo) out])))
(define-for-syntax (extract-patterns pattern)
(let loop ([out '()]
[in pattern])
(syntax-case in (:)
[(any : attribute rest ...)
(loop (cons #'any out)
#'(rest ...))]
[(foo rest1 rest ...)
(loop (cons #'foo out)
#'(rest1 rest ...))]
[(foo) (reverse (cons #'foo out))])))
(define-honu-syntax honu-macro
(lambda (stx ctx)
(syntax-case stx (#%braces)
[(_ (#%parens honu-literal ...)
(#%braces (#%braces name pattern ...))
(#%braces (#%braces template ...))
. rest)
(with-syntax ([(conventions ...)
(extract-conventions #'(pattern ...))]
[(raw-patterns ...)
(extract-patterns #'(pattern ...))])
(values
#'(begin
(define honu-literal (lambda () (error 'honu-literal "you suck")))
...
(define-honu-syntax name
(lambda (stx ctx)
(define-conventions honu-conventions conventions ...)
#;
(printf "Hello from ~a transformer. Syntax is ~a\n" 'name (syntax->datum stx))
(syntax-parse stx
#:literals (honu-literal ...)
#:conventions (honu-conventions)
[(name raw-patterns ... . rrest)
(values
#'(honu-unparsed-block
#f obj 'obj #f ctx
template ...)
#'rrest)]))))
#'rest))])
))
(define-honu-syntax honu-if (define-honu-syntax honu-if
(lambda (stx ctx) (lambda (stx ctx)
(define (get-block-or-statement kw rest) (define (get-block-or-statement kw rest)
@ -2042,8 +2102,10 @@
(define-syntax (#%dynamic-honu-module-begin stx) (define-syntax (#%dynamic-honu-module-begin stx)
;; (printf "honu raw sexp ~a\n" (syntax->datum stx)) ;; (printf "honu raw sexp ~a\n" (syntax->datum stx))
#`(#%plain-module-begin (let ([result #`(#%plain-module-begin
(honu-unparsed-begin #,@(stx-cdr stx)))) (honu-unparsed-begin #,@(stx-cdr stx)))])
;; (pretty-print (syntax->datum (expand result)))
result))
(define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx)) (define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx))
@ -2095,6 +2157,7 @@
(rename-out (set! =) (rename-out (set! =)
(honu-return return) (honu-return return)
(honu-if if) (honu-if if)
(honu-macro macro)
(honu-time time) (honu-time time)
(honu-class class) (honu-class class)
(honu+ +) (honu+ +)