mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-06 20:56:38 +02:00
changing type names to traditional <type>
This commit is contained in:
Alex Shinn
parent
1923f54df0
commit
27a57b6e87
4 changed files with 84 additions and 72 deletions
|
|
@ -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, "<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, "<symbol>", SEXP_SYMBOL);
|
||||
sexp_define_type(ctx, "<string>", SEXP_STRING);
|
||||
sexp_define_type(ctx, "<byte-vector>", SEXP_BYTES);
|
||||
sexp_define_type(ctx, "<pair>", SEXP_PAIR);
|
||||
sexp_define_type(ctx, "<vector>", SEXP_VECTOR);
|
||||
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_predicate(ctx, env, "environment?", SEXP_ENV);
|
||||
sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE);
|
||||
sexp_define_type_predicate(ctx, env, "exception?", SEXP_EXCEPTION);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
<object> <opcode> <procedure> <bytecode> <macro> <env>
|
||||
<number> <bignum> <flonum> <integer>
|
||||
<symbol> <string> <byte-vector> <vector> <pair>
|
||||
<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)
|
||||
(import-immutable (scheme))
|
||||
(include-shared "ast")
|
||||
(include "ast.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)
|
||||
|
|
|
|||
|
|
@ -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 <number>) (eq? a <flonum>) (eq? a <integer>)))
|
||||
|
||||
(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)
|
||||
(or (equal? a b)
|
||||
(equal? a object)
|
||||
(equal? b object)
|
||||
(equal? a <object>)
|
||||
(equal? b <object>)
|
||||
(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 <object>) (equal? b <object>)) <object>)
|
||||
((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 <object>) (unfinalized-type? a)) b)
|
||||
((or (equal? b <object>) (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)
|
||||
(($ <lam> 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)
|
||||
(($ <set> ref value)
|
||||
(type-analyze-expr value)
|
||||
(if #f #f))
|
||||
(($ ref name (_ . loc) source)
|
||||
(($ <ref> name (_ . loc) source)
|
||||
(if (lambda? loc)
|
||||
(lambda-param-type-ref loc name)
|
||||
object))
|
||||
(($ cnd test pass fail)
|
||||
<object>))
|
||||
(($ <cnd> test pass fail)
|
||||
(type-analyze-expr test)
|
||||
(type-union (type-analyze-expr pass) (type-analyze-expr fail)))
|
||||
(($ seq ls)
|
||||
(($ <seq> 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)
|
||||
(($ <ref> name (_ . (and g ($ <lam>))))
|
||||
(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)))))
|
||||
<object>)))))
|
||||
(else
|
||||
;;(write `(unknown type ,x) (current-error-port)) (newline (current-error-port))
|
||||
object)))
|
||||
<object>)))
|
||||
|
||||
(define (type-resolve-circularities x)
|
||||
#f)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue