diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 5f998e7e..74fd5fc2 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -139,24 +139,29 @@ static sexp sexp_optimize (sexp ctx sexp_api_params(self, n), sexp x) { sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, tag)); sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { - sexp_define_type(ctx, "object", SEXP_OBJECT); - sexp_define_type(ctx, "number", SEXP_NUMBER); - sexp_define_type(ctx, "bignum", SEXP_BIGNUM); - sexp_define_type(ctx, "flonum", SEXP_FLONUM); - sexp_define_type(ctx, "integer", SEXP_FIXNUM); - sexp_define_type(ctx, "opcode", SEXP_OPCODE); - sexp_define_type(ctx, "procedure", SEXP_PROCEDURE); - sexp_define_type(ctx, "bytecode", SEXP_BYTECODE); - sexp_define_type(ctx, "env", SEXP_ENV); - sexp_define_type(ctx, "macro", SEXP_MACRO); - sexp_define_type(ctx, "lam", SEXP_LAMBDA); - sexp_define_type(ctx, "cnd", SEXP_CND); - sexp_define_type(ctx, "set", SEXP_SET); - sexp_define_type(ctx, "ref", SEXP_REF); - sexp_define_type(ctx, "seq", SEXP_SEQ); - sexp_define_type(ctx, "lit", SEXP_LIT); - sexp_define_type(ctx, "sc", SEXP_SYNCLO); - sexp_define_type(ctx, "context", SEXP_CONTEXT); + sexp_define_type(ctx, "", SEXP_OBJECT); + sexp_define_type(ctx, "", SEXP_NUMBER); + sexp_define_type(ctx, "", SEXP_BIGNUM); + sexp_define_type(ctx, "", SEXP_FLONUM); + sexp_define_type(ctx, "", SEXP_FIXNUM); + sexp_define_type(ctx, "", SEXP_SYMBOL); + sexp_define_type(ctx, "", SEXP_STRING); + sexp_define_type(ctx, "", SEXP_BYTES); + sexp_define_type(ctx, "", SEXP_PAIR); + sexp_define_type(ctx, "", SEXP_VECTOR); + sexp_define_type(ctx, "", SEXP_OPCODE); + sexp_define_type(ctx, "", SEXP_PROCEDURE); + sexp_define_type(ctx, "", SEXP_BYTECODE); + sexp_define_type(ctx, "", SEXP_ENV); + sexp_define_type(ctx, "", SEXP_MACRO); + sexp_define_type(ctx, "", SEXP_LAMBDA); + sexp_define_type(ctx, "", SEXP_CND); + sexp_define_type(ctx, "", SEXP_SET); + sexp_define_type(ctx, "", SEXP_REF); + sexp_define_type(ctx, "", SEXP_SEQ); + sexp_define_type(ctx, "", SEXP_LIT); + sexp_define_type(ctx, "", SEXP_SYNCLO); + sexp_define_type(ctx, "", SEXP_CONTEXT); sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV); sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE); sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION); diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index 192b1d7c..d6ca34d5 100644 --- a/lib/chibi/ast.module +++ b/lib/chibi/ast.module @@ -1,27 +1,30 @@ (define-module (chibi ast) - (export analyze optimize env-cell ast->sexp macroexpand - object opcode procedure bytecode macro env number bignum flonum integer - context lam cnd set ref seq lit sc - pair-source pair-source-set! - syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? type? - environment? bytecode? exception? macro? context? - syntactic-closure-expr syntactic-closure-env syntactic-closure-vars - lambda-name lambda-params lambda-body lambda-defs lambda-locals - lambda-flags lambda-free-vars lambda-set-vars lambda-return-type - lambda-param-types lambda-source - lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set! - lambda-locals-set! lambda-flags-set! lambda-free-vars-set! - lambda-set-vars-set! lambda-return-type-set! lambda-param-types-set! - lambda-source-set! - cnd-test cnd-pass cnd-fail - cnd-test-set! cnd-pass-set! cnd-fail-set! - set-var set-value set-var-set! set-value-set! - ref-name ref-cell ref-name-set! ref-cell-set! - seq-ls seq-ls-set! lit-value lit-value-set! - opcode-name opcode-num-params opcode-return-type opcode-param-type - opcode-variadic? - procedure-code procedure-vars procedure-name bytecode-name) + (export + analyze optimize env-cell ast->sexp macroexpand + + + + + pair-source pair-source-set! + syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? type? + environment? bytecode? exception? macro? context? + syntactic-closure-expr syntactic-closure-env syntactic-closure-vars + lambda-name lambda-params lambda-body lambda-defs lambda-locals + lambda-flags lambda-free-vars lambda-set-vars lambda-return-type + lambda-param-types lambda-source + lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set! + lambda-locals-set! lambda-flags-set! lambda-free-vars-set! + lambda-set-vars-set! lambda-return-type-set! lambda-param-types-set! + lambda-source-set! + cnd-test cnd-pass cnd-fail + cnd-test-set! cnd-pass-set! cnd-fail-set! + set-var set-value set-var-set! set-value-set! + ref-name ref-cell ref-name-set! ref-cell-set! + seq-ls seq-ls-set! lit-value lit-value-set! + opcode-name opcode-num-params opcode-return-type opcode-param-type + opcode-variadic? + procedure-code procedure-vars procedure-name bytecode-name) (import-immutable (scheme)) (include-shared "ast") (include "ast.scm")) diff --git a/lib/chibi/test.scm b/lib/chibi/test.scm index 58649427..728cb36c 100644 --- a/lib/chibi/test.scm +++ b/lib/chibi/test.scm @@ -15,7 +15,7 @@ (call-with-current-continuation (lambda (return) (with-exception-handler - (lambda (exn) handler) + (lambda (exn) (return handler)) (lambda () body ...))))))) (define (warning msg . args) diff --git a/lib/chibi/type-inference.scm b/lib/chibi/type-inference.scm index 515a8cca..605a442a 100644 --- a/lib/chibi/type-inference.scm +++ b/lib/chibi/type-inference.scm @@ -13,15 +13,17 @@ (and (pair? a) (memq (car a) '(return-type param-type)))) (define (numeric-type? a) - (or (eq? a number) (eq? a flonum) (eq? a integer))) + (or (eq? a ) (eq? a ) (eq? a ))) (define (procedure-type? a) - (or (eq? a opcode) (eq? a procedure) (and (pair? a) (eq? (car a) 'lambda)))) + (or (eq? a ) + (eq? a ) + (and (pair? a) (eq? (car a) 'lambda)))) (define (type-subset? a b) (or (equal? a b) - (equal? a object) - (equal? b object) + (equal? a ) + (equal? b ) (and (numeric-type? a) (numeric-type? b)) (and (procedure-type? a) (procedure-type? b)) (if (union-type? a) @@ -34,7 +36,7 @@ (define (type-union a b) (cond ((equal? a b) a) - ((or (equal? a object) (equal? b object)) object) + ((or (equal? a ) (equal? b )) ) ((union-type? a) (if (union-type? b) (cons (car a) (lset-union equal? (cdr a) (cdr b))) @@ -45,8 +47,8 @@ (define (type-intersection a b) (cond ((equal? a b) a) - ((or (equal? a object) (unfinalized-type? a)) b) - ((or (equal? b object) (unfinalized-type? b)) a) + ((or (equal? a ) (unfinalized-type? a)) b) + ((or (equal? b ) (unfinalized-type? b)) a) ((intersection-type? a) (if (intersection-type? b) (lset-intersection equal? (cdr a) (cdr b)) @@ -79,23 +81,23 @@ (define (type-analyze-expr x) ;;(write `(type-analyze-expr ,x ,(ast->sexp x)) (current-error-port)) (newline (current-error-port)) (match x - (($ lam name params body defs) + (($ name params body defs) (lambda-return-type-set! x (list 'return-type x)) (lambda-param-types-initialize! x) (let ((ret-type (type-analyze-expr body))) (lambda-return-type-set! x ret-type) (cons 'lambda (cons ret-type (lambda-param-types x))))) - (($ set ref value) + (($ ref value) (type-analyze-expr value) (if #f #f)) - (($ ref name (_ . loc) source) + (($ name (_ . loc) source) (if (lambda? loc) (lambda-param-type-ref loc name) - object)) - (($ cnd test pass fail) + )) + (($ test pass fail) (type-analyze-expr test) (type-union (type-analyze-expr pass) (type-analyze-expr fail))) - (($ seq ls) + (($ ls) (let lp ((ls ls)) (cond ((null? (cdr ls)) (type-analyze-expr (car ls))) @@ -105,27 +107,29 @@ ((f args ...) (cond ((opcode? f) - ;;(write `(opcode app ,(opcode-param-types f) ,args) (current-error-port)) (newline (current-error-port)) (let lp ((p (opcode-param-types f)) (a args)) (cond ((pair? a) (cond ((or (pair? p) (opcode-variadic? f)) - (match (car a) - (($ ref name (_ . (and g ($ lam)))) - (let ((t (type-intersection (lambda-param-type-ref g name) - (if (pair? p) - (car p) - (opcode-param-type f (opcode-num-params f)))))) - (lambda-param-type-set! g name t))) - (else - (let ((t (type-analyze-expr (car a)))) - (cond - ((not (type-subset? t (car p))) - (display "WARNING: incompatible type: " (current-error-port)) - (write (list x t (car p)) (current-error-port)) - (newline (current-error-port)))) - t))) + (let ((p-type + (if (pair? p) + (car p) + (opcode-param-type f (opcode-num-params f))))) + (match (car a) + (($ name (_ . (and g ($ )))) + (let ((t (type-intersection (lambda-param-type-ref g name) + p-type))) + (lambda-param-type-set! g name t))) + (else + (let ((t (type-analyze-expr (car a)))) + (cond + ((not (type-subset? t p-type)) + (display "WARNING: incompatible type: " + (current-error-port)) + (write (list x t p-type) (current-error-port)) + (newline (current-error-port)))) + t)))) (lp (and (pair? p) (cdr p)) (cdr a))) (else (for-each type-analyze-expr a)))))) @@ -136,10 +140,10 @@ (for-each type-analyze-expr args) (if (and (pair? f-type) (eq? 'lambda (car f-type))) (cadr f-type) - object))))) + ))))) (else ;;(write `(unknown type ,x) (current-error-port)) (newline (current-error-port)) - object))) + ))) (define (type-resolve-circularities x) #f)