Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-06 20:56:38 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

changing type names to traditional <type>

Browse source
This commit is contained in:
Alex Shinn 2010-08-01 15:03:13 +09:00
parent 1923f54df0
commit 27a57b6e87
4 changed files with 84 additions and 72 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

41
lib/chibi/ast.c
View file

@ -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_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 sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
sexp_define_type(ctx, "object", SEXP_OBJECT); sexp_define_type(ctx, "<object>", SEXP_OBJECT);
sexp_define_type(ctx, "number", SEXP_NUMBER); sexp_define_type(ctx, "<number>", SEXP_NUMBER);
sexp_define_type(ctx, "bignum", SEXP_BIGNUM); sexp_define_type(ctx, "<bignum>", SEXP_BIGNUM);
sexp_define_type(ctx, "flonum", SEXP_FLONUM); sexp_define_type(ctx, "<flonum>", SEXP_FLONUM);
sexp_define_type(ctx, "integer", SEXP_FIXNUM); sexp_define_type(ctx, "<integer>", SEXP_FIXNUM);
sexp_define_type(ctx, "opcode", SEXP_OPCODE); sexp_define_type(ctx, "<symbol>", SEXP_SYMBOL);
sexp_define_type(ctx, "procedure", SEXP_PROCEDURE); sexp_define_type(ctx, "<string>", SEXP_STRING);
sexp_define_type(ctx, "bytecode", SEXP_BYTECODE); sexp_define_type(ctx, "<byte-vector>", SEXP_BYTES);
sexp_define_type(ctx, "env", SEXP_ENV); sexp_define_type(ctx, "<pair>", SEXP_PAIR);
sexp_define_type(ctx, "macro", SEXP_MACRO); sexp_define_type(ctx, "<vector>", SEXP_VECTOR);
sexp_define_type(ctx, "lam", SEXP_LAMBDA); sexp_define_type(ctx, "<opcode>", SEXP_OPCODE);
sexp_define_type(ctx, "cnd", SEXP_CND); sexp_define_type(ctx, "<procedure>", SEXP_PROCEDURE);
sexp_define_type(ctx, "set", SEXP_SET); sexp_define_type(ctx, "<bytecode>", SEXP_BYTECODE);
sexp_define_type(ctx, "ref", SEXP_REF); sexp_define_type(ctx, "<env>", SEXP_ENV);
sexp_define_type(ctx, "seq", SEXP_SEQ); sexp_define_type(ctx, "<macro>", SEXP_MACRO);
sexp_define_type(ctx, "lit", SEXP_LIT); sexp_define_type(ctx, "<lam>", SEXP_LAMBDA);
sexp_define_type(ctx, "sc", SEXP_SYNCLO); sexp_define_type(ctx, "<cnd>", SEXP_CND);
sexp_define_type(ctx, "context", SEXP_CONTEXT); 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_predicate(ctx, env, "environment?", SEXP_ENV); sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV);
sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE); sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE);
sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION); sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION);

47
lib/chibi/ast.module
View file

