mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-13 07:57:35 +02:00
using titlecase names for types
This commit is contained in:
Alex Shinn
parent
b4f1ffd69b
commit
58b05c50af
5 changed files with 58 additions and 56 deletions
|
|
@ -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 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, "<symbol>", SEXP_SYMBOL);
|
||||
sexp_define_type(ctx, "<char>", SEXP_CHAR);
|
||||
sexp_define_type(ctx, "<boolean>", SEXP_BOOLEAN);
|
||||
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(ctx, "<exception>", SEXP_EXCEPTION);
|
||||
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, "Char", SEXP_CHAR);
|
||||
sexp_define_type(ctx, "Boolean", SEXP_BOOLEAN);
|
||||
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(ctx, "Exception", SEXP_EXCEPTION);
|
||||
sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV);
|
||||
sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE);
|
||||
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_PROCEDURE, 1, "procedure-code", 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, 3, "bytecode-source", NULL);
|
||||
sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 0, "exception-kind", NULL);
|
||||
|
|
|
|||
|
|
@ -2,10 +2,10 @@
|
|||
(module (chibi ast)
|
||||
(export
|
||||
analyze optimize env-cell ast->sexp macroexpand type-of
|
||||
<object> <opcode> <procedure> <bytecode> <macro> <env>
|
||||
<number> <bignum> <flonum> <integer> <char> <boolean>
|
||||
<symbol> <string> <byte-vector> <vector> <pair>
|
||||
<context> <lam> <cnd> <set> <ref> <seq> <lit> <sc> <exception>
|
||||
Object Opcode Procedure Bytecode Macro Env
|
||||
Number Bignum Flonum Integer Char Boolean
|
||||
Symbol String Byte-Vector Vector Pair
|
||||
Context Lam Cnd Set Ref Seq Lit Sc Exception
|
||||
syntactic-closure? lambda? cnd? set? ref? seq? lit? type?
|
||||
environment? bytecode? exception? macro? context?
|
||||
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-variadic?
|
||||
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
|
||||
pair-source pair-source-set!
|
||||
port-line port-line-set!
|
||||
|
|
@ -35,4 +35,3 @@
|
|||
(import (scheme))
|
||||
(include-shared "ast")
|
||||
(include "ast.scm"))
|
||||
|
||||
|
|
|
|||
|
|
@ -212,6 +212,9 @@
|
|||
(define (procedure-name x)
|
||||
(bytecode-name (procedure-code x)))
|
||||
|
||||
(define (procedure-name-set! x name)
|
||||
(bytecode-name-set! (procedure-code x) name))
|
||||
|
||||
;;> @subsubsubsection{Macros}
|
||||
|
||||
;;> @itemlist[
|
||||
|
|
|
|||
|
|
@ -23,17 +23,17 @@
|
|||
(not (unfinalized-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)
|
||||
(or (eq? a <opcode>)
|
||||
(eq? a <procedure>)
|
||||
(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)
|
||||
|
|
@ -46,7 +46,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)))
|
||||
|
|
@ -57,8 +57,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))
|
||||
|
|
@ -90,7 +90,7 @@
|
|||
|
||||
(define (type-analyze-expr x)
|
||||
(match x
|
||||
(($ <lam> name params body defs)
|
||||
(($ Lam name params body defs)
|
||||
(cond
|
||||
((not (lambda-return-type x))
|
||||
(lambda-return-type-set! x (list 'return-type x))
|
||||
|
|
@ -98,10 +98,10 @@
|
|||
(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 (value . loc) source)
|
||||
(($ Ref name (value . loc) source)
|
||||
(cond
|
||||
((lambda? loc) (lambda-param-type-ref loc name))
|
||||
((procedure? loc)
|
||||
|
|
@ -109,13 +109,13 @@
|
|||
(if (and (pair? sig) (car sig))
|
||||
(cons 'lambda sig)
|
||||
(list 'return-type (procedure-analysis loc)))))
|
||||
(else <object>)))
|
||||
(($ <cnd> test pass fail)
|
||||
(else Object)))
|
||||
(($ Cnd test pass fail)
|
||||
(let ((test-type (type-analyze-expr test))
|
||||
(pass-type (type-analyze-expr pass))
|
||||
(fail-type (type-analyze-expr fail)))
|
||||
(type-union pass-type fail-type)))
|
||||
(($ <seq> ls)
|
||||
(($ Seq ls)
|
||||
(let lp ((ls ls))
|
||||
(cond ((null? (cdr ls))
|
||||
(type-analyze-expr (car ls)))
|
||||
|
|
@ -135,7 +135,7 @@
|
|||
(car p)
|
||||
(opcode-param-type f (opcode-num-params f)))))
|
||||
(match (car a)
|
||||
(($ <ref> name (_ . (and g ($ <lam>))))
|
||||
(($ Ref name (_ . (and g ($ Lam))))
|
||||
(let ((t (type-intersection (lambda-param-type-ref g name)
|
||||
p-type)))
|
||||
(lambda-param-type-set! g name t)))
|
||||
|
|
@ -165,12 +165,12 @@
|
|||
((and (pair? f-type) (memq (car f-type) '(return-type param-type)))
|
||||
f-type)
|
||||
(else
|
||||
<object>))))))
|
||||
Object))))))
|
||||
(else
|
||||
(type-of x))))
|
||||
|
||||
(define (resolve-delayed-type x)
|
||||
(let lp ((x x) (seen '()) (default <object>))
|
||||
(let lp ((x x) (seen '()) (default Object))
|
||||
(match x
|
||||
(('return-type f)
|
||||
(if (memq f seen)
|
||||
|
|
@ -183,7 +183,7 @@
|
|||
(('or y ...)
|
||||
(let ((z (find finalized-type? y)))
|
||||
(if z
|
||||
(let ((default (if (eq? default <object>)
|
||||
(let ((default (if (eq? default Object)
|
||||
(lp z seen default)
|
||||
(type-union (lp z seen default) default))))
|
||||
(fold type-union
|
||||
|
|
@ -199,7 +199,7 @@
|
|||
|
||||
(define (type-resolve-circularities x)
|
||||
(match x
|
||||
(($ <lam> name params body defs)
|
||||
(($ Lam name params body defs)
|
||||
(if (unfinalized-type? (lambda-return-type x))
|
||||
(lambda-return-type-set! x (resolve-delayed-type
|
||||
(lambda-return-type x))))
|
||||
|
|
@ -210,13 +210,13 @@
|
|||
params
|
||||
(lambda-param-types x))
|
||||
(type-resolve-circularities (lambda-body x)))
|
||||
(($ <set> ref value)
|
||||
(($ Set ref value)
|
||||
(type-resolve-circularities value))
|
||||
(($ <cnd> test pass fail)
|
||||
(($ Cnd test pass fail)
|
||||
(type-resolve-circularities test)
|
||||
(type-resolve-circularities pass)
|
||||
(type-resolve-circularities fail))
|
||||
(($ <seq> ls)
|
||||
(($ Seq ls)
|
||||
(for-each type-resolve-circularities ls))
|
||||
((app ...)
|
||||
(for-each type-resolve-circularities app))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
(define (record? x)
|
||||
(is-a? x <object>))
|
||||
(is-a? x Object))
|
||||
|
||||
(define (record-rtd x)
|
||||
(type-of x))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue