summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-06-02 19:13:32 +0200
committerAndy Wingo <wingo@pobox.com>2011-06-02 19:13:32 +0200
commit6fc3eae4772bc2c5dc3e2b377ca481eef9aa52f5 (patch)
tree898c7e79ed0e5045692e619eda2a6e6a840462b0
parenta881a4ae3bc1f2cc00ac7274e286271b6f55287c (diff)
downloadguile-6fc3eae4772bc2c5dc3e2b377ca481eef9aa52f5.tar.gz
sequence of expressions -> seq of head and tail
* 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.
-rw-r--r--libguile/eval.c7
-rw-r--r--libguile/expand.c10
-rw-r--r--libguile/expand.h19
-rw-r--r--libguile/memoize.c45
-rw-r--r--libguile/memoize.h4
-rw-r--r--module/ice-9/eval.scm15
-rw-r--r--module/ice-9/psyntax-pp.scm8
-rw-r--r--module/ice-9/psyntax.scm2
-rw-r--r--module/language/elisp/compile-tree-il.scm151
-rw-r--r--module/language/tree-il.scm58
-rw-r--r--module/language/tree-il/analyze.scm14
-rw-r--r--module/language/tree-il/compile-glil.scm13
-rw-r--r--module/language/tree-il/fix-letrec.scm14
-rw-r--r--module/language/tree-il/spec.scm6
14 files changed, 194 insertions, 172 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index e008b3a08..e1d03484d 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -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:
diff --git a/libguile/expand.c b/libguile/expand.c
index af6eb7d12..78dd4cac4 100644
--- a/libguile/expand.c
+++ b/libguile/expand.c
@@ -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);
diff --git a/libguile/expand.h b/libguile/expand.h
index b4e6a2132..f5e7af5d4 100644
--- a/libguile/expand.h
+++ b/libguile/expand.h
@@ -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 \
diff --git a/libguile/memoize.c b/libguile/memoize.c
index d1537f9fb..801088ccb 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -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:
diff --git a/libguile/memoize.h b/libguile/memoize.h
index 26bd5b1c1..da78b06fa 100644
--- a/libguile/memoize.h
+++ b/libguile/memoize.h
@@ -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,
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 30a373a7a..e938061a3 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -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)))
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index c235d925e..9270a6947 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -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}#
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 85fda9ace..ae9c273ae 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -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)
diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm
index 9a5d74f1d..e1d75ba7a 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -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
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index a8169aa4c..ec3c50263 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -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)))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 3f2c10e67..9e5c685a5 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -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
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index ac164be8e..2cb0806d9 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -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
diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm
index cafc5d70b..2a18342d3 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -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.
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index 38e6d311c..1c6611b4e 100644
--- a/module/language/tree-il/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -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"