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

adding several utilities to chibi.modules including procedure-analysis

Browse source
This commit is contained in:
Alex Shinn 2010-07-25 21:24:46 +09:00
parent b2975ef623
commit ce6891b188
10 changed files with 133 additions and 158 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
include/chibi/sexp.h
View file

@ -301,7 +301,7 @@ struct sexp_struct {
struct sexp_core_form_struct core;
/* ast types */
struct {
sexp name, params, body, defs, locals, flags, fv, sv, source;
sexp name, params, body, defs, locals, flags, fv, sv, ret, types, source;
} lambda;
struct {
sexp test, pass, fail, source;
@ -704,6 +704,8 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
#define sexp_lambda_body(x) ((x)->value.lambda.body)
#define sexp_lambda_fv(x) ((x)->value.lambda.fv)
#define sexp_lambda_sv(x) ((x)->value.lambda.sv)
#define sexp_lambda_return_type(x) ((x)->value.lambda.ret)
#define sexp_lambda_param_types(x) ((x)->value.lambda.types)
#define sexp_lambda_source(x) ((x)->value.lambda.source)
#define sexp_cnd_test(x) ((x)->value.cnd.test)

36
lib/chibi/ast.c
View file

@ -45,8 +45,25 @@ static sexp sexp_get_opcode_name (sexp ctx sexp_api_params(self, n), sexp op) {
return sexp_intern(ctx, sexp_opcode_name(op), -1);
}
static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x) {
return sexp_analyze(ctx, x);
static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) {
sexp ctx2 = ctx;
if (sexp_envp(e)) {
ctx2 = sexp_make_child_context(ctx, NULL);
sexp_context_env(ctx2) = e;
}
return sexp_analyze(ctx2, x);
}
static sexp sexp_optimize (sexp ctx sexp_api_params(self, n), sexp x) {
sexp_gc_var2(ls, res);
sexp_gc_preserve2(ctx, ls, res);
res = x;
ls = sexp_global(ctx, SEXP_G_OPTIMIZATIONS);
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls))
res = sexp_apply1(ctx, sexp_cdar(ls), res);
sexp_free_vars(ctx, res, SEXP_NULL);
sexp_gc_release2(ctx);
return res;
}
#define sexp_define_type(ctx, name, tag) \
@ -67,6 +84,8 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ);
sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT);
sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE);
sexp_define_type_predicate(ctx, env, "type?", SEXP_TYPE);
sexp_define_accessors(ctx, env, SEXP_PAIR, 2, "pair-source", "pair-source-set!");
sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", "syntactic-closure-env-set!");
sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!");
sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", "syntactic-closure-expr-set!");
@ -74,6 +93,13 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!");
sexp_define_accessors(ctx, env, SEXP_LAMBDA, 2, "lambda-body", "lambda-body-set!");
sexp_define_accessors(ctx, env, SEXP_LAMBDA, 3, "lambda-defs", "lambda-defs-set!");
sexp_define_accessors(ctx, env, SEXP_LAMBDA, 4, "lambda-locals", "lambda-locals-set!");
sexp_define_accessors(ctx, env, SEXP_LAMBDA, 5, "lambda-flags", "lambda-flags-set!");
sexp_define_accessors(ctx, env, SEXP_LAMBDA, 6, "lambda-free-vars", "lambda-free-vars-set!");
sexp_define_accessors(ctx, env, SEXP_LAMBDA, 7, "lambda-set-vars", "lambda-set-vars-set!");
sexp_define_accessors(ctx, env, SEXP_LAMBDA, 8, "lambda-return-type", "lambda-return-type-set!");
sexp_define_accessors(ctx, env, SEXP_LAMBDA, 9, "lambda-param-types", "lambda-param-types-set!");
sexp_define_accessors(ctx, env, SEXP_LAMBDA, 10, "lambda-source", "lambda-source-set!");
sexp_define_accessors(ctx, env, SEXP_CND, 0, "cnd-test", "cnd-test-set!");
sexp_define_accessors(ctx, env, SEXP_CND, 1, "cnd-pass", "cnd-pass-set!");
sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!");
@ -83,10 +109,14 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!");
sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!");
sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!");
sexp_define_foreign(ctx, env, "analyze", 1, sexp_analyze_op);
sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 1, "procedure-code", "procedure-code-set!");
sexp_define_accessors(ctx, env, SEXP_PROCEDURE, 2, "procedure-vars", "procedure-vars-set!");
sexp_define_accessors(ctx, env, SEXP_BYTECODE, 1, "bytecode-name", "bytecode-name-set!");
sexp_define_foreign_opt(ctx, env, "analyze", 2, sexp_analyze_op, SEXP_FALSE);
sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env);
sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell);
sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name);
sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize);
return SEXP_VOID;
}

16
lib/chibi/ast.module
View file