@ -1,27 +1,30 @@
(define-module (chibi ast) (define-module (chibi ast)
(export analyze optimize env-cell ast->sexp macroexpand (export
object opcode procedure bytecode macro env number bignum flonum integer analyze optimize env-cell ast->sexp macroexpand
context lam cnd set ref seq lit sc <object> <opcode> <procedure> <bytecode> <macro> <env>
pair-source pair-source-set! <number> <bignum> <flonum> <integer>
syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? type? <symbol> <string> <byte-vector> <vector> <pair>
environment? bytecode? exception? macro? context? <context> <lam> <cnd> <set> <ref> <seq> <lit> <sc>
syntactic-closure-expr syntactic-closure-env syntactic-closure-vars pair-source pair-source-set!
lambda-name lambda-params lambda-body lambda-defs lambda-locals syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode? type?
lambda-flags lambda-free-vars lambda-set-vars lambda-return-type environment? bytecode? exception? macro? context?
lambda-param-types lambda-source syntactic-closure-expr syntactic-closure-env syntactic-closure-vars
lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set! lambda-name lambda-params lambda-body lambda-defs lambda-locals
lambda-locals-set! lambda-flags-set! lambda-free-vars-set! lambda-flags lambda-free-vars lambda-set-vars lambda-return-type
lambda-set-vars-set! lambda-return-type-set! lambda-param-types-set! lambda-param-types lambda-source
lambda-source-set! lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set!
cnd-test cnd-pass cnd-fail lambda-locals-set! lambda-flags-set! lambda-free-vars-set!
cnd-test-set! cnd-pass-set! cnd-fail-set! lambda-set-vars-set! lambda-return-type-set! lambda-param-types-set!
set-var set-value set-var-set! set-value-set! lambda-source-set!
ref-name ref-cell ref-name-set! ref-cell-set! cnd-test cnd-pass cnd-fail
seq-ls seq-ls-set! lit-value lit-value-set! cnd-test-set! cnd-pass-set! cnd-fail-set!
opcode-name opcode-num-params opcode-return-type opcode-param-type set-var set-value set-var-set! set-value-set!
opcode-variadic? ref-name ref-cell ref-name-set! ref-cell-set!
procedure-code procedure-vars procedure-name bytecode-name) 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)) (import-immutable (scheme))
(include-shared "ast") (include-shared "ast")
(include "ast.scm")) (include "ast.scm"))

2
lib/chibi/test.scm
View file

