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

using titlecase names for types

Browse source
This commit is contained in:
Alex Shinn 2011-06-11 16:26:30 +09:00
parent b4f1ffd69b
commit 58b05c50af
5 changed files with 58 additions and 56 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

54
lib/chibi/ast.c
View file

@ -232,32 +232,32 @@ static sexp sexp_string_contains (sexp ctx sexp_api_params(self, n), sexp x, sex
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, "<symbol>", SEXP_SYMBOL); sexp_define_type(ctx, "Symbol", SEXP_SYMBOL);
sexp_define_type(ctx, "<char>", SEXP_CHAR); sexp_define_type(ctx, "Char", SEXP_CHAR);
sexp_define_type(ctx, "<boolean>", SEXP_BOOLEAN); sexp_define_type(ctx, "Boolean", SEXP_BOOLEAN);
sexp_define_type(ctx, "<string>", SEXP_STRING); sexp_define_type(ctx, "String", SEXP_STRING);
sexp_define_type(ctx, "<byte-vector>", SEXP_BYTES); sexp_define_type(ctx, "Byte-Vector", SEXP_BYTES);
sexp_define_type(ctx, "<pair>", SEXP_PAIR); sexp_define_type(ctx, "Pair", SEXP_PAIR);
sexp_define_type(ctx, "<vector>", SEXP_VECTOR); sexp_define_type(ctx, "Vector", SEXP_VECTOR);
sexp_define_type(ctx, "<opcode>", SEXP_OPCODE); sexp_define_type(ctx, "Opcode", SEXP_OPCODE);
sexp_define_type(ctx, "<procedure>", SEXP_PROCEDURE); sexp_define_type(ctx, "Procedure", SEXP_PROCEDURE);
sexp_define_type(ctx, "<bytecode>", SEXP_BYTECODE); sexp_define_type(ctx, "Bytecode", SEXP_BYTECODE);
sexp_define_type(ctx, "<env>", SEXP_ENV); sexp_define_type(ctx, "Env", SEXP_ENV);
sexp_define_type(ctx, "<macro>", SEXP_MACRO); sexp_define_type(ctx, "Macro", SEXP_MACRO);
sexp_define_type(ctx, "<lam>", SEXP_LAMBDA); sexp_define_type(ctx, "Lam", SEXP_LAMBDA);
sexp_define_type(ctx, "<cnd>", SEXP_CND); sexp_define_type(ctx, "Cnd", SEXP_CND);
sexp_define_type(ctx, "<set>", SEXP_SET); sexp_define_type(ctx, "Set", SEXP_SET);
sexp_define_type(ctx, "<ref>", SEXP_REF); sexp_define_type(ctx, "Ref", SEXP_REF);
sexp_define_type(ctx, "<seq>", SEXP_SEQ); sexp_define_type(ctx, "Seq", SEXP_SEQ);
sexp_define_type(ctx, "<lit>", SEXP_LIT); sexp_define_type(ctx, "Lit", SEXP_LIT);
sexp_define_type(ctx, "<sc>", SEXP_SYNCLO); sexp_define_type(ctx, "Sc", SEXP_SYNCLO);
sexp_define_type(ctx, "<context>", SEXP_CONTEXT); sexp_define_type(ctx, "Context", SEXP_CONTEXT);
sexp_define_type(ctx, "<exception>", SEXP_EXCEPTION); sexp_define_type(ctx, "Exception", SEXP_EXCEPTION);
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, "macro?", SEXP_MACRO); sexp_define_type_predicate(ctx, env, "macro?", SEXP_MACRO);
@ -298,7 +298,7 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!"); sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!");
sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 1, "procedure-code", NULL); sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 1, "procedure-code", NULL);
sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 2, "procedure-vars", NULL); sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 2, "procedure-vars", NULL);
sexp_define_accessors(ctx, env, SEXP_BYTECODE, 1, "bytecode-name", NULL); sexp_define_accessors(ctx, env, SEXP_BYTECODE, 1, "bytecode-name", "bytecode-name-set!");
sexp_define_accessors(ctx, env, SEXP_BYTECODE, 2, "bytecode-literals", NULL); sexp_define_accessors(ctx, env, SEXP_BYTECODE, 2, "bytecode-literals", NULL);
sexp_define_accessors(ctx, env, SEXP_BYTECODE, 3, "bytecode-source", NULL); sexp_define_accessors(ctx, env, SEXP_BYTECODE, 3, "bytecode-source", NULL);
sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 0, "exception-kind", NULL); sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 0, "exception-kind", NULL);

11
lib/chibi/ast.module
View file

@ -2,10 +2,10 @@
(module (chibi ast) (module (chibi ast)
(export (export
analyze optimize env-cell ast->sexp macroexpand type-of analyze optimize env-cell ast->sexp macroexpand type-of
<object> <opcode> <procedure> <bytecode> <macro> <env> Object Opcode Procedure Bytecode Macro Env
<number> <bignum> <flonum> <integer> <char> <boolean> Number Bignum Flonum Integer Char Boolean
<symbol> <string> <byte-vector> <vector> <pair> Symbol String Byte-Vector Vector Pair
<context> <lam> <cnd> <set> <ref> <seq> <lit> <sc> <exception> Context Lam Cnd Set Ref Seq Lit Sc Exception
syntactic-closure? lambda? cnd? set? ref? seq? lit? type? syntactic-closure? lambda? cnd? set? ref? seq? lit? type?
environment? bytecode? exception? macro? context? environment? bytecode? exception? macro? context?
syntactic-closure-expr syntactic-closure-env syntactic-closure-vars syntactic-closure-expr syntactic-closure-env syntactic-closure-vars
@ -25,7 +25,7 @@
opcode-name opcode-num-params opcode-return-type opcode-param-type opcode-name opcode-num-params opcode-return-type opcode-param-type
opcode-variadic? opcode-variadic?
macro-procedure macro-env macro-source macro-procedure macro-env macro-source
procedure-code procedure-vars procedure-name procedure-code procedure-vars procedure-name procedure-name-set!
bytecode-name bytecode-literals bytecode-source bytecode-name bytecode-literals bytecode-source
pair-source pair-source-set! pair-source pair-source-set!
port-line port-line-set! port-line port-line-set!
@ -35,4 +35,3 @@
(import (scheme)) (import (scheme))
(include-shared "ast") (include-shared "ast")
(include "ast.scm")) (include "ast.scm"))

3
lib/chibi/ast.scm
View file

@ -212,6 +212,9 @@
(define (procedure-name x) (define (procedure-name x)
(bytecode-name (procedure-code x))) (bytecode-name (procedure-code x)))
(define (procedure-name-set! x name)
(bytecode-name-set! (procedure-code x) name))
;;> @subsubsubsection{Macros} ;;> @subsubsubsection{Macros}
;;> @itemlist[ ;;> @itemlist[

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

@ -23,17 +23,17 @@
(not (unfinalized-type? a))) (not (unfinalized-type? a)))
(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>) (or (eq? a Opcode)
(eq? a <procedure>) (eq? a Procedure)
(and (pair? a) (eq? (car a) 'lambda)))) (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)
@ -46,7 +46,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)))
@ -57,8 +57,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))
@ -90,7 +90,7 @@
(define (type-analyze-expr x) (define (type-analyze-expr x)
(match x (match x
(($ <lam> name params body defs) (($ Lam name params body defs)
(cond (cond
((not (lambda-return-type x)) ((not (lambda-return-type x))
(lambda-return-type-set! x (list 'return-type x)) (lambda-return-type-set! x (list 'return-type x))
@ -98,10 +98,10 @@
(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 (value . loc) source) (($ Ref name (value . loc) source)
(cond (cond
((lambda? loc) (lambda-param-type-ref loc name)) ((lambda? loc) (lambda-param-type-ref loc name))
((procedure? loc) ((procedure? loc)
@ -109,13 +109,13 @@
(if (and (pair? sig) (car sig)) (if (and (pair? sig) (car sig))
(cons 'lambda sig) (cons 'lambda sig)
(list 'return-type (procedure-analysis loc))))) (list 'return-type (procedure-analysis loc)))))
(else <object>))) (else Object)))
(($ <cnd> test pass fail) (($ Cnd test pass fail)
(let ((test-type (type-analyze-expr test)) (let ((test-type (type-analyze-expr test))
(pass-type (type-analyze-expr pass)) (pass-type (type-analyze-expr pass))
(fail-type (type-analyze-expr fail))) (fail-type (type-analyze-expr fail)))
(type-union pass-type fail-type))) (type-union pass-type fail-type)))
(($ <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)))
@ -135,7 +135,7 @@
(car p) (car p)
(opcode-param-type f (opcode-num-params f))))) (opcode-param-type f (opcode-num-params f)))))
(match (car a) (match (car a)
(($ <ref> name (_ . (and g ($ <lam>)))) (($ Ref name (_ . (and g ($ Lam))))
(let ((t (type-intersection (lambda-param-type-ref g name) (let ((t (type-intersection (lambda-param-type-ref g name)
p-type))) p-type)))
(lambda-param-type-set! g name t))) (lambda-param-type-set! g name t)))
@ -165,12 +165,12 @@
((and (pair? f-type) (memq (car f-type) '(return-type param-type))) ((and (pair? f-type) (memq (car f-type) '(return-type param-type)))
f-type) f-type)
(else (else
<object>)))))) Object))))))
(else (else
(type-of x)))) (type-of x))))
(define (resolve-delayed-type x) (define (resolve-delayed-type x)
(let lp ((x x) (seen '()) (default <object>)) (let lp ((x x) (seen '()) (default Object))
(match x (match x
(('return-type f) (('return-type f)
(if (memq f seen) (if (memq f seen)
@ -183,7 +183,7 @@
(('or y ...) (('or y ...)
(let ((z (find finalized-type? y))) (let ((z (find finalized-type? y)))
(if z (if z
(let ((default (if (eq? default <object>) (let ((default (if (eq? default Object)
(lp z seen default) (lp z seen default)
(type-union (lp z seen default) default)))) (type-union (lp z seen default) default))))
(fold type-union (fold type-union
@ -199,7 +199,7 @@
(define (type-resolve-circularities x) (define (type-resolve-circularities x)
(match x (match x
(($ <lam> name params body defs) (($ Lam name params body defs)
(if (unfinalized-type? (lambda-return-type x)) (if (unfinalized-type? (lambda-return-type x))
(lambda-return-type-set! x (resolve-delayed-type (lambda-return-type-set! x (resolve-delayed-type
(lambda-return-type x)))) (lambda-return-type x))))
@ -210,13 +210,13 @@
params params
(lambda-param-types x)) (lambda-param-types x))
(type-resolve-circularities (lambda-body x))) (type-resolve-circularities (lambda-body x)))
(($ <set> ref value) (($ Set ref value)
(type-resolve-circularities value)) (type-resolve-circularities value))
(($ <cnd> test pass fail) (($ Cnd test pass fail)
(type-resolve-circularities test) (type-resolve-circularities test)
(type-resolve-circularities pass) (type-resolve-circularities pass)
(type-resolve-circularities fail)) (type-resolve-circularities fail))
(($ <seq> ls) (($ Seq ls)
(for-each type-resolve-circularities ls)) (for-each type-resolve-circularities ls))
((app ...) ((app ...)
(for-each type-resolve-circularities app)) (for-each type-resolve-circularities app))

2
lib/srfi/99/records/inspection.scm
View file

@ -1,6 +1,6 @@
(define (record? x) (define (record? x)
(is-a? x <object>)) (is-a? x Object))
(define (record-rtd x) (define (record-rtd x)
(type-of x)) (type-of x))