@ -1,16 +1,24 @@
(define-module (chibi ast)
(export analyze env-cell opcode-name
(export analyze optimize env-cell opcode-name ast->sexp macroexpand
lam cnd set ref seq lit
pair-source pair-source-set!
syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode?
syntactic-closure-expr syntactic-closure-env syntactic-closure-vars
lambda-name lambda-params lambda-body lambda-defs
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!)
seq-ls seq-ls-set! lit-value lit-value-set!
procedure-code procedure-vars procedure-name bytecode-name)
(import-immutable (scheme))
(include-shared "ast"))
(include-shared "ast")
(include "ast.scm"))

6
lib/chibi/macroexpand.module
View file

@ -1,6 +0,0 @@
(define-module (chibi macroexpand)
(import-immutable (scheme))
(import (chibi ast))
(export macroexpand ast->sexp)
(include "macroexpand.scm"))

86
lib/chibi/macroexpand.scm
View file

@ -1,86 +0,0 @@
;; macroexpand.scm -- macro expansion utility
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;; This actually analyzes the expression then reverse-engineers an
;; sexp from the result, generating a minimal amount of renames.
(define (macroexpand x)
(ast->sexp (analyze x)))
(define (ast-renames ast)
(define i 0)
(define renames '())
(define (rename-symbol id)
(set! i (+ i 1))
(string->symbol
(string-append (symbol->string (identifier->symbol id))
"." (number->string i))))
(define (rename-lambda lam)
(or (assq lam renames)
(let ((res (list lam)))
(set! renames (cons res renames))
res)))
(define (rename! id lam)
(let ((cell (rename-lambda lam)))
(set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell)))))
(define (check-ref id lam env)
(let ((sym (identifier->symbol id)))
(let lp1 ((ls env))
(cond
((pair? ls)
(let lp2 ((ls2 (car ls)) (found? #f))
(cond
((null? ls2)
(if (not found?) (lp1 (cdr ls))))
((and (eq? id (caar ls2)) (eq? lam (cdar ls2)))
(lp2 (cdr ls2) #t))
((eq? sym (identifier->symbol (caar ls2)))
(rename! (caar ls2) (cdar ls2))
(lp2 (cdr ls2) found?))
(else
(lp2 (cdr ls2) found?)))))))))
(define (flatten-dot x)
(cond ((pair? x) (cons (car x) (flatten-dot (cdr x))))
((null? x) x)
(else (list x))))
(define (extend-env lam env)
(cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env))
(let lp ((x ast) (env '()))
(cond
((lambda? x) (lp (lambda-body x) (extend-env x env)))
((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env))
((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env))
((set? x) (lp (set-var x) env) (lp (set-value x) env))
((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x)))
((pair? x) (for-each (lambda (x) (lp x env)) x))))
renames)
(define (get-rename id lam renames)
(let ((ls (assq lam renames)))
(if (not ls)
(identifier->symbol id)
(cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id))))))
(define (ast->sexp ast)
(let ((renames (ast-renames ast)))
(let a2s ((x ast))
(cond
((lambda? x)
`(lambda ,(map (lambda (id) (get-rename id x renames)) (lambda-params x))
,@(map (lambda (d) `(define ,(identifier->symbol (cadar d)) #f))
(lambda-defs x))
,@(if (seq? (lambda-body x))
(map a2s (seq-ls (lambda-body x)))
(list (a2s (lambda-body x))))))
((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x))))
((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x))))
((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames))
((seq? x) `(begin ,@(map a2s (seq-ls x))))
((lit? x)
(let ((v (lit-value x)))
(if (or (pair? v) (null? v) (symbol? v)) `',v v)))
((pair? x) (cons (a2s (car x)) (a2s (cdr x))))
((opcode? x) (or (opcode-name x) x))
(else x)))))

7
lib/chibi/modules.module
View file

@ -1,5 +1,8 @@
(define-module (chibi modules)
(export analyze-module)
(import-immutable (scheme) (config) (chibi ast))
(export analyze-module module-ast module-ast-set!
module-ref module-contains? containing-module
procedure-analysis)
(import-immutable (scheme) (config))
(import (chibi ast))
(include "modules.scm"))

126
lib/chibi/modules.scm
View file