@ -15,7 +15,7 @@
(call-with-current-continuation (call-with-current-continuation
(lambda (return) (lambda (return)
(with-exception-handler (with-exception-handler
(lambda (exn) handler) (lambda (exn) (return handler))
(lambda () body ...))))))) (lambda () body ...)))))))
(define (warning msg . args) (define (warning msg . args)

66
lib/chibi/type-inference.scm
View file

@ -13,15 +13,17 @@
(and (pair? a) (memq (car a) '(return-type param-type)))) (and (pair? a) (memq (car a) '(return-type param-type))))
(define (numeric-type? a) (define (numeric-type? a)
(or (eq? a number) (eq? a flonum) (eq? a integer))) (or (eq? a <number>) (eq? a <flonum>) (eq? a <integer>)))
(define (procedure-type? a) (define (procedure-type? a)
(or (eq? a opcode) (eq? a procedure) (and (pair? a) (eq? (car a) 'lambda)))) (or (eq? a <opcode>)
(eq? a <procedure>)
(and (pair? a) (eq? (car a) 'lambda))))
(define (type-subset? a b) (define (type-subset? a b)
(or (equal? a b) (or (equal? a b)
(equal? a object) (equal? a <object>)
(equal? b object) (equal? b <object>)
(and (numeric-type? a) (numeric-type? b)) (and (numeric-type? a) (numeric-type? b))
(and (procedure-type? a) (procedure-type? b)) (and (procedure-type? a) (procedure-type? b))
(if (union-type? a) (if (union-type? a)
@ -34,7 +36,7 @@
(define (type-union a b) (define (type-union a b)
(cond (cond
((equal? a b) a) ((equal? a b) a)
((or (equal? a object) (equal? b object)) object) ((or (equal? a <object>) (equal? b <object>)) <object>)
((union-type? a) ((union-type? a)
(if (union-type? b) (if (union-type? b)
(cons (car a) (lset-union equal? (cdr a) (cdr b))) (cons (car a) (lset-union equal? (cdr a) (cdr b)))
@ -45,8 +47,8 @@
(define (type-intersection a b) (define (type-intersection a b)
(cond (cond
((equal? a b) a) ((equal? a b) a)
((or (equal? a object) (unfinalized-type? a)) b) ((or (equal? a <object>) (unfinalized-type? a)) b)
((or (equal? b object) (unfinalized-type? b)) a) ((or (equal? b <object>) (unfinalized-type? b)) a)
((intersection-type? a) ((intersection-type? a)
(if (intersection-type? b) (if (intersection-type? b)
(lset-intersection equal? (cdr a) (cdr b)) (lset-intersection equal? (cdr a) (cdr b))
@ -79,23 +81,23 @@
(define (type-analyze-expr x) (define (type-analyze-expr x)
;;(write `(type-analyze-expr ,x ,(ast->sexp x)) (current-error-port)) (newline (current-error-port)) ;;(write `(type-analyze-expr ,x ,(ast->sexp x)) (current-error-port)) (newline (current-error-port))
(match x (match x
(($ lam name params body defs) (($ <lam> name params body defs)
(lambda-return-type-set! x (list 'return-type x)) (lambda-return-type-set! x (list 'return-type x))
(lambda-param-types-initialize! x) (lambda-param-types-initialize! x)
(let ((ret-type (type-analyze-expr body))) (let ((ret-type (type-analyze-expr body)))
(lambda-return-type-set! x ret-type) (lambda-return-type-set! x ret-type)
(cons 'lambda (cons ret-type (lambda-param-types x))))) (cons 'lambda (cons ret-type (lambda-param-types x)))))
(($ set ref value) (($ <set> ref value)
(type-analyze-expr value) (type-analyze-expr value)
(if #f #f)) (if #f #f))
(($ ref name (_ . loc) source) (($ <ref> name (_ . loc) source)
(if (lambda? loc) (if (lambda? loc)
(lambda-param-type-ref loc name) (lambda-param-type-ref loc name)
object)) <object>))
(($ cnd test pass fail) (($ <cnd> test pass fail)
(type-analyze-expr test) (type-analyze-expr test)
(type-union (type-analyze-expr pass) (type-analyze-expr fail))) (type-union (type-analyze-expr pass) (type-analyze-expr fail)))
(($ seq ls) (($ <seq> ls)
(let lp ((ls ls)) (let lp ((ls ls))
(cond ((null? (cdr ls)) (cond ((null? (cdr ls))
(type-analyze-expr (car ls))) (type-analyze-expr (car ls)))
@ -105,27 +107,29 @@
((f args ...) ((f args ...)
(cond (cond
((opcode? f) ((opcode? f)
;;(write `(opcode app ,(opcode-param-types f) ,args) (current-error-port)) (newline (current-error-port))
(let lp ((p (opcode-param-types f)) (let lp ((p (opcode-param-types f))
(a args)) (a args))
(cond (cond
((pair? a) ((pair? a)
(cond ((or (pair? p) (opcode-variadic? f)) (cond ((or (pair? p) (opcode-variadic? f))
(match (car a) (let ((p-type
(($ ref name (_ . (and g ($ lam)))) (if (pair? p)
(let ((t (type-intersection (lambda-param-type-ref g name) (car p)
(if (pair? p) (opcode-param-type f (opcode-num-params f)))))
(car p) (match (car a)
(opcode-param-type f (opcode-num-params f)))))) (($ <ref> name (_ . (and g ($ <lam>))))
(lambda-param-type-set! g name t))) (let ((t (type-intersection (lambda-param-type-ref g name)
(else p-type)))
(let ((t (type-analyze-expr (car a)))) (lambda-param-type-set! g name t)))
(cond (else
((not (type-subset? t (car p))) (let ((t (type-analyze-expr (car a))))
(display "WARNING: incompatible type: " (current-error-port)) (cond
(write (list x t (car p)) (current-error-port)) ((not (type-subset? t p-type))
(newline (current-error-port)))) (display "WARNING: incompatible type: "
t))) (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))) (lp (and (pair? p) (cdr p)) (cdr a)))
(else (else
(for-each type-analyze-expr a)))))) (for-each type-analyze-expr a))))))
@ -136,10 +140,10 @@
(for-each type-analyze-expr args) (for-each type-analyze-expr args)
(if (and (pair? f-type) (eq? 'lambda (car f-type))) (if (and (pair? f-type) (eq? 'lambda (car f-type)))
(cadr f-type) (cadr f-type)
object))))) <object>)))))
(else (else
;;(write `(unknown type ,x) (current-error-port)) (newline (current-error-port)) ;;(write `(unknown type ,x) (current-error-port)) (newline (current-error-port))
object))) <object>)))
(define (type-resolve-circularities x) (define (type-resolve-circularities x)
#f) #f)