From 41f7592c1105bbbef04a64b7e39b1b9197bf712b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 15 Feb 2007 08:14:18 +0000 Subject: [PATCH] gradually typed functional honu svn: r5616 --- collects/honu-module/doc.txt | 164 +- collects/honu-module/dynamic.ss | 1177 ------------ collects/honu-module/honu-module.ss | 2079 +++++++++++++++++++++- collects/honu-module/private/contexts.ss | 39 +- collects/honu-module/private/mzscheme.ss | 3 + collects/honu-module/private/ops.ss | 27 +- collects/honu-module/private/util.ss | 8 +- 7 files changed, 2264 insertions(+), 1233 deletions(-) delete mode 100644 collects/honu-module/dynamic.ss create mode 100644 collects/honu-module/private/mzscheme.ss diff --git a/collects/honu-module/doc.txt b/collects/honu-module/doc.txt index 96a1054526..423a0977e5 100644 --- a/collects/honu-module/doc.txt +++ b/collects/honu-module/doc.txt @@ -2,48 +2,156 @@ >>> FOR NOW, THIS IS AN EXPERIMENTAL TOY <<< > Everything is subject to change. < -Write a dynamically typed Honu program as +Honu is a "gradual-ly typed" language. That is, it's statically typed, +but any expression can have type `obj', and an expresion of type `obj' +is implicitly coreced to any other type by inserting run-time checks +(with delayed checks for higher-order values, as in a contract +system). - #honu dynamic +Every identifier binding has a declared type --- it's `obj' if an +optional is omitted --- and every function has a declared +return type. Types for expressions are inferred in the obvious +way. [TODO: explain "obvious".] - +The syntax is much like Java, but also slightly influenced by +Javascript, since functions are first-class values. Honu support +higher-order parametric polymorphism, for which it uses the Java +"generic" terminology. + +There no no classes/records, yet. That's the next step. + + +Write a Honu program as + + #honu + + ... -The syntax of a definition is much like Java, and type positions in -Java are roughly contract positions in dynamic Honu. +and run it like a `(module ...)' program. -The only supported base "types" right now are +Each as a top-level is implicitly wrapped to print +the result of the (if the result is not void). - int - exact integer - obj - anything - string - character string +The following grammar is a lie, because Honu is extensible in a way +that doesn't fit BNFs. But it's (intended as) an accurate picture of +the initial grammar before any extensions. -and the only "type constructor" is +Types: - (_ -> _) + := obj // anything + | bool + | int // exact integer + | string // character string + | (* -> ) // procedure + | (* >-> ) // generic + | // if bound as generic argument -where "_" is to be replaced with a "type". [Ok, "->" is not very Java -like...] +Definitions: -Every declaration must have a value, like this: + := var [] = ; // defaults to `obj' + | const [] = ; // prohibits assignment + | = ; + | id(,*) { * } + | < ,* > id(,*) { * } - #honu dynamic + := // same as `obj ' + | - int v = 10; +The form is a generic-procedure definition. - int f(int x) { - return x + 1; - } +Expressions: - (int -> int) g() { - return f; - } + := + | + | + | + | () + | { * } + | (type) // cast + | (,*) // procedure call + | [ ] // array access (eventually) + | < ,* > // generic instantiation + | [type] function(,*) { * } // anon function + | < ,* > [type] function(,*) { * } - provide f, g; + := + | + | true | false -The "return" keyword is optional, but allowed only for expressions in -tail position. + := + | - | * | / | % + | == | < | > | >= | <= | = + | && | || + | ? | : // see note below -Assignment: = -Operators: + - * / % -Functions: stringToNumber numberToString + Operators have the same precedence as in Java + + Note: ` ? : ' is currently parsed as + `( ? ( : ))', where `?' looks for + `:' in its second argument. + +Statements: + + := + | // in non-tail positions, only + + := ; + | if () + | if () else + | return // in tail positions, only + | time ; + + := { * } + | + +Imports and exports: + + := + | provide ,* ; + +------------------------------------------------------------------------ + +About Honu Parsing and Typechecking +----------------------------------- + +A Honu program is first parsed by using the MzScheme reader, which +goes into H-expression mode due to the leading #honu. This read phase +tokenizes and groups based on parens, braces, brackets, and (under +certain circumstances) angle brackets. See the MzScheme manual for +details. + +The program is then parsed, expanded (including translation to +Scheme), and type-checked all at once. Thus, the parsing of a term can +depend on the type assigned by the context. + +Parsing proceeds by taking the first thing in the reader's output and +checking whether it has a binding as a Honu transformer. For example +`int' will have a binding to a transformer that expands the next bit +of the stream to a variable or function definition. This transformer +check is performed when the stream starts with an identifier or a +parenthesized group ( ...) includes only one operator +identifier; in the latter case, the operator is used for looking up a +transformer. For example, `(int -> int)' starts a definition because +`->' is bound to a transformer. + +A transformer takes the current stream and a context object; it +returns a Scheme expression and the unconsumed part of the stream. The +Scheme expression is likely to contain unparsed H-expression +representations in a `honu-unparsed-block' form, which is bound to a +Scheme macro in the usual way to continue parsing later. + +A context object can be anything. The base Honu grammar implies +several kinds of contexts, each with its own record type (described +later). A transformer should expand only in contexts that it +recognizes, and it should raise a syntax error when given any context +that it doesn't recognize. A transformer might expand differently in +different contexts. For example, `int' expands to a definition in a +block context (e.g., at the top level), but to a type description in a +type context (e.g., in a procedure's formal argument list). + +When the start of the stream offers no other guidance, it is parsed as +an expression. The expression-parsing rules are essentially hardwired +to the Java grammar rules. (In the future, programmers will likely +have control over precedence, at least.) + +[to be continued] diff --git a/collects/honu-module/dynamic.ss b/collects/honu-module/dynamic.ss deleted file mode 100644 index 43742694fc..0000000000 --- a/collects/honu-module/dynamic.ss +++ /dev/null @@ -1,1177 +0,0 @@ -(module dynamic mzscheme - - (require-for-syntax (lib "stx.ss" "syntax") - "private/ops.ss" - "private/util.ss" - (lib "kerncase.ss" "syntax") - "private/contexts.ss") - - (begin-for-syntax - - (define kernel-forms (kernel-form-identifier-list #'here)) - (define expand-stop-forms (list* #'honu-typed - #'honu-unparsed-block - kernel-forms)) - - ;; -------------------------------------------------------- - ;; 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 3 0 #f null (current-inspector) 0)) - - (define (honu-type-stx v) (honu-type-ref v 0)) - (define (honu-type-pred-def-stx v) (honu-type-ref v 1)) - (define (honu-type-pred-stx v) (honu-type-ref v 2)) - - ;; -------------------------------------------------------- - ;; Parsing blocks - - (define operator? - (let ([sym-chars (string->list "+-_=?:<>.!%^&*/~|")]) - (lambda (stx) - (and (identifier? stx) - (let ([str (symbol->string (syntax-e stx))]) - (and (positive? (string-length str)) - (memq (string-ref str 0) sym-chars))))))) - - (define (honu-identifier? stx) - (and (identifier? stx) - (not (ormap (lambda (i) (module-identifier=? stx i)) (list #'\; #'\,))) - (not (operator? stx)))) - - (define (get-transformer stx) - (or (and (stx-pair? stx) - (identifier? (stx-car stx)) - (let ([v (syntax-local-value (stx-car stx) (lambda () #f))]) - (and (honu-transformer? v) v))) - (and (stx-pair? stx) - (let ([first (stx-car stx)]) - (and (stx-pair? first) - (identifier? (stx-car first)) - (module-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))])))))))) - - ;; -------------------------------------------------------- - ;; 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)))] - [(syntax-case body (#%braces) - [((#%braces . block) . rest) (cons #'block #'rest)] - [_else #f]) - => (lambda (b+r) - (k #`(honu-unparsed-block #f obj #f #,(and (stx-null? (cdr b+r)) - (return-block-context? ctx)) - #,@(car b+r)) - (cdr b+r)))] - [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 (return-block-context? ctx) - parse-a-tail-expr - parse-an-expr) - expr-stxs)]) - (k ((if (top-block-context? ctx) - (lambda (x) - `(let ([v ,x]) - (unless (void? v) - (printf "~s\n" v)))) - 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)))) - - ;; -------------------------------------------------------- - ;; 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) - [(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" - #'v) - (list #'v))] - [((#%parens . pexpr)) - (if (stx-null? #'pexpr) - (raise-syntax-error - #f - "missing expression inside parentheses" - (stx-car stx)) - (list (parse-expr #'pexpr)))] - [((#%braces . pexpr)) - (if (stx-null? #'pexpr) - (raise-syntax-error - #f - "missing expression inside braces" - (stx-car stx)) - (list #'(honu-unparsed-block #f obj #f #f . pexpr)))] - [(op . more) - (and (identifier? #'op) - (ormap (lambda (uop) - (module-identifier=? #'op uop)) - 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)) - (or (module-identifier=? #'#%brackets (stx-car (stx-car stx))) - (module-identifier=? #'#%parens (stx-car (stx-car stx))))) - (and (identifier? (stx-car stx)) - (hash-table-get 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 - (cond - [(stx-pair? (stx-car stx)) - ;; Convert vector index or application to a binary operator: - (let ([opl (if (module-identifier=? #'#%brackets (stx-car (stx-car stx))) - (let ([index-expr (parse-expr (stx-cdr (stx-car stx)))]) - (list (make-infix (stx-car (stx-car stx))) - index-expr)) - (let ([arg-exprs (parse-arg-list (stx-cdr (stx-car stx)))]) - (list (make-infix (stx-car (stx-car stx))) - arg-exprs)))]) - (if (stx-null? (stx-cdr stx)) - opl - (append opl (start-operator (stx-cdr stx)))))] - [(or (module-identifier=? #'++ (stx-car stx)) - (module-identifier=? #'-- (stx-car stx))) - (if (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 - [(prefix? op) - (group (append (reverse (cdr before)) - (list (quasisyntax/loc (op-id op) - (honu-app #,(op-id op) #,(car before)))) - (reverse since)))] - [(postfix? op) - (let ([after (reverse since)]) - (group (append (reverse before) - (list (quasisyntax/loc (op-id op) - (honu-app #,(op-id op) #,(car after)))) - (cdr after))))] - [(infix? op) - (let ([after (reverse since)]) - (group (append (reverse (cdr before)) - (list (quasisyntax/loc (op-id op) - (honu-app #,(op-id op) #,(car before) #,(car after)))) - (cdr after))))] - [else (error "not an op!: " op)])] - [(not (op? (stx-car seq))) - (loop (cdr seq) before op (cons (car seq) since))] - [(> (hash-table-get precedence-table (prec-key (car seq)) (lambda () 0)) - (hash-table-get 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 #%parens) - [(honu-return expr ...) - (let ([exprs #'(expr ...)]) - (when (stx-null? exprs) - (raise-syntax-error - #f - "missing expression" - (stx-car expr-stxs))) - (parse-expr exprs))] - [((#%parens expr0 expr ...)) - (let ([exprs #'(expr0 expr ...)]) - (parse-tail-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-pred-def-stx type) - (honu-type-pred-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 (\,) - [(id \, . rest) - (honu-identifier? #'id) - #t] - [(id) - (honu-identifier? #'id) - #t] - [_else #f]) - (values (make-h-type #'obj #'(begin) #'(lambda (x) (values #t x))) - 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) - (module-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 (make-honu-type pred-id mk-pred-def) - (make-honu-trans - (lambda (orig-stx ctx) - (let* ([pred-id (or pred-id - (car (generate-temporaries '(type-pred))))] - [pred-def (if mk-pred-def - (mk-pred-def pred-id orig-stx) - #'(begin))]) - (cond - [(or (block-context? ctx) - (definition-context? ctx)) - (with-syntax ([pred-id pred-id] - [type-name (stx-car orig-stx)]) - (let loop ([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 (identifier? (stx-car #'rest)) - (module-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 pred-id - (check-expr-type #f 'id type-name pred-id - (honu-unparsed-expr #,@val-stxs)))]) - (if (module-identifier=? #'\; (stx-car after-expr)) - (values #`(begin #,pred-def #,def) (stx-cdr after-expr)) - (let-values ([(defs remainder kind) (loop (stx-cdr after-expr) (stx-car after-expr) "comma" #f)]) - (values #`(begin #,pred-def #,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 \;) - [((#%parens . prest) (#%braces . body) . rest) - (let ([args (parse-arguments #'prest #'id)]) - (with-syntax ([((arg arg-type arg-pred-def arg-pred-id) ...) args] - [(temp-id ...) (generate-temporaries (map car args))]) - (values #`(begin - #,pred-def - arg-pred-def ... - (define-typed-procedure id - type-name - ((arg arg-type arg-pred-id) ...) - (lambda (temp-id ...) - (define-typed arg #f id arg-type arg-pred-id temp-id) ... - (honu-unparsed-block id type-name pred-id #t . body)))) - #'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)"] - [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)])))] - [(type-context? ctx) - (values (make-h-type (stx-car orig-stx) pred-def pred-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 name form) - ;; Form start with a operator-transformer sequence - (let-values ([(args-stx -> result-stx) - (let loop ([stx (stx-cdr (stx-car form))][args null]) - (if (and (identifier? (stx-car stx)) - (module-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-type-error - #f - "missing type for result" - ->)) - (let ([arg-types - (let loop ([args-stx args-stx]) - (if (stx-null? args-stx) - null - (let ([trans (get-transformer args-stx)]) - (unless trans - (raise-type-error '-> - "non-type within a procedure-type construction" - (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-type-error '-> - "non-type in result position for procedure-type construction" - (stx-car result-stx))) - (let-values ([(type rest-stx) (trans result-stx the-type-context)]) - (unless (stx-null? rest-stx) - (raise-type-error '-> - "extra tokens following result for procedure-type construction" - (stx-car rest-stx))) - type))]) - (with-syntax ([(arg ...) (generate-temporaries arg-types)] - [(arg-type ...) (map honu-type-stx arg-types)] - [(arg-pred-def ...) (map honu-type-pred-def-stx arg-types)] - [(arg-pred-id ...) (map honu-type-pred-stx arg-types)] - [result-type (honu-type-stx result-type)] - [result-pred-def (honu-type-pred-def-stx result-type)] - [result-pred-id (honu-type-pred-stx result-type)] - [n (length arg-types)]) - #`(begin - arg-pred-def ... - result-pred-def - (define (#,name v) - (if (and (procedure? v) - (procedure-arity-includes? v n)) - (values #t (lambda (arg ...) - (check-expr-type - #f #t result-type result-pred-id - (v (check-expr-type #f #f arg-type arg-pred-id arg) ...)))) - (values #f #f)))))))) - - (define (check-compatible-type val-expr val-type target-type fail-k) - (and (identifier? target-type) - (or (module-identifier=? #'obj target-type) - (and (identifier? val-type) - (module-identifier=? val-type target-type)) - (let ([val-type - (if (not val-type) - (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-type] - [(boolean? (syntax-e val-expr)) #'bool] - [(identifier? val-expr) - (cond - [(module-identifier=? #'false val-expr) #'bool] - [(module-identifier=? #'true val-expr) #'bool] - [else #'obj])] - [else #'obj]) - val-type)]) - (or (module-identifier=? val-type target-type) - (and (module-identifier=? #'num target-type) - (or (module-identifier=? val-type #'int) - (module-identifier=? val-type #'real))) - (and (module-identifier=? #'real target-type) - (or (module-identifier=? val-type #'int))) - (if (module-identifier=? val-type #'obj) - #f - (fail-k val-expr val-type target-type))))))) - - (define (type-mismatch val-expr val-type target-type) - (raise-syntax-error - '|type mismatch| - (format "actual type ~a does not match expected type ~a" - (syntax-object->datum val-type) - (syntax-object->datum target-type)) - val-expr))) - - (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 (check-expr-type stx) - (syntax-case stx () - [(_ proc who type-name pred val) - ;; Avoid the check if the static types are consistent - (let ([v (local-expand - #'val - 'expression - expand-stop-forms)]) - (syntax-case v (honu-typed if let-values) - [(honu-typed val val-type) - (check-compatible-type #'val #'val-type #'type-name type-mismatch) - ;; No run-time check: - #'val] - [(if t then else) - ;; propagate check to body: - #'(if t - (check-expr-type proc who type-name pred then) - (check-expr-type proc who type-name pred else))] - [(let-values bindings body) - #'(let-values bindings - (check-expr-type proc who type-name pred body))] - [(honu-unparsed-block #f _ #f return-context? . body) - #'(honu-unparsed-block who type-name pred return-context? . body)] - [_else - ;; Even without a type for v, we might see a literal, - ;; or maybe the declaration is simply val - (if (check-compatible-type v #f #'type-name type-mismatch) - ;; No run-time check: - v - ;; Run-time check: - (with-syntax ([val v]) - #'(check proc who 'type-name pred val)))]))])) - - (define-syntax honu-app - (syntax-rules () - [(_ a b ...) (a b ...)])) - - (define-syntax (define-typed stx) - (syntax-case stx () - [(_ id const? proc-name type-name pred-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) - #'(set! gen-id (check-expr-type 'set! id type-name pred-id rhs)))] - [(id arg (... ...)) - #'(honu-app (honu-typed gen-id type-name) arg (... ...))] - [id - #'(honu-typed gen-id type-name)]))))))])) - - (define-for-syntax (make-typed-procedure gen-id result-spec arg-spec) - (with-syntax ([((arg arg-type pred-id) ...) arg-spec] - [result-spec result-spec] - [gen-id gen-id]) - (make-set!-transformer - (lambda (stx) - (syntax-case stx (set!) - [(set! id rhs) - (raise-syntax-error #f - "cannot assign to procedure name" - stx - #'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 (honu-typed gen-id type-name) - (check-expr-type 'id 'arg arg-type pred-id actual-arg) - ...) - result-spec))] - [id - #'(honu-need-type gen-id - (let ([id (lambda (arg ...) - (id arg ...))]) - id) - type-name)]))))) - - (provide honu-typed check-expr-type) ; <-------- FIXME. These shouldn't be exported. - - (define-syntax (define-typed-procedure stx) - (syntax-case stx () - [(_ id result-spec arg-spec val) - (with-syntax ([gen-id (car (generate-temporaries (list #'id)))]) - #'(begin - (define gen-id val) - (define-syntax id - (make-typed-procedure (quote-syntax gen-id) (quote-syntax result-spec) (quote-syntax arg-spec)))))])) - - (define-syntax honu-typed - (syntax-rules () - [(_ expr type) expr])) - - (require-for-syntax (lib "context.ss" "syntax")) - (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-pred-id (stx-car (stx-cdr (stx-cdr (stx-cdr stx))))] - [exprs (let loop ([exprs (cddddr (syntax->list stx))]) - (apply - append - (map (lambda (expr) - (let ([expr (local-expand - expr - (generate-expand-context) - expand-stop-forms)]) - (syntax-case expr (begin) - [(begin . rest) - (loop (syntax->list #'rest))] - [else - (list expr)]))) - exprs)))]) - #`(let () - #,@(let loop ([exprs exprs][prev-defns null][prev-exprs null]) - (cond - [(null? exprs) (append - (reverse prev-defns) - (if (and (pair? prev-exprs) - proc-id - (syntax-e proc-id)) - (reverse (cons - #`(check-expr-type '#,proc-id #t - #,result-type-name - #,result-pred-id - #,(car prev-exprs)) - (cdr prev-exprs))) - (begin - (unless (or (not proc-id) - (not (syntax-e proc-id)) - (module-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)) - (or (module-identifier=? #'define-values (stx-car (car exprs))) - (module-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-pred-id return-context? . body) - #`(honu-block proc-id result-type-name 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 ...) (parse-expr (syntax->list #'(v ...)))])) - - (define-syntax (h-return stx) - (syntax-case stx () - [(_ expr) #'expr])) - - (define-syntax (#%parens stx) - (syntax-case stx () - [(_ rator (rand ...)) (syntax/loc #'rator (honu-app rator rand ...))])) - - ;; -------------------------------------------------------- - ;; Defining a new transformer or new type - - (require-for-syntax (lib "define.ss" "syntax")) - (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 #'pred-id #f))))])) - - (define-syntax (define-type-constructor stx) - (syntax-case stx () - [(_ id generator-expr) - (identifier? #'id) - #'(define-syntax id (make-honu-type #f generator-expr))])) - - ;; ---------------------------------------- - ;; Pre-defined types and forms - - (define (exact-integer? v) - (and (integer? v) (exact? v))) - - (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-type string?) - - (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 orig-stx)]) - (unless (honu-identifier? id) - (raise-syntax-error #f - (format "expected an identifier for a ~a definition" what) - (stx-car orig-stx) - id)) - ((make-honu-type #'(lambda (x) (values #t x)) #f) orig-stx this-context))]))))) - - (define-syntax function (make-definition-form 'function the-function-definition-context function-definition-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-type-constructor -> make-proc-predicate) - - (define-for-syntax parse-comma-separated - (lambda (body empty-case parse-one combine) - (syntax-case body (\;) - [(\;) (empty-case)] - [_else - (let loop ([body body][accum null][prev-comma #f]) - (syntax-case 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) - (values (parse-one (reverse accum) prev-comma (stx-car body)) #'rest)] - [(x . rest) - (loop #'rest (cons #'x accum) #f)]))]))) - - (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) - (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) - (lambda () #'(begin)) - (lambda (stxes prev-comma-stx term-stx) - #`(require - #,(let () - (define (parse-module-name stxes) - (syntax-case stxes (lib file #%parens) - [(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 (\,) - [() 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 (\,) - [() (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 \,) - [(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 (return-block-context? 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 (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)) - null))))) - - (define-honu-syntax honu-if - (lambda (stx ctx) - (define (get-block-or-statement kw rest) - (syntax-case rest (#%braces) - [((#%braces then ...) . rrest) - (values (stx-cdr (stx-car rest)) #'rrest)] - [else - (let-values ([(val-stxs rest terminator) (extract-until rest (list #'\;) #t)]) - (unless val-stxs - (raise-syntax-error - #f - "expected a braced block or a terminating semicolon" - kw)) - (when (null? val-stxs) - (raise-syntax-error - #f - "expected an expression before semicolon" - kw - (stx-car rest))) - (values val-stxs (stx-cdr rest)))])) - - (define (wrap-block exprs rest) - #`(honu-unparsed-block #f obj #f #,(and (return-block-context? ctx) - (stx-null? rest)) - . #,exprs)) - - (syntax-case stx (#%parens) - [(_ (#%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)]) - (values #`(if #,test-expr - #,(wrap-block then-exprs rest) - #,(wrap-block else-exprs rest)) - rest))] - [_else - (values #`(if #,test-expr #,(wrap-block then-exprs rest) (void)) rest)]))))] - [_else - (raise-syntax-error - #f - "expected a parenthesized test after `if' keyword" - (stx-car stx))]))) - - ;; ---------------------------------------- - ;; 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-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) - #`(#%plain-module-begin - (honu-unparsed-begin #,@(stx-cdr stx)))) - - (define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx)) - - (define true #t) - (define false #f) - - (provide int real bool obj - function var const - (rename string-type string) -> - \; - (rename set! =) - (rename honu-return return) - (rename honu-if if) - (rename honu-class class) - + - * / (rename modulo %) - (rename string->number stringToNumber) - (rename number->string numberToString) - cons list - (rename car first) - (rename cdr rest) - (rename null empty) - (rename null? isEmpty) - (rename pair? isCons) - true false - display write newline - #%datum - #%top - #%parens - (rename #%dynamic-honu-module-begin #%module-begin) - define-honu-syntax - (rename honu-provide provide) - (rename honu-require require))) diff --git a/collects/honu-module/honu-module.ss b/collects/honu-module/honu-module.ss index 7093cfaa55..f4fb30a0fa 100644 --- a/collects/honu-module/honu-module.ss +++ b/collects/honu-module/honu-module.ss @@ -1,11 +1,2074 @@ -(module honu-module mzscheme - (define-syntax m +(module honu-module "private/mzscheme.ss" + + (require-for-syntax (lib "stx.ss" "syntax") + "private/ops.ss" + "private/util.ss" + (lib "kerncase.ss" "syntax") + (lib "name.ss" "syntax") + "private/contexts.ss") + + (begin-for-syntax + + (define kernel-forms (kernel-form-identifier-list #'here)) + (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)) + + (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-object->datum t))]))) + + ;; -------------------------------------------------------- + ;; Parsing blocks + + (define operator? + (let ([sym-chars (string->list "+-_=?:<>.!%^&*/~|")]) + (lambda (stx) + (and (identifier? stx) + (let ([str (symbol->string (syntax-e stx))]) + (and (positive? (string-length str)) + (memq (string-ref str 0) sym-chars))))))) + + (define (honu-identifier? stx) + (and (identifier? stx) + (not (ormap (lambda (i) (delim-identifier=? stx i)) (list #'\; #'\,))) + (not (operator? stx)))) + + (define (get-transformer stx) + (or (and (stx-pair? stx) + (identifier? (stx-car stx)) + (let ([v (syntax-local-value (stx-car stx) (lambda () #f))]) + (and (honu-transformer? v) v))) + (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)) + (module-identifier=? #'#%angles (stx-car first))) + (let ([v (syntax-local-value (stx-car first) (lambda () #f))]) + (and (honu-transformer? v) v))] + [else #f]))))) + + ;; -------------------------------------------------------- + ;; 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-object #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-object 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-table-get 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-table-get precedence-table (prec-key (car seq)) (lambda () 0)) + (hash-table-get 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 (module-identifier=? #'id #'function))) + (not (function-definition-context? ctx)) + (not (prototype-context? ctx)) + (identifier? (stx-car #'rest)) + (module-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)) + (module-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)) + (module-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)) + (module-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)) + (module-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 (module-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 + [(module-identifier=? #'false val-expr) #'bool] + [(module-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 (module-identifier=? #'obj target-type) + (and (identifier? val-type) + (module-identifier=? val-type target-type)) + (let ([val-type + (if (not val-type) + (apparent-type val-expr) + val-type)]) + (or (and (identifier? val-type) + (or (module-identifier=? val-type target-type) + (and (module-identifier=? #'num target-type) + (or (module-identifier=? val-type #'int) + (module-identifier=? val-type #'real))) + (and (module-identifier=? #'real target-type) + (or (module-identifier=? val-type #'int))))) + (if (and (identifier? val-type) + (module-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 (module-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) + (module-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 () - [(_ require provide) - (begin - (require "dynamic.ss") - (provide (all-from "dynamic.ss")))])) - (m require provide)) - + [(_ 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) + (module-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 (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: + #'(honu-typed (pack-a-expr (check-expr-type #f #f arg-type arg-type-name arg-pred b) ...) + 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. + #'(#%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-object #'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) + #'(set! gen-id (check-expr-type 'set! id type-name type-name-expr pred-id rhs)))] + [(id arg (... ...)) + #'(honu-app (honu-typed gen-id id type-name protect-id) arg (... ...))] + [id + #'(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 (lib "context.ss" "syntax")) + (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)]) + (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))))]) + #`(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)) + (module-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 (module-identifier=? #'define-values (stx-car (car exprs))) + (module-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) #'(or a b)])) + + ;; -------------------------------------------------------- + ;; Defining a new transformer or new type + + (require-for-syntax (lib "define.ss" "syntax")) + (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 (module-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 (module-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 (module-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 (exact-integer? v) + (and (integer? v) (exact? v))) + + (define-type int exact-integer?) + (define-type bool boolean?) + (define-type real real?) + (define-type num number?) + (define-type obj (lambda (x) #t)) + (define-type string string?) + + ;; ---------------------------------------- + ;; Pre-defined forms + + (define-honu-syntax honu-provide + (lambda (body ctx) + (unless (top-block-context? ctx) + (raise-syntax-error #f "not allowed outside the top level" (stx-car body))) + (parse-comma-separated + (stx-cdr body) + #t + (lambda () #'(begin)) + (lambda (stxes prev-comma-stx term-stx) + (syntax-case stxes () + [(id) + (honu-identifier? #'id) + #`(provide id)] + [else + (raise-syntax-error + #f + "unknown provide form" + (stx-car body) + (car stxes))])) + (lambda (p decls) + #`(begin #,p #,decls))))) + + (define-honu-syntax honu-require + (lambda (body ctx) + (define (check-empty rest after-what) + (unless (stx-null? rest) + (raise-syntax-error + #f + (format "expect a comma or semicolon after ~a" after-what) + (stx-car body) + (stx-car rest)))) + (unless (top-block-context? ctx) + (raise-syntax-error #f "not allowed outside the top level" (stx-car body))) + (parse-comma-separated + (stx-cdr body) + #t + (lambda () #'(begin)) + (lambda (stxes prev-comma-stx term-stx) + #`(require + #,(let () + (define (parse-module-name stxes) + (syntax-case* stxes (lib file #%parens) delim-identifier=? + [(fn . rest) + (string? (syntax-e #'fn)) + (begin + (check-empty #'rest "path string") + #'fn)] + [(lib (#%parens names ...) . rest) + (let ([names (let loop ([names #'(names ...)]) + (syntax-case* names (\,) delim-identifier=? + [() null] + [(name . rest) + (begin + (unless (string? (syntax-e #'name)) + (raise-syntax-error + #f + "expected a string for a library path" + (car stxes) + #'name)) + (syntax-case* #'rest (\,) delim-identifier=? + [() (list #'name)] + [(\, . rest) + (cons #'name (loop #'rest))] + [else + (raise-syntax-error + #f + "expected a comma" + (stx-car stxes) + (stx-car #'rest))]))] + [(\,) + (raise-syntax-error + #f + "expected a string before comma" + (car stxes) + (stx-car names))] + [_else + (raise-syntax-error + #f + "expected a string for a library path" + (car stxes) + (stx-car names))]))]) + (when (null? names) + (raise-syntax-error + #f + "expected at least one string for the library path" + (cadr stxes))) + (check-empty #'rest "library path") + (syntax-local-introduce #`(lib #,@names)))] + [(lib . rest) + (raise-syntax-error + #f + "expected a parenthesized sequence of strings after `lib' keyword" + (car stxes) + (stx-car body))] + [(file (#%parens name) . rest) + (string? (syntax-e #'name)) + (begin + (check-empty #'rest "file name") + (syntax-local-introduce #`(file name)))] + [(file . rest) + (raise-syntax-error + #f + "expected a parenthesized string after `file' keyword" + (car stxes) + (stx-car body))] + [(fn) + (honu-identifier? #'fn) + #'fn] + [else + (raise-syntax-error + #f + "unknown require form" + (stx-car body) + (car stxes))])) + (define (parse-module-spec stxes) + (syntax-case* stxes (rename #%parens \,) delim-identifier=? + [(rename (#%parens spec0 spec ... \, local-id \, remote-id) . rest) + (begin + (unless (honu-identifier? #'local-id) + (raise-syntax-error + #f + "expected an identifier" + (stx-car stxes) + #'local-id)) + (unless (honu-identifier? #'remote-id) + (raise-syntax-error + #f + "expected an identifier" + (stx-car stxes) + #'remote-id)) + (begin0 + #`(rename #,(parse-module-name + (syntax->list #'(spec0 spec ...))) + local-id + remote-id) + (check-empty #'rest "rename")))] + [(rename . rest) + (raise-syntax-error + #f + "expected a parenthesized id, id, and require spec `rename' keyword" + (car stxes) + (stx-car body))] + [_else (parse-module-name stxes)])) + (parse-module-spec stxes)))) + (lambda (p decls) + #`(begin #,p #,decls))))) + + (define-honu-syntax honu-return + (lambda (stx ctx) + (unless (block-context-return? ctx) + (raise-syntax-error #f "allowed only in a tail position" (stx-car stx))) + (let-values ([(val-stxs after-expr terminator) (extract-until (stx-cdr stx) + (list #'\;))]) + (unless val-stxs + (raise-syntax-error + #f + "missing semicolon" + (stx-car stx))) + (when (null? val-stxs) + (raise-syntax-error + #f + "missing expression" + (stx-car stx))) + (with-syntax ([expr (parse-expr val-stxs)]) + (unless (or (expression-block-context? ctx) + (stx-null? (stx-cdr after-expr))) + (raise-syntax-error + #f + "not at a block end" + (stx-car stx))) + (values + (syntax/loc (stx-car stx) + (h-return expr)) + (stx-cdr after-expr)))))) + + (define-honu-syntax honu-if + (lambda (stx ctx) + (define (get-block-or-statement kw rest) + (syntax-case rest (#%braces) + [((#%braces then ...) . rrest) + (values + #`(honu-unparsed-block #f obj 'obj #f #,(and (block-context-return? ctx) + (stx-null? rest)) + . #,(stx-cdr (stx-car rest))) + #'rrest)] + [else + (parse-block-one (if (block-context-return? ctx) + the-expression-return-block-context + the-expression-block-context) + rest + (lambda (expr rest) + (values expr rest)) + (lambda () + (raise-syntax-error + #f + "expected a braced block or a statement" + kw)))])) + + (unless (block-context? ctx) + (raise-syntax-error + #f + "allowed only in a block context" + (stx-car stx))) + + (syntax-case* stx (#%parens) delim-identifier=? + [(_ (#%parens test ...) . rest) + (let* ([tests #'(test ...)]) + (when (stx-null? tests) + (raise-syntax-error + #f + "missing test expression" + (stx-car stx) + (stx-car (stx-cdr stx)))) + (let ([test-expr (parse-expr (syntax->list tests))]) + (let-values ([(then-exprs rest) (get-block-or-statement (stx-car stx) #'rest)]) + (syntax-case rest (else) + [(else . rest2) + (let-values ([(else-exprs rest) (get-block-or-statement (stx-car rest) #'rest2)]) + (expression-result ctx + #`(if (as-test #,test-expr) #,then-exprs #,else-exprs) + rest))] + [_else + (expression-result ctx #`(if (as-test #,test-expr) #,then-exprs (void)) rest)]))))] + [_else + (raise-syntax-error + #f + "expected a parenthesized test after `if' keyword" + (stx-car stx))]))) + + (define-honu-syntax honu-time + (lambda (stx ctx) + (unless (block-context? ctx) + (raise-syntax-error + #f + "allowed only in a block context" + (stx-car stx))) + (let-values ([(val-stxs rest terminator) (extract-until (stx-cdr stx) (list #'\;) #f)]) + (unless val-stxs + (raise-syntax-error + #f + "expected a terminating semicolon" + (stx-car stx))) + (when (null? val-stxs) + (raise-syntax-error + #f + "expected an expression before semicolon" + (stx-car stx) + (stx-car rest))) + (let ([time-expr (parse-expr val-stxs)]) + (expression-result ctx + #`(time (#%expression #,time-expr)) + (stx-cdr rest)))))) + + ;; ---------------------------------------- + ;; Class form + + (define-honu-syntax honu-class + (lambda (stx ctx) + (syntax-case stx (#%braces) + [(form id . rest) + (not (honu-identifier? #'id)) + (raise-syntax-error + #f + "expected an identifier for the class" + #'form + #'id)] + [(form id (#%braces content ...) . rest) + (let ([id #'id]) + + + 10)] + [(form) + (raise-syntax-error + #f + "missing name for the class" + #'form)] + [(form id next . _) + (raise-syntax-error + #f + "expected braces after class name, found something else" + #'form + #'next)] + [(form id) + (raise-syntax-error + #f + "missing braces after class name" + #'form + #'id)]))) + + ;; ---------------------------------------- + ;; Main compiler loop + + (define (show-top-result v) + (unless (void? v) + (printf "~s\n" v))) + + (define-syntax (honu-unparsed-begin stx) + (syntax-case stx () + [(_) #'(begin)] + [(_ . body) (let-values ([(code rest) (parse-block-one the-top-block-context + #'body + values + (lambda () + (values #'(void) null)))]) + #`(begin + #,code + (honu-unparsed-begin #,@rest)))])) + + (define-syntax (#%dynamic-honu-module-begin stx) + #`(#%plain-module-begin + (honu-unparsed-begin #,@(stx-cdr stx)))) + + (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 + -> >-> + \; + (rename set! =) + (rename honu-return return) + (rename honu-if if) ? : + (rename honu-time time) + (rename honu-class class) + (rename honu+ +) (rename honu- -) (rename honu* *) + / (rename modulo %) + < > <= >= (rename equal? ==) + && \|\| + (rename string->number stringToNumber) + (rename number->string numberToString) + cons list + (rename car first) + (rename cdr rest) + (rename null empty) + (rename null? isEmpty) + (rename pair? isCons) + true false + display write newline + #%datum + #%top + #%parens #%brackets #%braces #%angles + #%prefix #%postfix + (rename #%dynamic-honu-module-begin #%module-begin) + (rename honu-#%app #%app) + define-honu-syntax + (rename honu-provide provide) + (rename honu-require require))) diff --git a/collects/honu-module/private/contexts.ss b/collects/honu-module/private/contexts.ss index 884aa3ba88..a77e19125d 100644 --- a/collects/honu-module/private/contexts.ss +++ b/collects/honu-module/private/contexts.ss @@ -1,9 +1,9 @@ (module contexts mzscheme - (define-struct block-context ()) + (define-struct block-context (return?)) (define-struct (top-block-context block-context) ()) - (define-struct (return-block-context block-context) ()) - + (define-struct (expression-block-context block-context) ()) + (define-struct definition-context ()) (define-struct (function-definition-context definition-context) ()) (define-struct (value-definition-context definition-context) ()) @@ -12,30 +12,40 @@ (define-struct expression-context ()) (define-struct type-context ()) + (define-struct type-or-expression-context ()) + (define-struct prototype-context ()) - (define the-block-context (make-block-context)) - (define the-top-block-context (make-top-block-context)) - (define the-return-block-context (make-return-block-context)) + (define the-block-context (make-block-context #f)) + (define the-top-block-context (make-top-block-context #f)) + (define the-expression-block-context (make-expression-block-context #f)) + (define the-return-block-context (make-block-context #t)) + (define the-expression-return-block-context (make-expression-block-context #t)) - (define the-function-definition-context (make-function-definition-context)) (define the-variable-definition-context (make-variable-definition-context)) (define the-constant-definition-context (make-constant-definition-context)) + (define the-function-definition-context (make-function-definition-context)) (define the-expression-context (make-expression-context)) (define the-type-context (make-type-context)) + (define the-type-or-expression-context (make-type-or-expression-context)) + (define the-prototype-context (make-prototype-context)) (define (context->name ctx) (cond [(type-context? ctx) "a type"] + [(type-or-expression-context? ctx) "a type or expression"] + [(expression-context? ctx) "an expression"] + [(expression-block-context? ctx) "a statement"] [(block-context? ctx) "a block"] [(variable-definition-context? ctx) "a variable-definition"] [(constant-definition-context? ctx) "a constant-definition"] [(function-definition-context? ctx) "a function-definition"] + [(prototype-context? ctx) "a function-definition"] [else "an expression"])) (provide block-context? - top-block-context? - return-block-context? + expression-block-context? + top-block-context? definition-context? function-definition-context? @@ -45,16 +55,25 @@ expression-context? type-context? + type-or-expression-context? + prototype-context? + + block-context-return? the-block-context the-top-block-context the-return-block-context + the-expression-block-context + the-expression-return-block-context - the-function-definition-context + make-function-definition-context the-variable-definition-context the-constant-definition-context + the-function-definition-context the-expression-context the-type-context + the-type-or-expression-context + the-prototype-context context->name)) diff --git a/collects/honu-module/private/mzscheme.ss b/collects/honu-module/private/mzscheme.ss new file mode 100644 index 0000000000..112a1e2964 --- /dev/null +++ b/collects/honu-module/private/mzscheme.ss @@ -0,0 +1,3 @@ +(module mzscheme mzscheme + (provide (all-from-except mzscheme + string))) diff --git a/collects/honu-module/private/ops.ss b/collects/honu-module/private/ops.ss index d770cc2400..546f582bc8 100644 --- a/collects/honu-module/private/ops.ss +++ b/collects/honu-module/private/ops.ss @@ -1,23 +1,29 @@ (module ops mzscheme (provide unary-prefix-ops + unary-postfix-ops (struct op (id)) (struct prefix ()) + (struct cast-prefix (type)) (struct infix ()) - (struct postfix ()) + (struct postfix ()) prec-key precedence-table op-table) - (define unary-prefix-ops (list #'++ - #'-- - #'+ - #'- - #'! - #'~)) + (define unary-prefix-ops '(++ + -- + + + - + ! + ~)) + + (define unary-postfix-ops '(++ + --)) (define-struct op (id)) (define-struct (prefix op) ()) + (define-struct (cast-prefix prefix) (type)) (define-struct (infix op) ()) (define-struct (postfix op) ()) @@ -33,6 +39,7 @@ '(((in . |.|) . 100) ((in . #%parens) . 100) ((in . #%brackets) . 100) + ((in . #%angles) . 100) ((post . ++) . 100) ((post . --) . 100) ((pre . ++) . 95) @@ -41,6 +48,7 @@ ((pre . -) . 95) ((pre . ~) . 95) ((pre . !) . 95) + ((pre . #%parens) . 95) ((in . *) . 90) ((in . %) . 90) ((in . /) . 90) @@ -71,7 +79,10 @@ ((in . \|=) . 10) ((in . <<=) . 10) ((in . >>=) . 10) - ((in . >>>=) . 10)) + ((in . >>>=) . 10) + ((in . \,) . 6) + ((in . :) . 5) + ((in . ?) . 4)) 'equal)) (define op-table (make-hash-table)) diff --git a/collects/honu-module/private/util.ss b/collects/honu-module/private/util.ss index 21402e3cba..6c5e05012e 100644 --- a/collects/honu-module/private/util.ss +++ b/collects/honu-module/private/util.ss @@ -1,9 +1,13 @@ (module util mzscheme - (provide extract-until) + (provide delim-identifier=? + extract-until) (require (lib "stx.ss" "syntax")) + (define (delim-identifier=? a b) + (eq? (syntax-e a) (syntax-e b))) + (define extract-until (case-lambda [(r ids keep?) @@ -13,7 +17,7 @@ (values #f #f #f)] [(and (identifier? (stx-car r)) (ormap (lambda (id) - (module-identifier=? id (stx-car r))) + (delim-identifier=? id (stx-car r))) ids)) (values (reverse (if keep? (cons (stx-car r) val-stxs)