diff --git a/collects/honu/main.ss b/collects/honu/main.ss index 6bd159997b..ff9ac0152f 100644 --- a/collects/honu/main.ss +++ b/collects/honu/main.ss @@ -1,2179 +1,50 @@ #lang scheme/base - (require (for-syntax - syntax/stx - scheme/base - syntax/kerncase - syntax/define - syntax/context - syntax/name - syntax/parse - scheme/pretty - "private/ops.ss" - "private/util.ss" - "private/contexts.ss" - )) - - (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])))) - (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-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 gurantees 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] - [(result-type result-type-name result-protect-id) result-spec] - [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)) - #'(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-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 "cant use this"))) - ... - (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 - (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)) - - (provide int real bool obj - function var const - string - -> >-> - \; - ? : - && \|\| - / - < > <= >= - != - cons list - true false - display write newline - #%datum - #%top - #%parens #%brackets #%braces #%angles - #%prefix #%postfix - define-honu-syntax - - (rename-out (set! =) - (honu-return return) - (honu-if if) - (honu-macro macro) - (honu-time time) - (honu-class class) - (honu+ +) - (honu- -) - (honu* *) - (modulo %) - (equal? ==) - (string->number stringToNumber) - (number->string numberToString) - (car first) - (cdr rest) - (null empty) - (null? isEmpty) - (pair? isCons) - (#%dynamic-honu-module-begin #%module-begin) - (honu-#%app #%app) - (honu-provide provide) - (honu-require require))) - +(require "private/honu.ss" + "private/macro.ss") + +(provide int real bool obj + function var const + string + -> >-> + \; + ? : + && \|\| + / + < > <= >= + != + cons list + true false + display write newline + #%datum + #%top + #%parens #%brackets #%braces #%angles + #%prefix #%postfix + ;; define-honu-syntax + (for-syntax ...) + + (rename-out (set! =) + (honu-return return) + (honu-if if) + (honu-macro macro) + (honu-time time) + (honu-class class) + (honu+ +) + (honu- -) + (honu* *) + (do do) + (honu-end end) + (honu-for2 for2) + (modulo %) + (equal? ==) + (string->number stringToNumber) + (number->string numberToString) + (car first) + (cdr rest) + (null empty) + (null? isEmpty) + (pair? isCons) + (#%dynamic-honu-module-begin #%module-begin) + (honu-#%app #%app) + (honu-provide provide) + (honu-require require))) diff --git a/collects/honu/private/debug.ss b/collects/honu/private/debug.ss new file mode 100644 index 0000000000..49f1314323 --- /dev/null +++ b/collects/honu/private/debug.ss @@ -0,0 +1,14 @@ +#lang scheme/base + +(require (for-syntax scheme/base)) + +(provide debug) + +(define-for-syntax verbose? #f) +(define-syntax (debug stx) + (if verbose? + (syntax-case stx () + [(_ str x ...) + #'(printf str x ...)]) + #'(void))) + diff --git a/collects/honu/private/honu.ss b/collects/honu/private/honu.ss new file mode 100644 index 0000000000..14ae9d5042 --- /dev/null +++ b/collects/honu/private/honu.ss @@ -0,0 +1,2118 @@ +#lang scheme/base + + (require (for-syntax + syntax/stx + scheme/base + syntax/kerncase + syntax/define + syntax/context + syntax/name + syntax/parse + scheme/pretty + "ops.ss" + "util.ss" + "contexts.ss" + )) + + (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])))) + (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-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 gurantees 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] + [(result-type result-type-name result-protect-id) result-spec] + [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)) + #'(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-for2 + (lambda (stx ctx) + (printf "for2: Try to match against pattern ~a. Literals ~a\n" '(name raw-patterns ... . rrest) '(honu-literal ...)) + (printf "for2: stx is ~a\n" (syntax->datum stx)) + ;; (printf "head is ~a\n" (stx-car stx)) + ;; (printf "= is ~a\n" =) + (printf "for2: my matcher ~a\n" + (syntax-case stx (to do set!) + [(for2 q set! v to m do bb ... end) (syntax->datum #'(bb ...))] + [(for2 v ...) 'ok3] + #; + [(for2 v (... ...)) (syntax->datum #'(v (... ...)))] + [else 'bad])) + #'1 + #; + (let ([result (syntax-case stx () + [(for2 raw-patterns ...) + #'(honu-unparsed-block + #f obj 'obj #f ctx + template ...)])]) + (printf "result was ~a\n" result)) + #; + (syntax-case stx (honu-literal ...) + [(name raw-patterns ... . rrest) + (values + #'(honu-unparsed-block + #f obj 'obj #f ctx + template ...) + #'rrest)]))) + + (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)) + + + diff --git a/collects/honu/private/macro.ss b/collects/honu/private/macro.ss new file mode 100644 index 0000000000..2696d874ba --- /dev/null +++ b/collects/honu/private/macro.ss @@ -0,0 +1,121 @@ +#lang scheme/base + +(require "honu.ss" + (for-syntax "debug.ss") + (for-syntax scheme/base)) + +(provide (all-defined-out)) + +(define-for-syntax (extract-conventions pattern) + (let loop ([out '()] + [in pattern]) + (syntax-case in (:) + [(any : attribute rest ...) + ;; todo: export honu attributes for syntax/parse + (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 ...) + (let ([f (if (eq? (syntax->datum #'foo) 'crackers) + #'(... ...) + #'foo)]) + (loop (cons f out) + #'(rest1 rest ...)))] + [(foo) (reverse (cons #'foo out))]))) + +(define-honu-syntax honu-macro + (lambda (stx ctx) + (debug "Original macro: ~a\n" (syntax->datum stx)) + (syntax-case stx (#%parens #%braces) + [(_ (#%parens honu-literal ...) + (#%braces (#%braces name pattern ...)) + (#%braces (#%braces template ...)) + . rest) + (with-syntax ([(conventions ...) + (extract-conventions #'(pattern ...))] + [(raw-patterns ...) + (extract-patterns #'(pattern ...))]) + (values + (syntax/loc + stx + (begin + #| + (define honu-literal (lambda () (error 'honu-literal "cant use this"))) + ... + |# + (define-honu-syntax name + (lambda (stx ctx) + (debug "Try to match against pattern ~a. Literals ~a\n" '(name raw-patterns ... . rrest) '(honu-literal ...)) + (debug "stx is ~a\n" (syntax->datum stx)) + ;; (printf "head is ~a\n" (stx-car stx)) + ;; (printf "= is ~a\n" =) + (debug "my matcher ~a\n" + (syntax-case stx (to set! do honu-end honu-literal ...) + [(name q set! v to m do bb (... ...) honu-end) (syntax->datum #'(bb (... ...)))] + [(name raw-patterns ...) + 'ok2] + [(name pattern ...) 'ok5] + [(name v (... ...) honu-literal ...) 'ok4] + [(name v (... ...)) 'ok3] + #; + [(name v (... ...)) (syntax->datum #'(v (... ...)))] + [else 'bad])) + #; + (debug "case pattern ~a\n" + #'(syntax-case stx + (honu-literal ...) + [(name pattern ...) + #'(honu-unparsed-block + #f obj 'obj #f ctx + template ...)])) + + (let ([result (syntax-case stx + #; + (to set! do honu-end) + (honu-literal ...) + #; + [(name q set! v to m do bb (... ...) honu-end) (syntax->datum #'(bb (... ...)))] + [(name pattern ...) 'ok] + [(name raw-patterns ...) + #'(honu-unparsed-block + #f obj 'obj #f ctx + template ...)] + [else 'fail-boat])]) + (debug "result was ~a\n" result)) + (syntax-case stx (honu-literal ...) + [(name raw-patterns ... . rrest) + (values + #'(honu-unparsed-block + #f obj 'obj #f ctx + template ...) + #'rrest)]))) + #; + (define-honu-syntax name + (lambda (stx ctx) + (define-conventions honu-conventions conventions ...) + #; + (debug "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))]) + ))