@ -8,57 +8,79 @@
(reverse res)
(lp (cons x res))))))))
;; load the module and return it with a list of all top-level forms in
;; the module analyzed
(define (module? x) (vector? x))
(define (module-ast mod) (vector-ref mod 3))
(define (module-ast-set! mod x) (vector-set! mod 3 x))
(define (analyze-module-source name mod recursive?)
(let ((env (module-env mod))
(dir (if (equal? name '(scheme)) "" (module-name-prefix name))))
(define (include-source file)
(cond ((find-module-file (string-append dir file))
=> (lambda (x) (cons 'body (file->sexp-list x))))
(else (error "couldn't find include" file))))
(let lp ((ls (module-meta-data mod)) (res '()))
(cond
((not (pair? ls))
(reverse res))
(else
(case (and (pair? (car ls)) (caar ls))
((import import-immutable)
(for-each
(lambda (m)
(let* ((mod2-name+imports (resolve-import m))
(mod2-name (car mod2-name+imports)))
(if recursive?
(analyze-module mod2-name #t))))
(cdar ls))
(lp (cdr ls) res))
((include)
(lp (append (map include-source (cdar ls)) (cdr ls)) res))
((body)
(let lp2 ((ls2 (cdar ls)) (res res))
(cond
((pair? ls2)
(lp2 (cdr ls2) (cons (analyze (car ls2) env) res)))
(else
(lp (cdr ls) res)))))
(else
(lp (cdr ls) res))))))))
(define (analyze-module name . o)
(let ((recursive? (and (pair? o) (car o)))
(modules `(((scheme) . ,(find-module '(scheme))))))
(let go ((name name))
(let ((env (make-environment))
(dir (module-name-prefix name)))
(define (load-modules files extension)
(for-each
(lambda (f)
(let ((f (string-append dir f extension)))
(cond ((find-module-file f) => (lambda (x) (load x env)))
(else (error "couldn't find include" f)))))
files))
(define (include-source file)
(cond ((find-module-file (string-append dir file))
=> (lambda (x) (cons 'body (file->sexp-list x))))
(else (error "couldn't find include" file))))
(cond
((assoc name modules) => cdr)
(else
(let ((mod (find-module name)))
(let lp ((ls (module-meta-data mod)) (res '()))
(cond
((not (pair? ls)) (reverse res))
(else
(case (and (pair? (car ls)) (caar ls))
((import import-immutable)
(for-each
(lambda (m)
(let* ((mod2-name+imports (resolve-import m))
(mod2 (load-module (car mod2-name+imports))))
(%env-copy! env (module-env mod2) (cdr mod2-name+imports)
(eq? (caar ls) 'import-immutable))))
(cdar ls))
(lp (cdr ls) res))
((include)
(lp (append (map include-source (cdar ls)) (cdr ls)) res))
((include-shared)
(cond-expand
(dynamic-loading
(load-modules (cdar ls) *shared-object-extension*))
(else #f)))
((body)
(let lp2 ((ls2 (cdar ls)) (res res))
(cond
((pair? ls2)
(eval (car ls2) env)
(lp2 (cdr ls2) (cons (analyze (car ls2)) res)))
(else
(lp (cdr ls) res)))))
(else
(lp (cdr ls) res)))))))))))))
(res (load-module name)))
(if (not (module-ast res))
(module-ast-set! res (analyze-module-source name res recursive?)))
res))
(define (module-ref mod var-name . o)
(let ((cell (env-cell (module-env (if (module? mod) mod (load-module mod)))
var-name)))
(if cell
(cdr cell)
(if (pair? o) (car o) (error "no binding in module" mod var-name)))))
(define (module-contains? mod var-name)
(and (env-cell (module-env (if (module? mod) mod (load-module mod))) var-name)
#t))
(define (containing-module x)
(let lp1 ((ls *modules*))
(and (pair? ls)
(let ((env (module-env (cdar ls))))
(let lp2 ((e-ls (env-exports env)))
(cond ((null? e-ls) (lp1 (cdr ls)))
((eq? x (cdr (env-cell env (car e-ls)))) (car ls))
(else (lp2 (cdr e-ls)))))))))
(define (procedure-analysis x)
(let ((mod (containing-module x)))
(and mod
(let lp ((ls (module-ast (analyze-module (car mod)))))
(and (pair? ls)
(if (and (set? (car ls))
(eq? (procedure-name x) (ref-name (set-var (car ls)))))
(set-value (car ls))
(lp (cdr ls))))))))

3
lib/chibi/repl.module
View file

@ -1,5 +1,6 @@
(define-module (chibi repl)
(export repl)
(import-immutable (scheme) (chibi process))
(import-immutable (scheme))
(import (chibi process))
(include "repl.scm"))

5
lib/config.scm
View file

@ -7,7 +7,7 @@
(define *this-module* '())
(define (make-module exports env meta) (vector exports env meta))
(define (make-module exports env meta) (vector exports env meta #f))
(define (%module-exports mod) (vector-ref mod 0))
(define (module-env mod) (vector-ref mod 1))
(define (module-meta-data mod) (vector-ref mod 2))
@ -167,7 +167,8 @@
(define-config-primitive body)
(define *modules*
(list (cons '(scheme) (make-module #f (interaction-environment) '()))
(list (cons '(scheme) (make-module #f (interaction-environment)
'((include "init.scm"))))
(cons '(config) (make-module #f (current-environment) '()))
(cons '(srfi 0) (make-module (list 'cond-expand)
(interaction-environment)

2
sexp.c
View file

@ -107,7 +107,7 @@ static struct sexp_type_struct _sexp_type_specs[] = {
_DEF_TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 3, 3, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode", NULL),
_DEF_TYPE(SEXP_CORE, 0, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form", NULL),
_DEF_TYPE(SEXP_OPCODE, sexp_offsetof(opcode, data), 3, 3, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode", NULL),
_DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 9, 9, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda", NULL),
_DEF_TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda", NULL),
_DEF_TYPE(SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, "conditional", NULL),
_DEF_TYPE(SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, "reference", NULL),
_DEF_TYPE(SEXP_SET, sexp_offsetof(set, var), 3, 3, 0, 0, sexp_sizeof(set), 0, 0, "set!", NULL),