mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

sequence of expressions -> seq of head and tail

Browse source 
* libguile/expand.h:
* module/language/tree-il.scm: Rename "sequence" to "seq", and instead
  of taking a list of expressions, take a head and a tail.

* module/language/tree-il/analyze.scm:
* module/language/tree-il/compile-glil.scm:
* module/language/tree-il/fix-letrec.scm:
* module/language/tree-il/spec.scm:
* module/language/elisp/compile-tree-il.scm:
* module/ice-9/psyntax.scm:
* module/ice-9/psyntax-pp.scm:
* module/ice-9/eval.scm:
* libguile/memoize.h:
* libguile/memoize.c:
* libguile/expand.c:
* libguile/eval.c: Adapt to the new seq format.
This commit is contained in:
Andy Wingo 2011-06-02 19:13:32 +02:00
parent a881a4ae3b
commit 6fc3eae477
14 changed files with 194 additions and 172 deletions
Download patch file Download diff file Expand all files Collapse all files

7
libguile/eval.c
View file

@ -229,10 +229,9 @@ eval (SCM x, SCM env)
mx = SCM_MEMOIZED_ARGS (x);
switch (SCM_MEMOIZED_TAG (x))
{
case SCM_M_BEGIN:
for (; !scm_is_null (CDR (mx)); mx = CDR (mx))
eval (CAR (mx), env);
x = CAR (mx);
case SCM_M_SEQ:
eval (CAR (mx), env);
x = CDR (mx);
goto loop;
case SCM_M_IF:

10
libguile/expand.c
View file

@ -73,8 +73,8 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
#define CALL(src, proc, exps) \
SCM_MAKE_EXPANDED_CALL(src, proc, exps)
#define SEQUENCE(src, exps) \
SCM_MAKE_EXPANDED_SEQUENCE(src, exps)
#define SEQ(src, head, tail) \
SCM_MAKE_EXPANDED_SEQ(src, head, tail)
#define LAMBDA(src, meta, body) \
SCM_MAKE_EXPANDED_LAMBDA(src, meta, body)
#define LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \
@ -396,7 +396,9 @@ expand_sequence (const SCM forms, const SCM env)
if (scm_is_null (CDR (forms)))
return expand (CAR (forms), env);
else
return SEQUENCE (SCM_BOOL_F, expand_exprs (forms, env));
return SEQ (scm_source_properties (forms),
expand (CAR (forms), env),
expand_sequence (CDR (forms), env));
}
@ -1245,7 +1247,7 @@ scm_init_expand ()
DEFINE_NAMES (CONDITIONAL);
DEFINE_NAMES (CALL);
DEFINE_NAMES (PRIMCALL);
DEFINE_NAMES (SEQUENCE);
DEFINE_NAMES (SEQ);
DEFINE_NAMES (LAMBDA);
DEFINE_NAMES (LAMBDA_CASE);
DEFINE_NAMES (LET);

19
libguile/expand.h
View file

@ -49,7 +49,7 @@ typedef enum
SCM_EXPANDED_CONDITIONAL,
SCM_EXPANDED_CALL,
SCM_EXPANDED_PRIMCALL,
SCM_EXPANDED_SEQUENCE,
SCM_EXPANDED_SEQ,
SCM_EXPANDED_LAMBDA,
SCM_EXPANDED_LAMBDA_CASE,
SCM_EXPANDED_LET,
@ -255,17 +255,18 @@ enum
#define SCM_MAKE_EXPANDED_PRIMCALL(src, name, args) \
scm_c_make_struct (exp_vtables[SCM_EXPANDED_PRIMCALL], 0, SCM_NUM_EXPANDED_PRIMCALL_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name), SCM_UNPACK (args))
#define SCM_EXPANDED_SEQUENCE_TYPE_NAME "sequence"
#define SCM_EXPANDED_SEQUENCE_FIELD_NAMES \
{ "src", "exps", }
#define SCM_EXPANDED_SEQ_TYPE_NAME "seq"
#define SCM_EXPANDED_SEQ_FIELD_NAMES \
{ "src", "head", "tail", }
enum
{
SCM_EXPANDED_SEQUENCE_SRC,
SCM_EXPANDED_SEQUENCE_EXPS,
SCM_NUM_EXPANDED_SEQUENCE_FIELDS,
SCM_EXPANDED_SEQ_SRC,
SCM_EXPANDED_SEQ_HEAD,
SCM_EXPANDED_SEQ_TAIL,
SCM_NUM_EXPANDED_SEQ_FIELDS,
};
#define SCM_MAKE_EXPANDED_SEQUENCE(src, exps) \
scm_c_make_struct (exp_vtables[SCM_EXPANDED_SEQUENCE], 0, SCM_NUM_EXPANDED_SEQUENCE_FIELDS, SCM_UNPACK (src), SCM_UNPACK (exps))
#define SCM_MAKE_EXPANDED_SEQ(src, head, tail) \
scm_c_make_struct (exp_vtables[SCM_EXPANDED_SEQ], 0, SCM_NUM_EXPANDED_SEQ_FIELDS, SCM_UNPACK (src), SCM_UNPACK (head), SCM_UNPACK (tail))
#define SCM_EXPANDED_LAMBDA_TYPE_NAME "lambda"
#define SCM_EXPANDED_LAMBDA_FIELD_NAMES \

