diff options
author | Andy Wingo <wingo@pobox.com> | 2011-06-02 19:13:32 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-06-02 19:13:32 +0200 |
commit | 6fc3eae4772bc2c5dc3e2b377ca481eef9aa52f5 (patch) | |
tree | 898c7e79ed0e5045692e619eda2a6e6a840462b0 | |
parent | a881a4ae3bc1f2cc00ac7274e286271b6f55287c (diff) | |
download | guile-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.c | 7 | ||||
-rw-r--r-- | libguile/expand.c | 10 | ||||
-rw-r--r-- | libguile/expand.h | 19 | ||||
-rw-r--r-- | libguile/memoize.c | 45 | ||||
-rw-r--r-- | libguile/memoize.h | 4 | ||||
-rw-r--r-- | module/ice-9/eval.scm | 15 | ||||
-rw-r--r-- | module/ice-9/psyntax-pp.scm | 8 | ||||
-rw-r--r-- | module/ice-9/psyntax.scm | 2 | ||||
-rw-r--r-- | module/language/elisp/compile-tree-il.scm | 151 | ||||
-rw-r--r-- | module/language/tree-il.scm | 58 | ||||
-rw-r--r-- | module/language/tree-il/analyze.scm | 14 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 13 | ||||
-rw-r--r-- | module/language/tree-il/fix-letrec.scm | 14 | ||||
-rw-r--r-- | module/language/tree-il/spec.scm | 6 |
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" |