2099 lines
92 KiB
Racket
2099 lines
92 KiB
Racket
#lang scheme/base
|
|
|
|
(require (for-syntax
|
|
syntax/stx
|
|
scheme/base
|
|
syntax/kerncase
|
|
syntax/define
|
|
syntax/context
|
|
syntax/name
|
|
syntax/parse
|
|
scheme/pretty
|
|
"ops.rkt"
|
|
"util.rkt"
|
|
"contexts.rkt"
|
|
))
|
|
|
|
(provide (all-defined-out))
|
|
|
|
(begin-for-syntax
|
|
;; these definitions are used as stop-lists in local-expand
|
|
(define kernel-forms (kernel-form-identifier-list))
|
|
(define prop-expand-stop-forms (list* #'honu-typed
|
|
#'honu-unparsed-block
|
|
kernel-forms))
|
|
(define block-expand-stop-forms prop-expand-stop-forms)
|
|
(define prototype-expand-stop-forms (list
|
|
#'honu-prototype))
|
|
(define type-name-expand-stop-forms (list
|
|
#'honu-type-name))
|
|
|
|
|
|
;; --------------------------------------------------------
|
|
;; Transformer procedure property and basic struct
|
|
|
|
(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))
|
|
|
|
;; --------------------------------------------------------
|
|
;; Type
|
|
|
|
(define-values (struct:honu-type make-h-type honu-type? honu-type-ref honu-type-set!)
|
|
(make-struct-type 'honu-type #f 4 0 #f null (current-inspector) 0))
|
|
|
|
(define (honu-type-stx v) (honu-type-ref v 0))
|
|
(define (honu-type-name-stx v) (honu-type-ref v 1))
|
|
(define (honu-type-pred-stx v) (honu-type-ref v 2))
|
|
(define (honu-type-protect-stx v) (honu-type-ref v 3))
|
|
|
|
;; convert a honu type into a list with nice formatting
|
|
;; todo: need example
|
|
(define (format-type t)
|
|
(if (identifier? t)
|
|
(syntax-e t)
|
|
(syntax-case t (-> forall)
|
|
[(-> (res . _) (arg . __) ...)
|
|
(append (map format-type (syntax->list #'(arg ...)))
|
|
(list '-> (format-type #'res)))]
|
|
[(forall (id ...) rhs bindings)
|
|
(append (map syntax-e (syntax->list #'(id ...)))
|
|
(list '>-> (format-type #'rhs)))]
|
|
[_else `(??? ,(syntax->datum t))])))
|
|
|
|
;; --------------------------------------------------------
|
|
;; Parsing blocks
|
|
|
|
;; #t if the syntax object contains an operator
|
|
(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)))))))
|
|
|
|
;; #t if the identifier is not an operator nor a delimiter
|
|
(define (honu-identifier? stx)
|
|
(and (identifier? stx)
|
|
(not (ormap (lambda (i) (delim-identifier=? stx i)) (list #'\; #'\,)))
|
|
(not (operator? stx))))
|
|
|
|
(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)))
|
|
|
|
;; --------------------------------------------------------
|
|
;; Parsing blocks
|
|
|
|
(define parse-an-expr #f)
|
|
(define parse-a-tail-expr #f)
|
|
|
|
(define (parse-block-one ctx body k done-k)
|
|
(cond
|
|
[(stx-null? body) (done-k)]
|
|
[(get-transformer body)
|
|
=> (lambda (transformer)
|
|
(let-values ([(code rest) (transformer body ctx)])
|
|
(k code rest)))]
|
|
[else (let-values ([(expr-stxs after-expr terminator)
|
|
(extract-until body (list #'\;))])
|
|
(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))
|
|
(let ([code ((if (block-context-return? ctx)
|
|
parse-a-tail-expr
|
|
parse-an-expr)
|
|
expr-stxs)])
|
|
(k #`(#%expression #,((if (top-block-context? ctx)
|
|
(lambda (x)
|
|
`(show-top-result ,x))
|
|
values)
|
|
code))
|
|
(stx-cdr after-expr))))]))
|
|
|
|
(define (parse-block stx ctx)
|
|
(let loop ([stx stx])
|
|
(parse-block-one ctx
|
|
stx
|
|
(lambda (code rest)
|
|
(cons code (loop rest)))
|
|
(lambda ()
|
|
null))))
|
|
|
|
(define (expression-result ctx expr rest)
|
|
(if (top-block-context? ctx)
|
|
(values #`(#%expression (show-top-result #,expr)) rest)
|
|
(values #`(#%expression #,expr) rest)))
|
|
|
|
|
|
(define (finish-parsing-expression what where expr rest ctx)
|
|
(if (or (expression-context? ctx)
|
|
(type-or-expression-context? ctx))
|
|
(values expr rest)
|
|
;; Since we're parsing an expression in a
|
|
;; declaration context, we're responsible for
|
|
;; getting the whole expression:
|
|
(let ([placeholder (datum->syntax #f (gensym))])
|
|
(let-values ([(expr-stxs after-expr terminator) (extract-until (cons placeholder rest) (list #'\;))])
|
|
(unless expr-stxs
|
|
(raise-syntax-error
|
|
#f
|
|
(format "expected a semicolon to terminate form after ~a" what)
|
|
where))
|
|
(let* ([total-expr (let loop ([in-expr (parse-an-expr expr-stxs)])
|
|
(cond
|
|
[(eq? in-expr placeholder) expr]
|
|
[(syntax? in-expr)
|
|
(datum->syntax in-expr
|
|
(loop (syntax-e in-expr))
|
|
in-expr
|
|
in-expr
|
|
in-expr)]
|
|
[(pair? in-expr) (cons (loop (car in-expr))
|
|
(loop (cdr in-expr)))]
|
|
[else in-expr]))])
|
|
(expression-result ctx
|
|
total-expr
|
|
(stx-cdr after-expr)))))))
|
|
|
|
;; --------------------------------------------------------
|
|
;; Parsing expressions
|
|
|
|
(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)])
|
|
(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-case expr-stxs (honu-return)
|
|
[(honu-return expr ...)
|
|
(let ([exprs #'(expr ...)])
|
|
(when (stx-null? exprs)
|
|
(raise-syntax-error
|
|
#f
|
|
"missing expression"
|
|
(stx-car expr-stxs)))
|
|
(parse-expr exprs))]
|
|
[_else
|
|
(parse-expr expr-stxs)]))
|
|
|
|
(set! parse-an-expr parse-expr)
|
|
(set! parse-a-tail-expr parse-tail-expr)
|
|
|
|
;; --------------------------------------------------------
|
|
;; Parsing declarations (which always start with a type)
|
|
|
|
(define (parse-one-argument proc-id type id k)
|
|
(cons (list id
|
|
(honu-type-stx type)
|
|
(honu-type-name-stx type)
|
|
(honu-type-pred-stx type)
|
|
(honu-type-protect-stx type))
|
|
(k)))
|
|
|
|
(define (parse-arguments orig-args-stx proc-id)
|
|
(if (stx-null? orig-args-stx)
|
|
null
|
|
(let loop ([args-stx orig-args-stx]
|
|
[where "at start of argument sequence"]
|
|
[where-stx orig-args-stx])
|
|
(let-values ([(type rest-stx) (if (syntax-case* args-stx (\,) delim-identifier=?
|
|
[(id \, . rest)
|
|
(honu-identifier? #'id)
|
|
#t]
|
|
[(id)
|
|
(honu-identifier? #'id)
|
|
#t]
|
|
[_else #f])
|
|
(values (make-h-type #'obj #''obj #f #f)
|
|
args-stx)
|
|
(let ([trans (get-transformer args-stx)])
|
|
(if trans
|
|
(trans args-stx the-type-context)
|
|
(values #f #f))))])
|
|
(unless (honu-type? type)
|
|
(raise-syntax-error
|
|
'|procedure declaration|
|
|
(format "expected an identifier or type ~a, found something else" where)
|
|
where-stx))
|
|
(syntax-case rest-stx ()
|
|
[(id)
|
|
(honu-identifier? #'id)
|
|
(parse-one-argument proc-id type #'id
|
|
(lambda () null))]
|
|
[(id comma . rest)
|
|
(and (honu-identifier? #'id)
|
|
(identifier? #'comma)
|
|
(delim-identifier=? #'comma #'\,))
|
|
(parse-one-argument proc-id type #'id
|
|
(lambda ()
|
|
(loop #'rest
|
|
"after comma"
|
|
#'comma)))]
|
|
[(id something . rest)
|
|
(honu-identifier? #'id)
|
|
(raise-syntax-error
|
|
'procedure\ declaration
|
|
"expected a comma after argument identifier, found something else"
|
|
#'something)]
|
|
[_else
|
|
(raise-syntax-error
|
|
'procedure\ declaration
|
|
"expected an argument identifier, found something else"
|
|
(car rest-stx))])))))
|
|
|
|
(define (parse-types main-stx orig-args-stx)
|
|
(if (stx-null? orig-args-stx)
|
|
null
|
|
(let loop ([args-stx orig-args-stx]
|
|
[where "at start of type sequence"]
|
|
[where-stx orig-args-stx])
|
|
(let-values ([(type rest-stx) (let ([trans (get-transformer args-stx)])
|
|
(if trans
|
|
(trans args-stx the-type-context)
|
|
(values #f #f)))])
|
|
(unless (honu-type? type)
|
|
(raise-syntax-error
|
|
'|type application|
|
|
(format "expected a type ~a, found something else" where)
|
|
main-stx
|
|
where-stx))
|
|
(syntax-case rest-stx ()
|
|
[()
|
|
(list type)]
|
|
[(comma . rest)
|
|
(cons type (loop #'rest
|
|
"after comma"
|
|
#'comma))]
|
|
[(something . rest)
|
|
(raise-syntax-error
|
|
'procedure\ declaration
|
|
"expected a comma after type, found something else"
|
|
main-stx
|
|
#'something)])))))
|
|
|
|
(define (make-honu-type pred-id get-type-name type-name-expr mk-pred-def)
|
|
(make-honu-trans
|
|
(lambda (orig-stx ctx)
|
|
(let-values ([(type-name type-name-expr pred-id protect-id)
|
|
(if mk-pred-def
|
|
(mk-pred-def orig-stx)
|
|
(let ([name (get-type-name orig-stx)])
|
|
(values name
|
|
(or type-name-expr #`'#,name)
|
|
pred-id
|
|
#f)))])
|
|
(cond
|
|
[(let ([is-expr?
|
|
(lambda ()
|
|
(syntax-case orig-stx (function)
|
|
[(function . __) #t]
|
|
[(_ function . __) #t]
|
|
[_else #f]))])
|
|
(and (or (block-context? ctx)
|
|
(definition-context? ctx)
|
|
(prototype-context? ctx)
|
|
(and (or (expression-context? ctx)
|
|
(type-or-expression-context? ctx))
|
|
(is-expr?)))
|
|
(or (not (expression-block-context? ctx))
|
|
(is-expr?))))
|
|
(with-syntax ([pred-id pred-id]
|
|
[protect-id protect-id]
|
|
[type-name type-name]
|
|
[type-name-expr type-name-expr])
|
|
(let loop ([stx (if (and (not (definition-context? ctx))
|
|
(not (prototype-context? ctx))
|
|
(syntax-case orig-stx (function)
|
|
[(function . __) #t]
|
|
[_else #f]))
|
|
orig-stx
|
|
(stx-cdr orig-stx))]
|
|
[after (stx-car orig-stx)]
|
|
[after-what "type name"])
|
|
(syntax-case stx ()
|
|
[(id . rest)
|
|
(begin
|
|
(unless (honu-identifier? #'id)
|
|
(raise-syntax-error 'declaration
|
|
(format "expected a identifier after ~a" after-what)
|
|
(stx-car orig-stx)
|
|
#'id))
|
|
(if (and (or (value-definition-context? ctx)
|
|
(not (free-identifier=? #'id #'function)))
|
|
(not (function-definition-context? ctx))
|
|
(not (prototype-context? ctx))
|
|
(identifier? (stx-car #'rest))
|
|
(free-identifier=? #'set! (stx-car #'rest)))
|
|
;; -- Non-procedure declaration
|
|
(if (function-definition-context? ctx)
|
|
(raise-syntax-error
|
|
'declaration
|
|
"expected parentheses after name for function definition"
|
|
(stx-car #'rest))
|
|
(let-values ([(val-stxs after-expr terminator) (extract-until (stx-cdr #'rest)
|
|
(list #'\; #'\,))])
|
|
(unless val-stxs
|
|
(raise-syntax-error
|
|
'declaration
|
|
"missing semicolon or comma after initializing assignment"
|
|
(stx-car #'rest)))
|
|
(when (null? val-stxs)
|
|
(raise-syntax-error
|
|
'declaration
|
|
"missing expression initializing assignment"
|
|
(stx-car #'rest)))
|
|
(let ([def #`(define-typed id
|
|
#,(constant-definition-context? ctx)
|
|
#f type-name type-name-expr pred-id protect-id
|
|
(check-expr-type #f 'id type-name type-name-expr pred-id
|
|
(let ([id (honu-unparsed-expr #,@val-stxs)])
|
|
id)))])
|
|
(if (delim-identifier=? #'\; (stx-car after-expr))
|
|
(values #`(begin #,def) (stx-cdr after-expr))
|
|
(let-values ([(defs remainder kind) (loop (stx-cdr after-expr) (stx-car after-expr) "comma" #f)])
|
|
(values #`(begin #,def #,defs) remainder))))))
|
|
;; -- Procedure declaration
|
|
(if (value-definition-context? ctx)
|
|
(raise-syntax-error
|
|
'declaration
|
|
(format "expected = after name in ~a context" (context->name ctx))
|
|
(stx-car #'rest))
|
|
(syntax-case* #'rest (#%parens \;) delim-identifier=?
|
|
[((#%parens . prest) (#%braces . body) . rest)
|
|
(let ([args (parse-arguments #'prest #'id)])
|
|
(with-syntax ([((arg arg-type arg-type-name arg-pred-id arg-protect-id) ...) args]
|
|
[(temp-id ...) (generate-temporaries (map car args))]
|
|
[def-id (if (and (not (definition-context? ctx))
|
|
(free-identifier=? #'id #'function))
|
|
(or (syntax-local-infer-name #'id)
|
|
(car (generate-temporaries '(function))))
|
|
#'id)])
|
|
(if (prototype-context? ctx)
|
|
;; Just generate the prototype (as needed for polymorphic functions,
|
|
;; for example)
|
|
#`(honu-prototype (type-name protect-id)
|
|
(arg-type arg-pred-id arg-type-name) ...)
|
|
;; Generate a function declaration
|
|
(let ([decl
|
|
#`(begin
|
|
(define-typed-procedure def-id
|
|
(type-name type-name-expr protect-id)
|
|
((arg arg-type arg-type-name arg-pred-id) ...)
|
|
(lambda (temp-id ...)
|
|
(define-typed arg #f id arg-type arg-type-name arg-pred-id arg-protect-id temp-id) ...
|
|
(honu-unparsed-block def-id type-name type-name-expr pred-id #t . body))))])
|
|
(if (and (not (definition-context? ctx))
|
|
(free-identifier=? #'id #'function))
|
|
;; Anonymous function:
|
|
;; We may have to continue parsing...
|
|
(finish-parsing-expression "anonymous function"
|
|
#'id
|
|
#`(let () #,decl def-id) #'rest ctx)
|
|
;; Function definition:
|
|
(values decl #'rest))))))]
|
|
;; --- Error handling ---
|
|
[((#%parens . prest) . bad-rest)
|
|
(begin
|
|
(parse-arguments #'prest #'id)
|
|
(raise-syntax-error
|
|
'|procedure declaration|
|
|
"braces for function body after parenthesized arguments"
|
|
(stx-car #'rest)
|
|
#'id))]
|
|
[(id . _)
|
|
(raise-syntax-error
|
|
'|declaration|
|
|
(cond
|
|
[(constant-definition-context? ctx) "expected = (for constant initialization)"]
|
|
[(variable-definition-context? ctx) "expected = (for variable initialization)"]
|
|
[(function-definition-context? ctx) "expected parens (for function arguments)"]
|
|
[(or (expression-context? ctx)
|
|
(type-or-expression-context? ctx)
|
|
(expression-block-context? ctx))
|
|
"expected parens (for function arguments)"]
|
|
[else
|
|
"expected either = (for variable intialization) or parens (for function arguments)"])
|
|
#'id)]))))]
|
|
[_else
|
|
(raise-syntax-error #f
|
|
(format "expected a identifier after ~a" after-what)
|
|
after
|
|
#'id)])))]
|
|
[(or (type-context? ctx)
|
|
(type-or-expression-context? ctx))
|
|
(values (make-h-type type-name type-name-expr pred-id protect-id) (stx-cdr orig-stx))]
|
|
[else
|
|
(raise-syntax-error #f
|
|
(format "illegal in ~a context" (context->name ctx))
|
|
(stx-car orig-stx))])))))
|
|
|
|
(define (make-proc-predicate form)
|
|
;; `Form' starts with a operator-transformer sequence
|
|
(let-values ([(args-stx ->-stx result-stx)
|
|
(let loop ([stx (stx-cdr (stx-car form))][args null])
|
|
(if (and (identifier? (stx-car stx))
|
|
(free-identifier=? #'-> (stx-car stx)))
|
|
(values (reverse args) (stx-car stx) (stx-cdr stx))
|
|
(loop (stx-cdr stx) (cons (stx-car stx) args))))])
|
|
(when (stx-null? result-stx)
|
|
(raise-syntax-error
|
|
#f
|
|
"missing type for result"
|
|
->-stx))
|
|
(let ([arg-types
|
|
(let loop ([args-stx args-stx])
|
|
(if (stx-null? args-stx)
|
|
null
|
|
(let ([trans (get-transformer args-stx)])
|
|
(unless trans
|
|
(raise-syntax-error #f
|
|
"non-type within a procedure-type construction"
|
|
->-stx
|
|
(stx-car args-stx)))
|
|
(let-values ([(type rest-stx) (trans args-stx the-type-context)])
|
|
(cons type (loop rest-stx))))))]
|
|
[result-type
|
|
(let ([trans (get-transformer result-stx)])
|
|
(unless trans
|
|
(raise-syntax-error #f
|
|
"non-type in result position for procedure-type construction"
|
|
->-stx
|
|
(stx-car result-stx)))
|
|
(let-values ([(type rest-stx) (trans result-stx the-type-context)])
|
|
(unless (stx-null? rest-stx)
|
|
(raise-syntax-error #f
|
|
"extra tokens following result for procedure-type construction"
|
|
->-stx
|
|
(stx-car rest-stx)))
|
|
type))])
|
|
(with-syntax ([(arg ...) (generate-temporaries arg-types)]
|
|
[(arg-type ...) (map honu-type-stx arg-types)]
|
|
[(arg-type-name ...) (map honu-type-name-stx arg-types)]
|
|
[(arg-pred-id ...) (map honu-type-pred-stx arg-types)]
|
|
[(arg-protect-id ...) (map honu-type-protect-stx arg-types)]
|
|
[result-type (honu-type-stx result-type)]
|
|
[result-type-name (honu-type-name-stx result-type)]
|
|
[result-pred-id (honu-type-pred-stx result-type)]
|
|
[result-protect-id (honu-type-protect-stx result-type)]
|
|
[n (length arg-types)])
|
|
(values
|
|
#'(-> (result-type result-protect-id)
|
|
(arg-type arg-type-name arg-pred-id) ...)
|
|
#'`(,arg-type-name ... -> ,result-type-name)
|
|
#`(lambda (v)
|
|
(if (and (procedure? v)
|
|
(procedure-arity-includes? v n))
|
|
(values #t (lambda (arg ...)
|
|
(check-expr-type
|
|
#f #t result-type result-type-name result-pred-id
|
|
(v (honu-typed arg #f arg-type arg-protect-id) ...))))
|
|
(values #f #f)))
|
|
#`(lambda (v)
|
|
(lambda (arg ...)
|
|
(honu-typed (v (check-expr-type #f #f arg-type arg-type-name arg-pred-id arg)
|
|
...)
|
|
#f
|
|
result-type
|
|
result-protect-id))))))))
|
|
|
|
(define (make-poly-predicate form)
|
|
;; `Form' starts with an operator-transformer sequence
|
|
(let-values ([(args-stx >->-stx result-stx)
|
|
(let loop ([stx (stx-cdr (stx-car form))][args null])
|
|
(if (and (identifier? (stx-car stx))
|
|
(free-identifier=? #'>-> (stx-car stx)))
|
|
(values (reverse args) (stx-car stx) (stx-cdr stx))
|
|
(loop (stx-cdr stx) (cons (stx-car stx) args))))])
|
|
(when (stx-null? result-stx)
|
|
(raise-syntax-error
|
|
#f
|
|
"missing right-hand-side type template"
|
|
>->-stx))
|
|
(for-each (lambda (arg)
|
|
(unless (identifier? arg)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an identifier for a generic-type formal argument"
|
|
>->-stx
|
|
arg)))
|
|
args-stx)
|
|
(with-syntax ([(arg-id ...) args-stx]
|
|
[(arg-pred-id ...) (generate-temporaries args-stx)]
|
|
[(arg-name-id ...) (generate-temporaries args-stx)]
|
|
[n (add1 (* 2 (length args-stx)))])
|
|
;; To get the right type name, we have to parse result-stx:
|
|
(let-values ([(type-name result-type-name)
|
|
(let ([ex (local-expand #`(let ()
|
|
(define-syntax arg-id (make-honu-type #'values stx-car #f #f)) ...
|
|
(honu-type-name arg-id ...)
|
|
(honu-unparsed-type-name #'>->-stx . #,result-stx))
|
|
'expression
|
|
type-name-expand-stop-forms)])
|
|
(syntax-case ex (honu-type-name)
|
|
[(let () (l-s+v b1 b2
|
|
(honu-type-name bound-arg-id ...)
|
|
(honu-type-name result-type result-type-name)))
|
|
(values #`(forall (bound-arg-id ...) result-type (arg-pred-id ... arg-name-id ...))
|
|
#'result-type-name)]))])
|
|
(values type-name
|
|
#``(arg-id ... >-> ,#,result-type-name)
|
|
#`(lambda (v)
|
|
(if (and (generic? v)
|
|
(procedure-arity-includes? (generic-val v) n))
|
|
;; So far, so good. Check the rest lazily.
|
|
(values #t (make-generic
|
|
(lambda (safe? arg-pred-id ... arg-name-id ...)
|
|
(define-syntax arg-id (make-honu-type #'arg-pred-id stx-car #'arg-name-id #f)) ...
|
|
(honu-unparsed-type-predicate #,>->-stx next-pred res-type-name . #,result-stx)
|
|
(let ([v ((generic-val v) safe? arg-pred-id ... arg-name-id ...)])
|
|
(check* #f #f res-type-name next-pred v)))))
|
|
;; Not a generic
|
|
(values #f #f)))
|
|
;; generics always protect themselves, for now:
|
|
#'(lambda (x) x))))))
|
|
|
|
(define (poly-subs t orig-ids binding-ids new-types new-preds new-protects new-type-names)
|
|
(syntax-case t (-> poly)
|
|
[id
|
|
(identifier? t)
|
|
(or (and (identifier? t)
|
|
(ormap (lambda (orig new)
|
|
(and (free-identifier=? t orig)
|
|
new))
|
|
orig-ids new-types))
|
|
t)]
|
|
[(-> (res res-protect) (arg arg-pred arg-type-name) ...)
|
|
(let ([cvt (lambda (p) (poly-subs p orig-ids binding-ids new-types new-preds new-protects new-type-names))]
|
|
[wrap (lambda (expr) (and binding-ids
|
|
(and (syntax-e expr)
|
|
#`((lambda #,binding-ids #,expr)
|
|
#,@new-preds
|
|
#,@new-type-names))))])
|
|
(with-syntax ([res (cvt #'res)]
|
|
[res-protect (wrap #'res-protect)]
|
|
[(arg ...) (map cvt (syntax->list #'(arg ...)))]
|
|
[(arg-pred ...) (map wrap (syntax->list #'(arg-pred ...)))]
|
|
[(arg-type-name ...) (map wrap (syntax->list #'(arg-type-name ...)))])
|
|
#'(-> (res res-protect) (arg arg-pred arg-type-name) ...)))]
|
|
[else t]))
|
|
|
|
(define (apparent-type val-expr)
|
|
(syntax-case val-expr (#%datum)
|
|
[(#%datum . val-expr) (apparent-type #'val-expr)]
|
|
[_else
|
|
(cond
|
|
[(and (integer? (syntax-e val-expr))
|
|
(exact? (syntax-e val-expr))) #'int]
|
|
[(real? (syntax-e val-expr)) #'real]
|
|
[(number? (syntax-e val-expr)) #'num]
|
|
[(string? (syntax-e val-expr)) #'string]
|
|
[(boolean? (syntax-e val-expr)) #'bool]
|
|
[(identifier? val-expr)
|
|
(cond
|
|
[(free-identifier=? #'false val-expr) #'bool]
|
|
[(free-identifier=? #'true val-expr) #'bool]
|
|
[else #'obj])]
|
|
[else #'obj])]))
|
|
|
|
(define (check-compatible-type val-expr orig-val-expr val-type target-type fail-k)
|
|
;; Check whether target-type subsumes val-type, and returns #t if so.
|
|
;; If val-type subsumes target-type, the result is #f.
|
|
;; If the two types are incompatible, `fail-k' is called.
|
|
(syntax-case target-type (-> forall)
|
|
[ttid
|
|
(identifier? target-type)
|
|
(or (free-identifier=? #'obj target-type)
|
|
(and (identifier? val-type)
|
|
(free-identifier=? val-type target-type))
|
|
(let ([val-type
|
|
(if (not val-type)
|
|
(apparent-type val-expr)
|
|
val-type)])
|
|
(or (and (identifier? val-type)
|
|
(or (free-identifier=? val-type target-type)
|
|
(and (free-identifier=? #'num target-type)
|
|
(or (free-identifier=? val-type #'int)
|
|
(free-identifier=? val-type #'real)))
|
|
(and (free-identifier=? #'real target-type)
|
|
(or (free-identifier=? val-type #'int)))))
|
|
(if (and (identifier? val-type)
|
|
(free-identifier=? val-type #'obj))
|
|
#f
|
|
(fail-k orig-val-expr val-type target-type)))))]
|
|
[(-> (t-result-type t-result-protect-id) (t-arg-type t-arg-type-name t-arg-pred) ...)
|
|
(let* ([val-type (or val-type (apparent-type val-expr))]
|
|
[do-fail (lambda ()
|
|
(fail-k orig-val-expr val-type target-type))])
|
|
(syntax-case val-type (->)
|
|
[(-> (v-result-type v-result-protect-id) (v-arg-type v-arg-type-name v-arg-pred) ...)
|
|
(let ([t-args (syntax->list #'(t-arg-type ...))]
|
|
[v-args (syntax->list #'(v-arg-type ...))])
|
|
(and (or (= (length t-args) (length v-args))
|
|
(do-fail))
|
|
(check-compatible-type val-expr orig-val-expr
|
|
#'v-result-type #'t-result-type
|
|
(lambda (a b c) (do-fail)))
|
|
(andmap (lambda (t-arg v-arg)
|
|
(check-compatible-type val-expr orig-val-expr
|
|
t-arg v-arg
|
|
(lambda (a b c)
|
|
(do-fail))))
|
|
t-args v-args)))]
|
|
[_else
|
|
(if (free-identifier=? val-type #'obj)
|
|
#f
|
|
(do-fail))]))]
|
|
[(forall (poly-id ...) poly-t bindings)
|
|
(let ([val-type (or val-type (apparent-type val-expr))]
|
|
[do-fail (lambda ()
|
|
(fail-k orig-val-expr val-type target-type))])
|
|
(syntax-case val-type (forall)
|
|
[(forall (v-poly-id ...) v-poly-t v-bindings)
|
|
(let ([poly-ids (syntax->list #'(poly-id ...))]
|
|
[v-poly-ids (syntax->list #'(v-poly-id ...))])
|
|
(if (= (length poly-ids) (length v-poly-ids))
|
|
(let ([new-ids (generate-temporaries poly-ids)])
|
|
(check-compatible-type
|
|
val-expr orig-val-expr
|
|
(poly-subs #'poly-t poly-ids #f new-ids new-ids new-ids #f)
|
|
(poly-subs #'v-poly-t v-poly-ids #f new-ids new-ids new-ids #f)
|
|
(lambda (a b c) (do-fail))))
|
|
(do-fail)))]
|
|
[else
|
|
(if (and (identifier? val-type)
|
|
(free-identifier=? val-type #'obj))
|
|
#f
|
|
(do-fail))]))]
|
|
[_else
|
|
(syntax-case val-type (-> forall)
|
|
[(-> . rest)
|
|
(fail-k orig-val-expr val-type target-type)]
|
|
[(forall . rest)
|
|
(fail-k orig-val-expr val-type target-type)]
|
|
[else #f])]))
|
|
|
|
(define (type-mismatch val-expr val-type target-type)
|
|
(raise-syntax-error
|
|
'|static type mismatch|
|
|
(format "type `~s' does not match type `~s'"
|
|
(format-type val-type)
|
|
(format-type target-type))
|
|
val-expr))
|
|
|
|
(define parse-comma-separated
|
|
(lambda (body terminated? empty-case parse-one combine)
|
|
(syntax-case* body (\;) delim-identifier=?
|
|
[(\;) terminated? (empty-case)]
|
|
[_else
|
|
(let loop ([body body][accum null][prev-comma #f])
|
|
(syntax-case* body (\, \;) delim-identifier=?
|
|
[()
|
|
(not terminated?)
|
|
(values (reverse accum) body)]
|
|
[(\, . rest)
|
|
(let-values ([(one) (parse-one (reverse accum) prev-comma (stx-car body))]
|
|
[(other rest) (loop #'rest null (stx-car body))])
|
|
(values (combine one other) rest))]
|
|
[(\; . rest)
|
|
terminated?
|
|
(values (parse-one (reverse accum) prev-comma (stx-car body)) #'rest)]
|
|
[(x . rest)
|
|
(loop #'rest (cons #'x accum) #f)]))]))))
|
|
|
|
;; ----------------------------------------
|
|
;; end begin-for-syntax
|
|
|
|
(define (check proc who type-name pred val)
|
|
(let-values ([(tst new-val) (pred val)])
|
|
(unless tst
|
|
(raise
|
|
(make-exn:fail:contract
|
|
(format "~a: expected `~a' value for ~a, got something else: ~e"
|
|
(or proc (if (eq? who #t) #f who) "procedure")
|
|
type-name
|
|
(cond [(eq? who #t) "result"]
|
|
[else (if proc
|
|
(format "`~a' argument" who)
|
|
(if who "initialization" "argument"))])
|
|
val)
|
|
(current-continuation-marks))))
|
|
new-val))
|
|
|
|
(define-syntax as-protected
|
|
(syntax-rules ()
|
|
[(_ expr)
|
|
;; No need for `expr' to protect itself:
|
|
(check-expr-type #f #f #t #t #t expr)]))
|
|
|
|
(define-syntax as-test
|
|
(syntax-rules ()
|
|
[(_ expr) (as-protected expr)]))
|
|
|
|
(define-for-syntax (extract-type v)
|
|
;; Lifts type checks up so that we can see them immediately:
|
|
(syntax-case v (#%expression if begin quote-syntax honu-type-info)
|
|
[(begin (quote-syntax (honu-type-info orig-expr val-type protect-id)) val)
|
|
(list #'orig-expr #'val-type #'protect-id)]
|
|
[(if t orig-then-expr orig-else-expr)
|
|
(with-syntax ([(orig-then-expr then-type then-protect-id) (extract-type #'orig-then-expr)]
|
|
[(orig-else-expr else-type else-protect-id) (extract-type #'orig-else-expr)])
|
|
(cond
|
|
[(check-compatible-type #f v #'else-type #'then-type type-mismatch)
|
|
(list v #'then-type #'then-protect-id)]
|
|
[(check-compatible-type #f v #'then-type #'else-type type-mismatch)
|
|
(list v #'else-type #'else-protect-id)]
|
|
[else
|
|
(raise-syntax-error #f
|
|
"need a least-upper bound?!"
|
|
v)]))]
|
|
[(lv ([(lhs ...) expr] ...) ... body)
|
|
(ormap (lambda (id)
|
|
(free-identifier=? #'lv id))
|
|
(list #'let-values #'letrec-values #'letrec-syntaxes+values))
|
|
(extract-type #'body)]
|
|
[(begin e ... last-expr)
|
|
(extract-type #'last-expr)]
|
|
[(%expression expr)
|
|
(extract-type #'expr)]
|
|
[_else
|
|
(list v (apparent-type v) #f)]))
|
|
|
|
(define-for-syntax (expand-for-type stx)
|
|
(let-values ([(v pack-v) (syntax-local-expand-expression
|
|
#`(as-protected #,stx))])
|
|
(list* pack-v v (extract-type v))))
|
|
|
|
;; (define-for-syntax certify (syntax-local-certifier))
|
|
|
|
(define-syntax (check-expr-type stx)
|
|
;; Pushes type checks down to be treated by later expansion:
|
|
(syntax-case stx ()
|
|
[(_ proc who type-name type-name-expr pred val)
|
|
;; Avoid the check if the static types are consistent
|
|
(let ([v (local-expand
|
|
#'val
|
|
'expression
|
|
prop-expand-stop-forms)])
|
|
;; FIXME: this is where we run afoul of certificates, because we're
|
|
;; pulling apart something produced by `local-expand'.
|
|
(syntax-case v (honu-typed if
|
|
let-values letrec-values letrec-syntaxes+values
|
|
begin #%expression
|
|
honu-unparsed-block)
|
|
[(honu-typed val orig-expr val-type protect-id)
|
|
(if (eq? #t (syntax-e #'type-name))
|
|
;; Context guarantees correct use, as long as we report our type:
|
|
#'(honu-report-type val orig-expr val-type protect-id)
|
|
;; Context guarantees use at a particular type...
|
|
(if (check-compatible-type #'val #'orig-expr #'val-type #'type-name type-mismatch)
|
|
;; Declared type subsumes actual type:
|
|
(if (and (syntax-e #'protect-id)
|
|
(not (check-compatible-type #f #f #'type-name #'val-type (lambda (a b c) #f))))
|
|
;; Type subsumes, but still need to protect:
|
|
v
|
|
(if (syntax-e #'protect-id)
|
|
;; Don't need protect:
|
|
#'(honu-typed val orig-expr val-type #f)
|
|
;; Didn't declare protect anyway:
|
|
v))
|
|
;; Need a run-time check:
|
|
(with-syntax ([val v])
|
|
#'(check* proc who type-name-expr pred val))))]
|
|
[(if test-expr then-expr else-expr)
|
|
(if (eq? #t (syntax-e #'type-name))
|
|
;; Context guarantees correct use, but we have to manage any
|
|
;; merge for subsumption.
|
|
(with-syntax ([(pack-t-expr t-expr orig-t-expr t-type t-protect-id)
|
|
(expand-for-type #'then-expr)]
|
|
[(pack-e-expr e-expr orig-e-expr e-type e-protect-id)
|
|
(expand-for-type #'else-expr)])
|
|
(if (check-compatible-type #'e-expr #'else-expr #'e-type #'t-type type-mismatch)
|
|
(if (check-compatible-type #'t-expr #'then-expr #'t-type #'e-type type-mismatch)
|
|
;; branch types are equivalent
|
|
#'(honu-typed (if test-expr pack-t-expr pack-e-expr)
|
|
val t-type t-protect-id)
|
|
;; then subsumes else
|
|
#'(honu-typed (if test-expr
|
|
pack-t-expr
|
|
(e-protect-id pack-e-expr))
|
|
val t-type t-protect-id))
|
|
(if (check-compatible-type #'t-expr #'then-expr #'t-type #'e-type type-mismatch)
|
|
;; else subsumes then
|
|
#'(honu-typed (if test-expr
|
|
(t-protect-id pack-t-expr)
|
|
pack-e-expr)
|
|
val e-type e-protect-id)
|
|
;; neither subsumes the other, but they are compatible
|
|
;; --- we're losing information about the LUB
|
|
#'(if test-expr
|
|
(t-protect-id pack-t-expr)
|
|
(e-protect-id pack-e-expr)))))
|
|
;; Context guarantees use at a particular type.
|
|
;; Simply propagate check to braches:
|
|
#'(if test-expr
|
|
(check-expr-type proc who type-name type-name-expr pred then-expr)
|
|
(check-expr-type proc who type-name type-name-expr pred else-expr)))]
|
|
[(let-values ([(id) rhs]) body-id)
|
|
;; recognized when `let' is being used to name an expression
|
|
(and (identifier? #'body-id)
|
|
(bound-identifier=? #'id #'body-id))
|
|
#'(let-values ([(id) (check-expr-type proc who type-name type-name-expr pred rhs)]) body-id)]
|
|
[(let-values bindings body0 ... body)
|
|
#'(let-values bindings
|
|
body0 ...
|
|
(check-expr-type proc who type-name type-name-expr pred body))]
|
|
[(letrec-values bindings body0 ... body)
|
|
#'(letrec-values bindings
|
|
body0 ...
|
|
(check-expr-type proc who type-name type-name-expr pred body))]
|
|
[(letrec-syntaxes+values bindings1 bindings2 body0 ... body)
|
|
#'(letrec-syntaxes+values bindings1 bindings2
|
|
body0...
|
|
(check-expr-type proc who type-name type-name-expr pred body))]
|
|
[(begin e0 ... e)
|
|
#'(begin e0 ... (check-expr-type proc who type-name type-name-expr pred e))]
|
|
[(#%expression e)
|
|
#'(#%expression (check-expr-type proc who type-name type-name-expr pred e))]
|
|
[(honu-unparsed-block #f _ __ #f return-context? . body)
|
|
#'(honu-unparsed-block who type-name type-name-expr pred return-context? . body)]
|
|
[_else
|
|
(if (eq? #t (syntax-e #'type-name))
|
|
v
|
|
;; Even without a type for v, we might see a literal,
|
|
;; or maybe the declaration is simply val
|
|
(if (or (check-compatible-type v v #f #'type-name type-mismatch)
|
|
(not (syntax-e #'pred)))
|
|
;; No run-time check:
|
|
v
|
|
;; Run-time check:
|
|
(with-syntax ([val v])
|
|
#'(check* proc who type-name-expr pred val))))]))]))
|
|
|
|
(define-syntax check*
|
|
(syntax-rules ()
|
|
[(_ proc who type-name #f val) val]
|
|
[(_ proc who type-name pred val)
|
|
(check proc who type-name pred val)]))
|
|
|
|
(define-syntax (honu-app stx)
|
|
(syntax-case stx ()
|
|
[(_ a b ...)
|
|
(with-syntax ([(pack-a-expr a-expr orig-a-expr a-type a-protect-id)
|
|
(expand-for-type #'a)]
|
|
[orig-expr stx])
|
|
(syntax-case #'a-type (-> obj)
|
|
[(-> (result-type result-protect-id) (arg-type arg-type-name arg-pred) ...)
|
|
(if (= (length (syntax->list #'(arg-type ...)))
|
|
(length (syntax->list #'(b ...))))
|
|
;; Some run-time checks maybe needed on some arguments:
|
|
(with-syntax ([app
|
|
(syntax/loc stx
|
|
(pack-a-expr (check-expr-type #f #f arg-type arg-type-name arg-pred b) ...))])
|
|
(syntax/loc stx
|
|
(honu-typed app
|
|
orig-expr
|
|
result-type result-protect-id)))
|
|
(raise-syntax-error #f
|
|
(format (string-append
|
|
"static type mismatch: "
|
|
"function called with the wrong number of arguments; "
|
|
"expected ~a, given ~a")
|
|
(length (syntax->list #'(arg-type ...)))
|
|
(length (syntax->list #'(b ...))))
|
|
#'orig-expr))]
|
|
[obj
|
|
;; There will be a run-time check to make sure that a is the
|
|
;; right kind of function, etc., and it will take care of the
|
|
;; argument checks itself.
|
|
(syntax/loc stx
|
|
(#%app (honu-typed pack-a-expr orig-a-expr a-type a-protect-id) b ...))]
|
|
[_else
|
|
(type-mismatch #'orig-a-expr #'a-type #'(-> (.... #f) (.... #f #f)))]))]))
|
|
|
|
(define-syntax (op-app stx)
|
|
(syntax-case stx (#%parens #%angles)
|
|
[(_ #%parens a (b ...))
|
|
#'(honu-app a b ...)]
|
|
[(_ #%angles a (b ...))
|
|
#'(honu-type-app a b ...)]
|
|
[(_ a b ...)
|
|
(datum->syntax #'a
|
|
(cons #'a #'(b ...))
|
|
#'a)]))
|
|
|
|
(define-syntax (op-cast stx)
|
|
(syntax-case stx (#%parens)
|
|
[(_ #%parens (type-name type-name-expr pred-id protect-id) b)
|
|
#'(honu-typed (check-expr-type #f #f type-name type-name-expr pred-id b)
|
|
b
|
|
type-name
|
|
#f)]))
|
|
|
|
(define-syntax (honu-#%app stx)
|
|
(syntax-case stx ()
|
|
[(_ a b ...) #'(#%expression (honu-app a b ...))]))
|
|
|
|
(define-syntax (honu-type-app stx)
|
|
(syntax-case stx ()
|
|
[(_ a b ...)
|
|
(with-syntax ([(pack-a-expr a-expr orig-a-expr a-type a-protect-id)
|
|
(expand-for-type #'a)])
|
|
(let ([types (parse-types stx #'(b ...))])
|
|
(with-syntax ([ids (generate-temporaries types)])
|
|
(check-compatible-type #'a-expr #'a #'a-type #'(forall ids obj #f)
|
|
type-mismatch))
|
|
(with-syntax ([(pred ...) (map honu-type-pred-stx types)]
|
|
[(name ...) (map honu-type-name-stx types)]
|
|
[cnt (add1 (* 2 (length types)))])
|
|
(syntax-case #'a-type (forall)
|
|
[(forall (formal-id ...) t bindings)
|
|
(with-syntax ([new-type (poly-subs #'t
|
|
(syntax->list #'(formal-id ...))
|
|
(syntax->list #'bindings)
|
|
(map honu-type-stx types)
|
|
(map honu-type-pred-stx types)
|
|
(map honu-type-protect-stx types)
|
|
(map honu-type-name-stx types))])
|
|
#`(honu-typed ((generic-val pack-a-expr) #t pred ... name ...) #,stx new-type #f))]
|
|
[_else #'((extract-polymorphic pack-a-expr cnt) #f pred ... name ...)]))))]))
|
|
|
|
(define-syntax (define-typed stx)
|
|
(syntax-case stx ()
|
|
[(_ id const? proc-name type-name type-name-expr pred-id protect-id val)
|
|
(with-syntax ([gen-id (car (generate-temporaries (list #'id)))])
|
|
#'(begin
|
|
(define gen-id val)
|
|
(define-syntax id
|
|
(make-set!-transformer
|
|
(lambda (stx)
|
|
(syntax-case stx (set!)
|
|
[(set! id rhs)
|
|
(if const?
|
|
(raise-syntax-error #f "cannot assign to constant" #'id)
|
|
(syntax/loc stx
|
|
(set! gen-id (check-expr-type 'set! id type-name type-name-expr pred-id rhs))))]
|
|
[(id arg (... ...))
|
|
(syntax/loc stx
|
|
(honu-app (honu-typed gen-id id type-name protect-id) arg (... ...)))]
|
|
[id
|
|
(syntax/loc stx
|
|
(honu-typed gen-id id type-name protect-id))]))))))]))
|
|
|
|
(define-for-syntax (make-typed-procedure gen-id result-spec arg-spec protect-id)
|
|
(with-syntax ([((arg arg-type arg-type-name arg-pred-id) ...) arg-spec]
|
|
;; FIXME! protect-id is quote-syntax'd and expanding it here
|
|
;; runs into trouble due to lexical marks
|
|
;; [(result-type result-type-name result-protect-id) result-spec]
|
|
[(result-type result-type-name result-protect-id) (list #'#f #'#f #'#f)]
|
|
[gen-id gen-id])
|
|
(with-syntax ([type-name #'(-> (result-type result-protect-id)
|
|
(arg-type arg-type-name arg-pred-id) ...)])
|
|
(make-set!-transformer
|
|
(lambda (stx)
|
|
(syntax-case stx (set! honu-safe-use-hack)
|
|
[(set! id rhs)
|
|
(raise-syntax-error #f
|
|
"cannot assign to procedure name"
|
|
stx
|
|
#'id)]
|
|
[(id honu-safe-use-hack)
|
|
#'gen-id]
|
|
[(id actual-arg ...)
|
|
(let ([actual-args (syntax->list #'(actual-arg ...))]
|
|
[formal-args (syntax->list #'(arg ...))])
|
|
(unless (= (length actual-args)
|
|
(length formal-args))
|
|
(raise-syntax-error
|
|
'id
|
|
(format "expects ~a arguments, provided ~a"
|
|
(length formal-args)
|
|
(length actual-args))
|
|
stx))
|
|
;; FIXME!
|
|
#'(#%app gen-id actual-arg ...)
|
|
#;
|
|
#'(honu-typed (#%app gen-id actual-arg ...) id result-type result-protect-id)
|
|
#;
|
|
#'(honu-typed (#%app gen-id
|
|
(check-expr-type 'id 'arg arg-type arg-type-name arg-pred-id actual-arg)
|
|
...)
|
|
id
|
|
result-type
|
|
result-protect-id))]
|
|
[id
|
|
#`(honu-typed gen-id id type-name #,protect-id)]))))))
|
|
|
|
;; FIXME: some of these must be exported due to a bad `local-expand':
|
|
(provide honu-typed check-expr-type honu-app op-app
|
|
define-typed-procedure define-typed
|
|
honu-unparsed-block
|
|
extract-polymorphic generic-val)
|
|
|
|
(define-syntax (define-typed-procedure stx)
|
|
(syntax-case stx ()
|
|
[(_ id result-spec arg-spec val)
|
|
(with-syntax ([gen-id (car (generate-temporaries (list #'id)))]
|
|
[((arg arg-type arg-type-name arg-pred-id) ...) #'arg-spec]
|
|
[(result-type result-type-name result-protect-id) #'result-spec])
|
|
#'(begin
|
|
(define gen-id val)
|
|
(define-syntax id
|
|
(make-typed-procedure (quote-syntax gen-id)
|
|
(quote-syntax result-spec)
|
|
(quote-syntax arg-spec)
|
|
(quote-syntax
|
|
(lambda (orig)
|
|
(let ([id (lambda (arg ...)
|
|
(honu-typed (orig (check-expr-type 'id 'arg arg-type arg-type-name arg-pred-id arg)
|
|
...)
|
|
#f
|
|
result-type
|
|
result-protect-id))])
|
|
id)))))))]))
|
|
|
|
(define-syntax honu-typed
|
|
(syntax-rules ()
|
|
[(_ expr orig-expr type #f)
|
|
(honu-report-type expr orig-expr type #f)]
|
|
[(_ expr orig-expr type protect-id)
|
|
;; The `protect-id' must be an expression that can be
|
|
;; lifted out of any enclosing `let' binding.
|
|
;; Since nothing stripped the `honu-typed' from `expr',
|
|
;; we need to protect the value by applying `protect-id':
|
|
(honu-report-type (protect-id expr) orig-expr type #f)]))
|
|
|
|
(define-syntax honu-report-type
|
|
(syntax-rules ()
|
|
[(_ expr orig-expr type protect-id)
|
|
;; Preserve information in a particular pattern that survives full
|
|
;; expansion, but that doesn't create any run-time overhead:
|
|
(#%expression (begin (quote-syntax (honu-type-info orig-expr type protect-id))
|
|
expr))]))
|
|
|
|
(define-syntax (honu-type-info stx) (raise-syntax-error #f "shouldn't appear unquoted!" stx))
|
|
|
|
;; (require-for-syntax syntax/context)
|
|
(define-syntax (honu-block stx)
|
|
;; A block can have mixed exprs and defns. Wrap expressions with
|
|
;; `(define-values () ... (values))' as needed, and add a (void)
|
|
;; at the end if needed. Also, wrap the final expression with
|
|
;; a type check as needed.
|
|
(let ([proc-id (stx-car (stx-cdr stx))]
|
|
[result-type-name (stx-car (stx-cdr (stx-cdr stx)))]
|
|
[result-type-name-expr (stx-car (stx-cdr (stx-cdr (stx-cdr stx))))]
|
|
[result-pred-id (stx-car (stx-cdr (stx-cdr (stx-cdr (stx-cdr stx)))))]
|
|
[exprs
|
|
(let ([def-ctx (syntax-local-make-definition-context)]
|
|
[ctx (generate-expand-context)])
|
|
(begin0
|
|
(let loop ([exprs (cddddr (cdr (syntax->list stx)))])
|
|
(apply
|
|
append
|
|
(map (lambda (expr)
|
|
(let ([expr (local-expand
|
|
expr
|
|
ctx
|
|
block-expand-stop-forms
|
|
def-ctx)])
|
|
(syntax-case expr (begin define-values define-syntaxes)
|
|
[(begin . rest)
|
|
(loop (syntax->list #'rest))]
|
|
[(define-syntaxes (id ...) rhs)
|
|
(andmap identifier? (syntax->list #'(id ...)))
|
|
(with-syntax ([rhs (local-transformer-expand
|
|
#'rhs
|
|
'expression
|
|
null)])
|
|
(syntax-local-bind-syntaxes
|
|
(syntax->list #'(id ...))
|
|
#'rhs def-ctx)
|
|
(list #'(define-syntaxes (id ...) rhs)))]
|
|
[(define-values (id ...) rhs)
|
|
(andmap identifier? (syntax->list #'(id ...)))
|
|
(let ([ids (syntax->list #'(id ...))])
|
|
(syntax-local-bind-syntaxes ids #f def-ctx)
|
|
(list expr))]
|
|
[else
|
|
(list expr)])))
|
|
exprs)))
|
|
(internal-definition-context-seal def-ctx)))])
|
|
#`(let ()
|
|
#,@(let loop ([exprs exprs][prev-defns null][prev-exprs null])
|
|
(cond
|
|
[(null? exprs) (append
|
|
(reverse prev-defns)
|
|
(if (pair? prev-exprs)
|
|
(reverse (cons
|
|
#`(check-expr-type '#,proc-id #t
|
|
#,result-type-name
|
|
#,result-type-name-expr
|
|
#,result-pred-id
|
|
#,(car prev-exprs))
|
|
(cdr prev-exprs)))
|
|
(begin
|
|
(unless (or (not proc-id)
|
|
(not (syntax-e proc-id))
|
|
(free-identifier=? #'type-name #'obj))
|
|
(error "no expression for type check; should have been "
|
|
"caught earlier"))
|
|
(reverse prev-exprs)))
|
|
(if (null? prev-exprs)
|
|
(list #'(void))
|
|
null))]
|
|
[(and (stx-pair? (car exprs))
|
|
(identifier? (stx-car (car exprs)))
|
|
(or (free-identifier=? #'define-values (stx-car (car exprs)))
|
|
(free-identifier=? #'define-syntaxes (stx-car (car exprs)))))
|
|
(loop (cdr exprs)
|
|
(cons (car exprs)
|
|
(append
|
|
(map (lambda (expr)
|
|
#`(define-values () (begin #,expr (values))))
|
|
prev-exprs)
|
|
prev-defns))
|
|
null)]
|
|
[else
|
|
(loop (cdr exprs) prev-defns (cons (car exprs) prev-exprs))])))))
|
|
|
|
(define-syntax (honu-unparsed-block stx)
|
|
(syntax-case stx (void)
|
|
[(_ proc-id result-type-name result-type-name-expr result-pred-id return-context? . body)
|
|
#`(honu-block proc-id result-type-name result-type-name-expr result-pred-id
|
|
#,@(parse-block
|
|
#'body
|
|
(if (syntax-e #'return-context?)
|
|
the-return-block-context
|
|
the-block-context)))]))
|
|
|
|
(define-syntax (honu-unparsed-expr stx)
|
|
(syntax-case stx ()
|
|
[(_ v ...) #`(#%expression #,(parse-expr (syntax->list #'(v ...))))]))
|
|
|
|
(define-syntax (h-return stx)
|
|
(syntax-case stx ()
|
|
[(_ expr) #'(#%expression expr)]))
|
|
|
|
(define-syntax (#%parens stx)
|
|
(raise-syntax-error #f "misplaced parentheses" stx))
|
|
|
|
(define-syntax (#%brackets stx)
|
|
(raise-syntax-error #f "misplaced brackets" stx))
|
|
|
|
(define-syntax (#%braces stx)
|
|
(raise-syntax-error #f "misplaced braces" stx))
|
|
|
|
(define-syntax (&& stx)
|
|
(syntax-case stx ()
|
|
[(_ a b) #'(and a b)]))
|
|
|
|
(define-syntax (!= stx)
|
|
(syntax-case stx ()
|
|
[(_ a b) #'(not (equal? a b))]))
|
|
|
|
(define-syntax (\|\| stx)
|
|
(syntax-case stx ()
|
|
[(_ a b) #'(or a b)]))
|
|
|
|
;; --------------------------------------------------------
|
|
;; Defining a new transformer or new type
|
|
|
|
;; (require-for-syntax syntax/define)
|
|
(define-syntax (define-honu-syntax stx)
|
|
(let-values ([(id rhs) (normalize-definition stx #'lambda #f)])
|
|
(with-syntax ([id id]
|
|
[rhs rhs])
|
|
#'(define-syntax id (make-honu-transformer rhs)))))
|
|
|
|
(define-syntax (define-type stx)
|
|
(syntax-case stx ()
|
|
[(_ id pred-expr)
|
|
(identifier? #'id)
|
|
(with-syntax ([pred-id (car (generate-temporaries '(pred)))])
|
|
#'(begin
|
|
(define pred-id (let ([pred pred-expr])
|
|
(lambda (v)
|
|
(values (pred v) v))))
|
|
(define-syntax id (make-honu-type ((syntax-local-certifier #t) #'pred-id) stx-car #f #f))))]))
|
|
|
|
(define-syntax (define-type-constructor stx)
|
|
(syntax-case stx ()
|
|
[(_ id generator-expr)
|
|
(identifier? #'id)
|
|
#'(define-syntax id (make-honu-type #f #f #f generator-expr))]))
|
|
|
|
;; ----------------------------------------
|
|
;; Definition forms
|
|
|
|
(define-for-syntax (make-definition-form what this-context this-context?)
|
|
(make-honu-transformer
|
|
(lambda (orig-stx ctx)
|
|
(when (this-context? ctx)
|
|
(raise-syntax-error #f
|
|
(format "redundant in ~a context" (context->name ctx))
|
|
(stx-car orig-stx)))
|
|
(unless (block-context? ctx)
|
|
(raise-syntax-error #f
|
|
(format "illegal in ~a context" (context->name ctx))
|
|
(stx-car orig-stx)))
|
|
(let ([body (stx-cdr orig-stx)])
|
|
(cond
|
|
[(stx-null? body)
|
|
(raise-syntax-error #f
|
|
(format "expected a ~a definition after keyword" what)
|
|
(stx-car orig-stx))]
|
|
[(get-transformer body)
|
|
=> (lambda (transformer)
|
|
(transformer body this-context))]
|
|
[else
|
|
(let ([id (stx-car body)])
|
|
(unless (honu-identifier? id)
|
|
(raise-syntax-error #f
|
|
(format "expected an identifier or type for a ~a definition" what)
|
|
(stx-car orig-stx)
|
|
id))
|
|
((make-honu-type #f (lambda (stx) #'obj) #f #f) orig-stx this-context))])))))
|
|
|
|
(define-syntax var (make-definition-form 'variable the-variable-definition-context variable-definition-context?))
|
|
(define-syntax const (make-definition-form 'variable the-constant-definition-context constant-definition-context?))
|
|
|
|
(define-syntax function
|
|
(make-honu-type #f (lambda (stx) #'obj) #f #f))
|
|
|
|
(define-type-constructor -> make-proc-predicate)
|
|
(define-type-constructor >-> make-poly-predicate)
|
|
|
|
(define-for-syntax (honu-expand-type orig-stx type-stx)
|
|
(let-values ([(type rest-stx)
|
|
(let ([trans (get-transformer type-stx)])
|
|
(if trans
|
|
(trans type-stx the-type-context)
|
|
(values #f #f)))])
|
|
(unless (honu-type? type)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected a type after arrow, found something else"
|
|
orig-stx
|
|
(stx-car type-stx)))
|
|
(unless (stx-null? rest-stx)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected to end with result type, but found more"
|
|
orig-stx
|
|
(stx-car rest-stx)))
|
|
type))
|
|
|
|
|
|
(define-syntax (honu-unparsed-type-predicate stx)
|
|
(syntax-case stx ()
|
|
[(_ orig-stx next-pred res-type-name . type-stx)
|
|
(let ([type (honu-expand-type #'orig-stx #'type-stx)])
|
|
#`(begin
|
|
(define (next-pred v) (#,(honu-type-pred-stx type) v))
|
|
(define res-type-name #,(honu-type-name-stx type))))]))
|
|
|
|
(define-syntax (honu-unparsed-type-name stx)
|
|
(syntax-case stx ()
|
|
[(_ orig-stx . type-stx)
|
|
(let ([type (honu-expand-type #'orig-stx #'type-stx)])
|
|
#`(honu-type-name #,(honu-type-stx type) #,(honu-type-name-stx type)))]))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-syntax (honu-unparsed-function-definition stx)
|
|
(let-values ([(parsed rest)
|
|
((make-definition-form '|generic function| the-function-definition-context (lambda (x) #f))
|
|
stx
|
|
the-block-context)])
|
|
(unless (stx-null? rest)
|
|
(raise-syntax-error #f "error: function definition didn't consume body" rest))
|
|
parsed))
|
|
|
|
(define-syntax (honu-unparsed-prototype stx)
|
|
((make-definition-form '|generic function| the-prototype-context (lambda (x) #f))
|
|
stx
|
|
the-block-context))
|
|
|
|
;; By defining #%angles as a Honu transfomer, we override any potential
|
|
;; treatment as a prefix operator.
|
|
(define-honu-syntax #%angles
|
|
(lambda (stx ctx)
|
|
(unless (or (type-or-expression-context? ctx)
|
|
(expression-context? ctx)
|
|
(block-context? ctx))
|
|
(raise-syntax-error #f
|
|
(format
|
|
"generic allowed only in a block or expression context, not in ~a context"
|
|
(context->name ctx))
|
|
stx))
|
|
(syntax-case (stx-car stx) (#%angles)
|
|
[(#%angles . rest)
|
|
(let-values ([(ids empty-rest)
|
|
;; Parse inside angle brackets:
|
|
(parse-comma-separated
|
|
#'rest
|
|
#f
|
|
(lambda ()
|
|
(raise-syntax-error #f
|
|
"expected at least one identifier"
|
|
(stx-car stx)))
|
|
(lambda (stxes prev-comma-stx term-stx)
|
|
(unless (and (= (length stxes) 1)
|
|
(honu-identifier? (car stxes)))
|
|
;; Either prev-comma-stx is not #f or stxes is not null
|
|
;; (otherwise we'd hit the empty case, covered above)
|
|
(cond
|
|
[prev-comma-stx
|
|
(raise-syntax-error #f
|
|
"expected a single identifier after comma"
|
|
(stx-car stx)
|
|
prev-comma-stx)]
|
|
[(raise-syntax-error #f
|
|
"expected a single identifier before comma or closing bracket"
|
|
(stx-car stx)
|
|
(car stxes))]))
|
|
(car stxes))
|
|
(lambda (id ids)
|
|
(cons id ids)))]
|
|
[(new-id) (car (generate-temporaries '(poly)))])
|
|
;; Everything up to and including curly braces defines the poly function:
|
|
(let-values ([(id defn rest)
|
|
(let loop ([rest (stx-cdr stx)][accum null])
|
|
(syntax-case* rest (#%braces \; \,) delim-identifier=?
|
|
[((#%braces . body) . new-rest)
|
|
(begin
|
|
;; Maybe found the body. Preceeded by params and identifier?
|
|
(unless (and (pair? accum)
|
|
(stx-pair? (car accum))
|
|
(identifier? (stx-car (car accum)))
|
|
(delim-identifier=? #'#%parens (stx-car (car accum))))
|
|
(raise-syntax-error #f
|
|
"expected a function-argument list before generic function body braces"
|
|
(stx-car stx)
|
|
(if (null? accum)
|
|
(stx-car rest)
|
|
(car accum))))
|
|
(unless (and (pair? (cdr accum))
|
|
(honu-identifier? (cadr accum)))
|
|
(raise-syntax-error #f
|
|
"expected an identifier for a function name before generic function argument list"
|
|
(stx-car stx)
|
|
(if (null? (cdr accum))
|
|
(car accum)
|
|
(cadr accum))))
|
|
(values (cadr accum) (reverse (list* (stx-car rest)
|
|
(car accum)
|
|
new-id
|
|
(cddr accum))) #'new-rest))]
|
|
[()
|
|
(raise-syntax-error #f
|
|
"expected a function body in braces eventually after generic specification"
|
|
(stx-car stx))]
|
|
[(\; . _)
|
|
(raise-syntax-error #f
|
|
"expected a function body in braces (eventually), found a semi-colon"
|
|
(stx-car stx)
|
|
(stx-car rest))]
|
|
[(\, . _)
|
|
(raise-syntax-error #f
|
|
"expected a function body in braces (eventually), found a comma"
|
|
(stx-car stx)
|
|
(stx-car rest))]
|
|
[(something . rest)
|
|
;; Assume anything else is ok:
|
|
(loop #'rest (cons #'something accum))]))])
|
|
(unless (block-context? ctx)
|
|
(unless (free-identifier=? id #'function)
|
|
(raise-syntax-error #f
|
|
(format
|
|
"named generic allowed only in a block context, not in ~a context"
|
|
(context->name ctx))
|
|
(stx-car stx)
|
|
id)))
|
|
(with-syntax ([(poly-id ...) ids]
|
|
[(poly-pred-id ...) (generate-temporaries ids)]
|
|
[(poly-name-id ...) (generate-temporaries ids)]
|
|
[def-id (if (free-identifier=? id #'function)
|
|
(or (syntax-local-infer-name id)
|
|
(car (generate-temporaries '(function))))
|
|
id)]
|
|
[new-id new-id]
|
|
[defn defn])
|
|
(with-syntax ([((bound-poly-id ...) (return-type return-protect) (arg-type arg-pred arg-type-name) ...)
|
|
(let ([ex (local-expand #`(let ([poly-pred-id #f] ... [poly-name-id #f] ...)
|
|
(define-syntax poly-id (make-honu-type #'poly-pred-id stx-car #'poly-name-id #f)) ...
|
|
(honu-prototype poly-id ...)
|
|
(honu-unparsed-prototype . defn))
|
|
'expression
|
|
prototype-expand-stop-forms)])
|
|
(syntax-case ex (honu-prototype)
|
|
[(let b0 (l-s+v b1 b2
|
|
(honu-prototype bound-poly-id ...)
|
|
(honu-prototype (return-type return-protect) (arg-type arg-pred arg-type-name) ...)))
|
|
#'((bound-poly-id ...) (return-type return-protect) (arg-type arg-pred arg-type-name) ...)]
|
|
[else (raise-syntax-error
|
|
#f
|
|
"expansion problem: didn't get expected prototype information"
|
|
ex)]))])
|
|
(with-syntax ([(safe-arg ...) (generate-temporaries #'(arg-type ...))])
|
|
(let ([decl
|
|
#'(begin
|
|
(define-syntax def-id
|
|
(make-set!-transformer
|
|
(lambda (stx)
|
|
(syntax-case stx (set!)
|
|
[(set! def-id rhs)
|
|
(raise-syntax-error #f
|
|
"cannot assign to generic procedure name"
|
|
stx
|
|
#'def-id)]
|
|
[(def-id arg (... ...))
|
|
(raise-syntax-error #f
|
|
"cannot apply generic procedure without first applying it to types"
|
|
stx)]
|
|
[def-id
|
|
#'(honu-typed gen-id def-id
|
|
(forall (bound-poly-id ...)
|
|
(-> (return-type return-protect) (arg-type arg-pred arg-type-name) ...)
|
|
(poly-pred-id ... poly-name-id ...))
|
|
#f)]))))
|
|
(define gen-id
|
|
(make-generic
|
|
(lambda (safe? poly-pred-id ... poly-name-id ...)
|
|
(define-syntax poly-id (make-honu-type #'poly-pred-id stx-car #'poly-name-id #f)) ...
|
|
(honu-unparsed-function-definition . defn)
|
|
(if safe?
|
|
(new-id honu-safe-use-hack)
|
|
new-id)))))])
|
|
|
|
(if (free-identifier=? id #'function)
|
|
;; Anonymous function:
|
|
;; We may have to continue parsing...
|
|
(finish-parsing-expression "anonymous generic function"
|
|
id
|
|
#`(let () #,decl def-id) rest ctx)
|
|
(values decl rest))))))))])))
|
|
|
|
(define-syntax (honu-safe-use-hack stx) (raise-syntax-error #f "shouldn't see this" stx))
|
|
(define-syntax (honu-prototype stx) (raise-syntax-error #f "shouldn't see this" stx))
|
|
(define-syntax (honu-type-name stx) (raise-syntax-error #f "shouldn't see this" stx))
|
|
|
|
(define-struct generic (val))
|
|
(define (extract-polymorphic v n)
|
|
(unless (generic? v)
|
|
(raise-type-error '|type application|
|
|
"generic value"
|
|
v))
|
|
(let ([p (generic-val v)])
|
|
(unless (procedure-arity-includes? p n)
|
|
(raise-type-error '|type application|
|
|
(format "generic value (type arity ~a)" n)
|
|
v))
|
|
p))
|
|
|
|
(define-syntax (#%prefix stx) (raise-syntax-error #f "should have been matched by an operator binding" stx))
|
|
(define-syntax (#%postfix stx) (raise-syntax-error #f "should have been matched by an operator binding" stx))
|
|
|
|
;; ----------------------------------------
|
|
;; Pre-defined types
|
|
|
|
(define-type int exact-integer?)
|
|
(define-type bool boolean?)
|
|
(define-type real real?)
|
|
(define-type num number?)
|
|
(define-type obj (lambda (x) #t))
|
|
(define-type string string?)
|
|
|
|
;; ----------------------------------------
|
|
;; Pre-defined forms
|
|
|
|
(define-honu-syntax honu-provide
|
|
(lambda (body ctx)
|
|
(unless (top-block-context? ctx)
|
|
(raise-syntax-error #f "not allowed outside the top level" (stx-car body)))
|
|
(parse-comma-separated
|
|
(stx-cdr body)
|
|
#t
|
|
(lambda () #'(begin))
|
|
(lambda (stxes prev-comma-stx term-stx)
|
|
(syntax-case stxes ()
|
|
[(id)
|
|
(honu-identifier? #'id)
|
|
#`(provide id)]
|
|
[else
|
|
(raise-syntax-error
|
|
#f
|
|
"unknown provide form"
|
|
(stx-car body)
|
|
(car stxes))]))
|
|
(lambda (p decls)
|
|
#`(begin #,p #,decls)))))
|
|
|
|
(define-honu-syntax honu-require
|
|
(lambda (body ctx)
|
|
(define (check-empty rest after-what)
|
|
(unless (stx-null? rest)
|
|
(raise-syntax-error
|
|
#f
|
|
(format "expect a comma or semicolon after ~a" after-what)
|
|
(stx-car body)
|
|
(stx-car rest))))
|
|
(unless (top-block-context? ctx)
|
|
(raise-syntax-error #f "not allowed outside the top level" (stx-car body)))
|
|
(parse-comma-separated
|
|
(stx-cdr body)
|
|
#t
|
|
(lambda () #'(begin))
|
|
(lambda (stxes prev-comma-stx term-stx)
|
|
#`(require
|
|
#,(let ()
|
|
(define (parse-module-name stxes)
|
|
(syntax-case* stxes (lib file #%parens) delim-identifier=?
|
|
[(fn . rest)
|
|
(string? (syntax-e #'fn))
|
|
(begin
|
|
(check-empty #'rest "path string")
|
|
#'fn)]
|
|
[(lib (#%parens names ...) . rest)
|
|
(let ([names (let loop ([names #'(names ...)])
|
|
(syntax-case* names (\,) delim-identifier=?
|
|
[() null]
|
|
[(name . rest)
|
|
(begin
|
|
(unless (string? (syntax-e #'name))
|
|
(raise-syntax-error
|
|
#f
|
|
"expected a string for a library path"
|
|
(car stxes)
|
|
#'name))
|
|
(syntax-case* #'rest (\,) delim-identifier=?
|
|
[() (list #'name)]
|
|
[(\, . rest)
|
|
(cons #'name (loop #'rest))]
|
|
[else
|
|
(raise-syntax-error
|
|
#f
|
|
"expected a comma"
|
|
(stx-car stxes)
|
|
(stx-car #'rest))]))]
|
|
[(\,)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected a string before comma"
|
|
(car stxes)
|
|
(stx-car names))]
|
|
[_else
|
|
(raise-syntax-error
|
|
#f
|
|
"expected a string for a library path"
|
|
(car stxes)
|
|
(stx-car names))]))])
|
|
(when (null? names)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected at least one string for the library path"
|
|
(cadr stxes)))
|
|
(check-empty #'rest "library path")
|
|
(syntax-local-introduce #`(lib #,@names)))]
|
|
[(lib . rest)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected a parenthesized sequence of strings after `lib' keyword"
|
|
(car stxes)
|
|
(stx-car body))]
|
|
[(file (#%parens name) . rest)
|
|
(string? (syntax-e #'name))
|
|
(begin
|
|
(check-empty #'rest "file name")
|
|
(syntax-local-introduce #`(file name)))]
|
|
[(file . rest)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected a parenthesized string after `file' keyword"
|
|
(car stxes)
|
|
(stx-car body))]
|
|
[(fn)
|
|
(honu-identifier? #'fn)
|
|
#'fn]
|
|
[else
|
|
(raise-syntax-error
|
|
#f
|
|
"unknown require form"
|
|
(stx-car body)
|
|
(car stxes))]))
|
|
(define (parse-module-spec stxes)
|
|
(syntax-case* stxes (rename #%parens \,) delim-identifier=?
|
|
[(rename (#%parens spec0 spec ... \, local-id \, remote-id) . rest)
|
|
(begin
|
|
(unless (honu-identifier? #'local-id)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an identifier"
|
|
(stx-car stxes)
|
|
#'local-id))
|
|
(unless (honu-identifier? #'remote-id)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an identifier"
|
|
(stx-car stxes)
|
|
#'remote-id))
|
|
(begin0
|
|
#`(rename #,(parse-module-name
|
|
(syntax->list #'(spec0 spec ...)))
|
|
local-id
|
|
remote-id)
|
|
(check-empty #'rest "rename")))]
|
|
[(rename . rest)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected a parenthesized id, id, and require spec `rename' keyword"
|
|
(car stxes)
|
|
(stx-car body))]
|
|
[_else (parse-module-name stxes)]))
|
|
(parse-module-spec stxes))))
|
|
(lambda (p decls)
|
|
#`(begin #,p #,decls)))))
|
|
|
|
(define-honu-syntax honu-return
|
|
(lambda (stx ctx)
|
|
(unless (block-context-return? ctx)
|
|
(raise-syntax-error #f "allowed only in a tail position" (stx-car stx)))
|
|
(let-values ([(val-stxs after-expr terminator) (extract-until (stx-cdr stx)
|
|
(list #'\;))])
|
|
(unless val-stxs
|
|
(raise-syntax-error
|
|
#f
|
|
"missing semicolon"
|
|
(stx-car stx)))
|
|
(when (null? val-stxs)
|
|
(raise-syntax-error
|
|
#f
|
|
"missing expression"
|
|
(stx-car stx)))
|
|
(with-syntax ([expr (parse-expr val-stxs)])
|
|
(unless (or (expression-block-context? ctx)
|
|
(stx-null? (stx-cdr after-expr)))
|
|
(raise-syntax-error
|
|
#f
|
|
"not at a block end"
|
|
(stx-car stx)))
|
|
(values
|
|
(syntax/loc (stx-car stx)
|
|
(h-return expr))
|
|
(stx-cdr after-expr))))))
|
|
|
|
(define-honu-syntax honu-if
|
|
(lambda (stx ctx)
|
|
(define (get-block-or-statement kw rest)
|
|
(syntax-case rest (#%braces)
|
|
[((#%braces then ...) . rrest)
|
|
(values
|
|
#`(honu-unparsed-block #f obj 'obj #f #,(and (block-context-return? ctx)
|
|
(stx-null? rest))
|
|
. #,(stx-cdr (stx-car rest)))
|
|
#'rrest)]
|
|
[else
|
|
(parse-block-one (if (block-context-return? ctx)
|
|
the-expression-return-block-context
|
|
the-expression-block-context)
|
|
rest
|
|
(lambda (expr rest)
|
|
(values expr rest))
|
|
(lambda ()
|
|
(raise-syntax-error
|
|
#f
|
|
"expected a braced block or a statement"
|
|
kw)))]))
|
|
|
|
(unless (block-context? ctx)
|
|
(raise-syntax-error
|
|
#f
|
|
"allowed only in a block context"
|
|
(stx-car stx)))
|
|
|
|
(syntax-case* stx (#%parens) delim-identifier=?
|
|
[(_ (#%parens test ...) . rest)
|
|
(let* ([tests #'(test ...)])
|
|
(when (stx-null? tests)
|
|
(raise-syntax-error
|
|
#f
|
|
"missing test expression"
|
|
(stx-car stx)
|
|
(stx-car (stx-cdr stx))))
|
|
(let ([test-expr (parse-expr (syntax->list tests))])
|
|
(let-values ([(then-exprs rest) (get-block-or-statement (stx-car stx) #'rest)])
|
|
(syntax-case rest (else)
|
|
[(else . rest2)
|
|
(let-values ([(else-exprs rest) (get-block-or-statement (stx-car rest) #'rest2)])
|
|
(expression-result ctx
|
|
#`(if (as-test #,test-expr) #,then-exprs #,else-exprs)
|
|
rest))]
|
|
[_else
|
|
(expression-result ctx #`(if (as-test #,test-expr) #,then-exprs (void)) rest)]))))]
|
|
[_else
|
|
(raise-syntax-error
|
|
#f
|
|
"expected a parenthesized test after `if' keyword"
|
|
(stx-car stx))])))
|
|
|
|
(define-honu-syntax honu-time
|
|
(lambda (stx ctx)
|
|
(unless (block-context? ctx)
|
|
(raise-syntax-error
|
|
#f
|
|
"allowed only in a block context"
|
|
(stx-car stx)))
|
|
(let-values ([(val-stxs rest terminator) (extract-until (stx-cdr stx) (list #'\;) #f)])
|
|
(unless val-stxs
|
|
(raise-syntax-error
|
|
#f
|
|
"expected a terminating semicolon"
|
|
(stx-car stx)))
|
|
(when (null? val-stxs)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an expression before semicolon"
|
|
(stx-car stx)
|
|
(stx-car rest)))
|
|
(let ([time-expr (parse-expr val-stxs)])
|
|
(expression-result ctx
|
|
#`(time (#%expression #,time-expr))
|
|
(stx-cdr rest))))))
|
|
|
|
;; ----------------------------------------
|
|
;; Class form
|
|
|
|
(define-honu-syntax honu-class
|
|
(lambda (stx ctx)
|
|
(syntax-case stx (#%braces)
|
|
[(form id . rest)
|
|
(not (honu-identifier? #'id))
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an identifier for the class"
|
|
#'form
|
|
#'id)]
|
|
[(form id (#%braces content ...) . rest)
|
|
(let ([id #'id])
|
|
|
|
|
|
10)]
|
|
[(form)
|
|
(raise-syntax-error
|
|
#f
|
|
"missing name for the class"
|
|
#'form)]
|
|
[(form id next . _)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected braces after class name, found something else"
|
|
#'form
|
|
#'next)]
|
|
[(form id)
|
|
(raise-syntax-error
|
|
#f
|
|
"missing braces after class name"
|
|
#'form
|
|
#'id)])))
|
|
|
|
;; ----------------------------------------
|
|
;; Main compiler loop
|
|
|
|
(define (show-top-result v)
|
|
(unless (void? v)
|
|
(printf "~s\n" v)))
|
|
|
|
(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)))])
|
|
#`(begin
|
|
#,code
|
|
(honu-unparsed-begin #,@rest)))]))
|
|
|
|
(define-syntax (#%dynamic-honu-module-begin stx)
|
|
;; (printf "honu raw sexp ~a\n" (syntax->datum stx))
|
|
(let ([result #`(#%plain-module-begin
|
|
(honu-unparsed-begin #,@(stx-cdr stx)))])
|
|
;; (pretty-print (syntax->datum (expand result)))
|
|
result))
|
|
|
|
(define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx))
|
|
|
|
(define true #t)
|
|
(define false #f)
|
|
|
|
(define-syntax define-integer-closed-op
|
|
(syntax-rules ()
|
|
[(_ id scheme-id)
|
|
(define-syntax (id stx)
|
|
(syntax-case stx (#%prefix)
|
|
[(_ #%prefix a) (syntax/loc stx (honu-app (honu-typed scheme-id #f (-> (int #f) (int 'int #f)) #f) a))]
|
|
[(_ a b) (syntax/loc stx (honu-app (honu-typed scheme-id #f (-> (int #f) (int 'int #f) (int 'int #f)) #f) a b))]
|
|
[_ (syntax/loc stx (honu-typed scheme-id #f (-> (int #f) (int 'int #f) (int 'int #f)) #f))]))]))
|
|
|
|
(define-integer-closed-op honu- -)
|
|
(define-integer-closed-op honu+ +)
|
|
(define-integer-closed-op honu* *)
|
|
|
|
(define-syntax (? stx)
|
|
(syntax-case stx (op-app :)
|
|
[(_ t (opp-app : b1 b2))
|
|
(syntax/loc stx (if t b1 b2))]
|
|
[(? . _)
|
|
(raise-syntax-error #f "misuse of operator (not matched with :)" #'?)]))
|
|
|
|
(define-syntax (: stx)
|
|
(raise-syntax-error #f "misuse of operator (not preceded with ?)" stx))
|
|
|
|
(define-syntax (honu-end stx)
|
|
(raise-syntax-error #f "ignore this" stx))
|
|
|
|
(define-syntax (honu-top stx)
|
|
(raise-syntax-error #f "interactive use is not yet supported"))
|