45
libguile/memoize.c
View file

@ -67,8 +67,8 @@ scm_t_bits scm_tc16_memoized;
#define MAKMEMO(n, args) \
(scm_cell (scm_tc16_memoized | ((n) << 16), SCM_UNPACK (args)))
#define MAKMEMO_BEGIN(exps) \
MAKMEMO (SCM_M_BEGIN, exps)
#define MAKMEMO_SEQ(head,tail) \
MAKMEMO (SCM_M_SEQ, scm_cons (head, tail))
#define MAKMEMO_IF(test, then, else_) \
MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
#define FIXED_ARITY(nreq) \
@ -124,7 +124,7 @@ scm_t_bits scm_tc16_memoizer;
/* This table must agree with the list of M_ constants in memoize.h */
static const char *const memoized_tags[] =
{
"begin",
"seq",
"if",
"lambda",
"let",
@ -277,8 +277,9 @@ memoize (SCM exp, SCM env)
return MAKMEMO_CALL (proc, scm_ilength (args), args);
}
case SCM_EXPANDED_SEQUENCE:
return MAKMEMO_BEGIN (memoize_exps (REF (exp, SEQUENCE, EXPS), env));
case SCM_EXPANDED_SEQ:
return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
memoize (REF (exp, SEQ, TAIL), env));
case SCM_EXPANDED_LAMBDA:
/* The body will be a lambda-case. */
@ -408,18 +409,21 @@ memoize (SCM exp, SCM env)
if (in_order_p)
{
SCM body_exps = SCM_EOL;
SCM body_exps = SCM_EOL, seq;
for (; scm_is_pair (exps); exps = CDR (exps), i--)
body_exps = scm_cons (MAKMEMO_LEX_SET (i-1,
memoize (CAR (exps), new_env)),
body_exps);
body_exps = scm_cons (memoize (body, new_env), body_exps);
body_exps = scm_reverse_x (body_exps, SCM_UNDEFINED);
return MAKMEMO_LET (undefs, MAKMEMO_BEGIN (body_exps));
seq = memoize (body, new_env);
for (; scm_is_pair (body_exps); body_exps = CDR (body_exps))
seq = MAKMEMO_SEQ (CAR (body_exps), seq);
return MAKMEMO_LET (undefs, seq);
}
else
{
SCM sets = SCM_EOL, inits = SCM_EOL;
SCM sets = SCM_EOL, inits = SCM_EOL, set_seq;
for (; scm_is_pair (exps); exps = CDR (exps), i--)
{
sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
@ -428,10 +432,18 @@ memoize (SCM exp, SCM env)
inits = scm_cons (memoize (CAR (exps), new_env), inits);
}
inits = scm_reverse_x (inits, SCM_UNDEFINED);
return MAKMEMO_LET
(undefs,
MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (inits, MAKMEMO_BEGIN (sets)),
memoize (body, new_env))));
sets = scm_reverse_x (sets, SCM_UNDEFINED);
if (scm_is_null (sets))
return memoize (body, env);
for (set_seq = CAR (sets), sets = CDR (sets); scm_is_pair (sets);
sets = CDR (sets))
set_seq = MAKMEMO_SEQ (CAR (sets), set_seq);
return MAKMEMO_LET (undefs,
MAKMEMO_SEQ (MAKMEMO_LET (inits, set_seq),
memoize (body, new_env)));
}
}
@ -622,8 +634,9 @@ unmemoize (const SCM expr)
{
case SCM_M_APPLY:
return scm_cons (scm_sym_atapply, unmemoize_exprs (args));
case SCM_M_BEGIN:
return scm_cons (scm_sym_begin, unmemoize_exprs (args));
case SCM_M_SEQ:
return scm_list_3 (scm_sym_begin, unmemoize (CAR (args)),
unmemoize (CDR (args)));
case SCM_M_CALL:
return scm_cons (unmemoize (CAR (args)), unmemoize_exprs (CDDR (args)));
case SCM_M_CONT:

4
libguile/memoize.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_MEMOIZE_H
#define SCM_MEMOIZE_H
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@ -72,7 +72,7 @@ SCM_INTERNAL scm_t_bits scm_tc16_memoized;
enum
{
SCM_M_BEGIN,
SCM_M_SEQ,
SCM_M_IF,
SCM_M_LAMBDA,
SCM_M_LET,

15
module/ice-9/eval.scm
View file

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;; Copyright (C) 2009, 2010
;;;; Copyright (C) 2009, 2010, 2011
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
@ -381,14 +381,11 @@
0 #f '() #f)
(apply make-general-closure (capture-env env) body nreq tail))))
(('begin (first . rest))
(let lp ((first first) (rest rest))
(if (null? rest)
(eval first env)
(begin
(eval first env)
(lp (car rest) (cdr rest))))))
(('seq (head . tail))
(begin
(eval head env)
(eval tail env)))
(('lexical-set! (n . x))
(let ((val (eval x env)))
(list-set! env n val)))

8
module/ice-9/psyntax-pp.scm
View file

@ -107,11 +107,11 @@
#{name 838}#
#{args 839}#)))
(#{make-sequence 229}#
(lambda (#{src 843}# #{exps 844}#)
(lambda (#{src 843}# head tail)
(make-struct/no-tail
(vector-ref %expanded-vtables 13)
#{src 843}#
#{exps 844}#)))
head tail)))
(#{make-lambda 231}#
(lambda (#{src 847}# #{meta 848}# #{body 849}#)
(make-struct/no-tail
@ -445,8 +445,8 @@
(if (null? (cdr #{exps 1099}#))
(car #{exps 1099}#)
(#{make-sequence 229}#
#{src 1098}#
#{exps 1099}#))))
#f (car #{exps 1099}#)
(#{build-sequence 297}# #f (cdr #{exps 1099}#))))))
(#{build-let 299}#
(lambda (#{src 1102}#
#{ids 1103}#

2
module/ice-9/psyntax.scm
View file

@ -417,7 +417,7 @@
(lambda (src exps)
(if (null? (cdr exps))
(car exps)
(make-sequence src exps))))
(make-seq src (car exps) (build-sequence #f (cdr exps))))))
(define build-let
(lambda (src ids vars val-exps body-exp)

151
module/language/elisp/compile-tree-il.scm
View file

@ -134,7 +134,7 @@
(make-const loc sym))))
(define (ensuring-globals loc bindings body)
(make-sequence
(list->seq
loc
`(,@(map-globals-needed (fluid-ref bindings)
(lambda (mod sym)
@ -286,7 +286,7 @@
(map (lambda (el) (compile-expr (cdr el)))
for)))
(make-body (lambda ()
(make-sequence loc (map compile-expr body)))))
(list->seq loc (map compile-expr body)))))
(if (null? lexical)
(let-dynamic loc (map car dynamic) module
(make-values dynamic) (make-body))
@ -330,7 +330,7 @@
(map car bind))
(let iterate ((tail bind))
(if (null? tail)
(make-sequence loc (map compile-expr body))
(list->seq loc (map compile-expr body))
(let ((sym (caar tail))
(value (compile-expr (cdar tail))))
(if (bind-lexically? sym module)
@ -500,36 +500,35 @@
(map (lambda (x) (nil-value loc)) optional)
all-syms
(let ((compiled-body
(make-sequence loc (map compile-expr body))))
(make-sequence
(list->seq loc (map compile-expr body))))
(make-seq
loc
(list
(if rest
(make-conditional
loc
(call-primitive loc
'null?
(make-lexical-ref loc
rest
the-rest-sym))
(make-lexical-set loc
rest
the-rest-sym
(nil-value loc))
(make-void loc))
(if rest
(make-conditional
loc
(call-primitive loc
'null?
(make-lexical-ref loc
rest
the-rest-sym))
(make-lexical-set loc
rest
the-rest-sym
(nil-value loc))
(make-void loc))
(if (null? dynamic)
compiled-body
(let-dynamic loc
dynamic
value-slot
(map (lambda (name-sym)
(make-lexical-ref
loc
(car name-sym)
(cdr name-sym)))
all-dyn-pairs)
compiled-body)))))
(make-void loc))
(if (null? dynamic)
compiled-body
(let-dynamic loc
dynamic
value-slot
(map (lambda (name-sym)
(make-lexical-ref
loc
(car name-sym)
(cdr name-sym)))
all-dyn-pairs)
compiled-body))))
#f)))))))))
;;; Handle the common part of defconst and defvar, that is, checking for
@ -621,7 +620,7 @@
(report-error loc "invalid symbol list" syms))
(let ((old (fluid-ref fluid))
(make-body (lambda ()
(make-sequence loc (map compile-expr body)))))
(list->seq loc (map compile-expr body)))))
(if (eq? old 'all)
(make-body)
(let ((new (if (eq? syms 'all)
@ -633,7 +632,7 @@
;;; Special operators
(defspecial progn (loc args)
(make-sequence loc (map compile-expr args)))
(list->seq loc (map compile-expr args)))
(defspecial if (loc args)
(pmatch args
@ -643,53 +642,51 @@
(compile-expr then)
(if (null? else)
(nil-value loc)
(make-sequence loc
(map compile-expr else)))))))
(list->seq loc (map compile-expr else)))))))
(defspecial defconst (loc args)
(pmatch args
((,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
(make-sequence loc
(list (set-variable! loc
sym
value-slot
(compile-expr value))
(make-const loc sym)))))))
(make-seq loc
(set-variable! loc
sym
value-slot
(compile-expr value))
(make-const loc sym))))))
(defspecial defvar (loc args)
(pmatch args
((,sym) (make-const loc sym))
((,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
(make-sequence
(make-seq
loc
(list
(make-conditional
loc
(make-conditional
loc
(make-conditional
(call-primitive
loc
(call-primitive
loc
'module-bound?
(call-primitive loc
'resolve-interface
(make-const loc value-slot))
(make-const loc sym))
'module-bound?
(call-primitive loc
'fluid-bound?
(make-module-ref loc value-slot sym #t))
(make-const loc #f))
(make-void loc)
(set-variable! loc sym value-slot (compile-expr value)))
(make-const loc sym)))))))
'resolve-interface
(make-const loc value-slot))
(make-const loc sym))
(call-primitive loc
'fluid-bound?
(make-module-ref loc value-slot sym #t))
(make-const loc #f))
(make-void loc)
(set-variable! loc sym value-slot (compile-expr value)))
(make-const loc sym))))))
(defspecial setq (loc args)
(define (car* x) (if (null? x) '() (car x)))
(define (cdr* x) (if (null? x) '() (cdr x)))
(define (cadr* x) (car* (cdr* x)))
(define (cddr* x) (cdr* (cdr* x)))
(make-sequence
(list->seq
loc
(let loop ((args args) (last (nil-value loc)))
(if (null? args)
@ -782,8 +779,7 @@
'iterate
itersym)
(list)))
(full-body (make-sequence loc
`(,@compiled-body ,iter-call)))
(full-body (list->seq loc `(,@compiled-body ,iter-call)))
(lambda-body (make-conditional loc
(compile-expr condition)
full-body
@ -819,17 +815,16 @@
(if (not (symbol? name))
(report-error loc "expected symbol as macro name" name)
(let* ((tree-il
(make-sequence
(make-seq
loc
(list
(set-variable!
loc
name
function-slot
(make-primcall loc 'cons
(list (make-const loc 'macro)
(compile-lambda loc args body))))
(make-const loc name)))))
(set-variable!
loc
name
function-slot
(make-primcall loc 'cons
(list (make-const loc 'macro)
(compile-lambda loc args body))))
(make-const loc name))))
(compile (ensuring-globals loc bindings-data tree-il)
#:from 'tree-il
#:to 'value)
@ -840,14 +835,14 @@
((,name ,args . ,body)
(if (not (symbol? name))
(report-error loc "expected symbol as function name" name)
(make-sequence loc
(list (set-variable! loc
name
function-slot
(compile-lambda loc
args
body))
(make-const loc name)))))))
(make-seq loc
(set-variable! loc
name
function-slot
(compile-lambda loc
args
body))
(make-const loc name))))))
(defspecial #{`}# (loc args)
(pmatch args

58
module/language/tree-il.scm
View file

@ -36,7 +36,7 @@
<conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate
<call> call? make-call call-src call-proc call-args
<primcall> primcall? make-primcall primcall-src primcall-name primcall-args
<sequence> sequence? make-sequence sequence-src sequence-exps
<seq> seq? make-seq seq-head seq-tail
<lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
<lambda-case> lambda-case? make-lambda-case lambda-case-src
lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw
@ -53,6 +53,8 @@
<prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
<abort> abort? make-abort abort-src abort-tag abort-args abort-tail
list->seq
parse-tree-il
unparse-tree-il
tree-il->scheme
@ -121,7 +123,7 @@
;; (<conditional> test consequent alternate)
;; (<call> proc args)
;; (<primcall> name args)
;; (<sequence> exps)
;; (<seq> head tail)
;; (<lambda> meta body)
;; (<lambda-case> req opt rest kw inits gensyms body alternate)
;; (<let> names gensyms vals body)
@ -139,6 +141,14 @@
;; A helper.
(define (list->seq loc exps)
(if (null? (cdr exps))
(car exps)
(make-seq loc (car exps) (list->seq #f (cdr exps)))))
(define (location x)
(and (pair? x)
(let ((props (source-properties x)))
@ -214,8 +224,12 @@
((const ,exp)
(make-const loc exp))
((seq ,head ,tail)
(make-seq loc (retrans head) (retrans tail)))
;; Convenience.
((begin . ,exps)
(make-sequence loc (map retrans exps)))
(list->seq loc (map retrans exps)))
((let ,names ,gensyms ,vals ,body)
(make-let loc names gensyms (map retrans vals) (retrans body)))
@ -302,9 +316,9 @@
((<const> exp)
`(const ,exp))
((<sequence> exps)
`(begin ,@(map unparse-tree-il exps)))
((<seq> head tail)
`(seq ,(unparse-tree-il head) ,(unparse-tree-il tail)))
((<let> names gensyms vals body)
`(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
@ -444,8 +458,13 @@
exp
(list 'quote exp)))
((<sequence> exps)
`(begin ,@(map tree-il->scheme exps)))
((<seq> head tail)
`(begin ,(tree-il->scheme head)
,@(unfold (lambda (x) (not (seq? x)))
(lambda (x) (tree-il->scheme (seq-head x)))
seq-tail
tail
tree-il->scheme)))
((<let> gensyms vals body)
`(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
@ -523,8 +542,8 @@ This is an implementation of `foldts' as described by Andy Wingo in
(up tree (loop (cons proc args) (down tree result))))
((<primcall> name args)
(up tree (loop args (down tree result))))
((<sequence> exps)
(up tree (loop exps (down tree result))))
((<seq> head tail)
(up tree (loop tail (loop head (down tree result)))))
((<lambda> body)
(up tree (loop body (down tree result))))
((<lambda-case> inits body alternate)
@ -599,8 +618,9 @@ This is an implementation of `foldts' as described by Andy Wingo in
(fold-values foldts args seed ...)))
((<primcall> name args)
(fold-values foldts args seed ...))
((<sequence> exps)
(fold-values foldts exps seed ...))
((<seq> head tail)
(let-values (((seed ...) (foldts head seed ...)))
(foldts tail seed ...)))
((<lambda> body)
(foldts body seed ...))
((<lambda-case> inits body alternate)
@ -682,9 +702,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
(if alternate
(set! (lambda-case-alternate x) (lp alternate))))
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
((<seq> head tail)
(set! (seq-head x) (lp head))
(set! (seq-tail x) (lp tail)))
((<let> gensyms vals body)
(set! (let-vals x) (map lp vals))
(set! (let-body x) (lp body)))
@ -768,9 +789,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (lambda-case-body x) (lp body))
(if alternate (set! (lambda-case-alternate x) (lp alternate))))
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
((<seq> head tail)
(set! (seq-head x) (lp head))
(set! (seq-tail x) (lp tail)))
((<let> vals body)
(set! (let-vals x) (map lp vals))
(set! (let-body x) (lp body)))

14
module/language/tree-il/analyze.scm
View file

@ -223,13 +223,8 @@
((<toplevel-define> exp)
(step exp))
((<sequence> exps)
(let lp ((exps exps) (ret '()))
(cond ((null? exps) '())
((null? (cdr exps))
(lset-union eq? ret (step-tail (car exps))))
(else
(lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
((<seq> head tail)
(lset-union eq? (step head) (step-tail tail)))
((<lambda> body)
;; order is important here
@ -388,8 +383,9 @@
((<toplevel-define> exp)
(recur exp))
((<sequence> exps)
(apply max (map recur exps)))
((<seq> head tail)
(max (recur head)
(recur tail)))
((<lambda> body)
;; allocate closure vars in order

13
module/language/tree-il/compile-glil.scm
View file

@ -246,15 +246,10 @@
(emit-code src (make-glil-const exp))))
(maybe-emit-return))
;; FIXME: should represent sequence as exps tail
((<sequence> exps)
(let lp ((exps exps))
(if (null? (cdr exps))
(comp-tail (car exps))
(begin
(comp-drop (car exps))
(lp (cdr exps))))))
((<seq> head tail)
(comp-drop head)
(comp-tail tail))
((<call> src proc args)
(cond
;; self-call in tail position

14
module/language/tree-il/fix-letrec.scm
View file

@ -41,9 +41,9 @@
(and (simple-expression? test bound-vars simple-primitive?)
(simple-expression? consequent bound-vars simple-primitive?)
(simple-expression? alternate bound-vars simple-primitive?)))
((<sequence> exps)
(and-map (lambda (x) (simple-expression? x bound-vars simple-primitive?))
exps))
((<seq> head tail)
(and (simple-expression? head bound-vars simple-primitive?)
(simple-expression? tail bound-vars simple-primitive?)))
((<primcall> name args)
(and (simple-primitive? name)
;; FIXME: check arity?
@ -190,7 +190,7 @@
;; expression, called for effect.
((<lexical-set> gensym exp)
(if (memq gensym unref)
(make-sequence #f (list exp (make-void #f)))
(make-seq #f exp (make-void #f))
x))
((<letrec> src in-order? names gensyms vals body)
@ -218,7 +218,7 @@
;; Bind lambdas using the fixpoint operator.
(make-fix
src (map cadr l) (map car l) (map caddr l)
(make-sequence
(list->seq
src
(append
;; The right-hand-sides of the unreferenced
@ -245,7 +245,7 @@
(let ((tmps (map (lambda (x) (gensym)) c)))
(make-let
#f (map cadr c) tmps (map caddr c)
(make-sequence
(list->seq
#f
(map (lambda (x tmp)
(make-lexical-set
@ -262,7 +262,7 @@
(let ((u (lookup unref))
(l (lookup lambda*))
(c (lookup complex)))
(make-sequence
(list->seq
src
(append
;; unreferenced bindings, called for effect.

6
module/language/tree-il/spec.scm
View file

@ -1,6 +1,6 @@
;;; Tree Intermediate Language
;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -33,7 +33,9 @@
(pmatch exps
(() (make-void #f))
((,x) x)
(else (make-sequence #f exps))))
((,x . ,rest)
(make-seq #f x (join rest env)))
(else (error "what!" x rest env))))
(define-language tree-il
#:title "Tree Intermediate Language"