mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +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); mx = SCM_MEMOIZED_ARGS (x);
switch (SCM_MEMOIZED_TAG (x)) switch (SCM_MEMOIZED_TAG (x))
{ {
case SCM_M_BEGIN: case SCM_M_SEQ:
for (; !scm_is_null (CDR (mx)); mx = CDR (mx)) eval (CAR (mx), env);
eval (CAR (mx), env); x = CDR (mx);
x = CAR (mx);
goto loop; goto loop;
case SCM_M_IF: 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) SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
#define CALL(src, proc, exps) \ #define CALL(src, proc, exps) \
SCM_MAKE_EXPANDED_CALL(src, proc, exps) SCM_MAKE_EXPANDED_CALL(src, proc, exps)
#define SEQUENCE(src, exps) \ #define SEQ(src, head, tail) \
SCM_MAKE_EXPANDED_SEQUENCE(src, exps) SCM_MAKE_EXPANDED_SEQ(src, head, tail)
#define LAMBDA(src, meta, body) \ #define LAMBDA(src, meta, body) \
SCM_MAKE_EXPANDED_LAMBDA(src, meta, body) SCM_MAKE_EXPANDED_LAMBDA(src, meta, body)
#define LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \ #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))) if (scm_is_null (CDR (forms)))
return expand (CAR (forms), env); return expand (CAR (forms), env);
else 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 (CONDITIONAL);
DEFINE_NAMES (CALL); DEFINE_NAMES (CALL);
DEFINE_NAMES (PRIMCALL); DEFINE_NAMES (PRIMCALL);
DEFINE_NAMES (SEQUENCE); DEFINE_NAMES (SEQ);
DEFINE_NAMES (LAMBDA); DEFINE_NAMES (LAMBDA);
DEFINE_NAMES (LAMBDA_CASE); DEFINE_NAMES (LAMBDA_CASE);
DEFINE_NAMES (LET); DEFINE_NAMES (LET);

19
libguile/expand.h
View file

@ -49,7 +49,7 @@ typedef enum
SCM_EXPANDED_CONDITIONAL, SCM_EXPANDED_CONDITIONAL,
SCM_EXPANDED_CALL, SCM_EXPANDED_CALL,
SCM_EXPANDED_PRIMCALL, SCM_EXPANDED_PRIMCALL,
SCM_EXPANDED_SEQUENCE, SCM_EXPANDED_SEQ,
SCM_EXPANDED_LAMBDA, SCM_EXPANDED_LAMBDA,
SCM_EXPANDED_LAMBDA_CASE, SCM_EXPANDED_LAMBDA_CASE,
SCM_EXPANDED_LET, SCM_EXPANDED_LET,
@ -255,17 +255,18 @@ enum
#define SCM_MAKE_EXPANDED_PRIMCALL(src, name, args) \ #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)) 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_SEQ_TYPE_NAME "seq"
#define SCM_EXPANDED_SEQUENCE_FIELD_NAMES \ #define SCM_EXPANDED_SEQ_FIELD_NAMES \
{ "src", "exps", } { "src", "head", "tail", }
enum enum
{ {
SCM_EXPANDED_SEQUENCE_SRC, SCM_EXPANDED_SEQ_SRC,
SCM_EXPANDED_SEQUENCE_EXPS, SCM_EXPANDED_SEQ_HEAD,
SCM_NUM_EXPANDED_SEQUENCE_FIELDS, SCM_EXPANDED_SEQ_TAIL,
SCM_NUM_EXPANDED_SEQ_FIELDS,
}; };
#define SCM_MAKE_EXPANDED_SEQUENCE(src, exps) \ #define SCM_MAKE_EXPANDED_SEQ(src, head, tail) \
scm_c_make_struct (exp_vtables[SCM_EXPANDED_SEQUENCE], 0, SCM_NUM_EXPANDED_SEQUENCE_FIELDS, SCM_UNPACK (src), SCM_UNPACK (exps)) 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_TYPE_NAME "lambda"
#define SCM_EXPANDED_LAMBDA_FIELD_NAMES \ #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) \ #define MAKMEMO(n, args) \
(scm_cell (scm_tc16_memoized | ((n) << 16), SCM_UNPACK (args))) (scm_cell (scm_tc16_memoized | ((n) << 16), SCM_UNPACK (args)))
#define MAKMEMO_BEGIN(exps) \ #define MAKMEMO_SEQ(head,tail) \
MAKMEMO (SCM_M_BEGIN, exps) MAKMEMO (SCM_M_SEQ, scm_cons (head, tail))
#define MAKMEMO_IF(test, then, else_) \ #define MAKMEMO_IF(test, then, else_) \
MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_))) MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
#define FIXED_ARITY(nreq) \ #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 */ /* This table must agree with the list of M_ constants in memoize.h */
static const char *const memoized_tags[] = static const char *const memoized_tags[] =
{ {
"begin", "seq",
"if", "if",
"lambda", "lambda",
"let", "let",
@ -277,8 +277,9 @@ memoize (SCM exp, SCM env)
return MAKMEMO_CALL (proc, scm_ilength (args), args); return MAKMEMO_CALL (proc, scm_ilength (args), args);
} }
case SCM_EXPANDED_SEQUENCE: case SCM_EXPANDED_SEQ:
return MAKMEMO_BEGIN (memoize_exps (REF (exp, SEQUENCE, EXPS), env)); return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
memoize (REF (exp, SEQ, TAIL), env));
case SCM_EXPANDED_LAMBDA: case SCM_EXPANDED_LAMBDA:
/* The body will be a lambda-case. */ /* The body will be a lambda-case. */
@ -408,18 +409,21 @@ memoize (SCM exp, SCM env)
if (in_order_p) if (in_order_p)
{ {
SCM body_exps = SCM_EOL; SCM body_exps = SCM_EOL, seq;
for (; scm_is_pair (exps); exps = CDR (exps), i--) for (; scm_is_pair (exps); exps = CDR (exps), i--)
body_exps = scm_cons (MAKMEMO_LEX_SET (i-1, body_exps = scm_cons (MAKMEMO_LEX_SET (i-1,
memoize (CAR (exps), new_env)), memoize (CAR (exps), new_env)),
body_exps); body_exps);
body_exps = scm_cons (memoize (body, new_env), body_exps);
body_exps = scm_reverse_x (body_exps, SCM_UNDEFINED); seq = memoize (body, new_env);
return MAKMEMO_LET (undefs, MAKMEMO_BEGIN (body_exps)); for (; scm_is_pair (body_exps); body_exps = CDR (body_exps))
seq = MAKMEMO_SEQ (CAR (body_exps), seq);
return MAKMEMO_LET (undefs, seq);
} }
else 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--) for (; scm_is_pair (exps); exps = CDR (exps), i--)
{ {
sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars, 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_cons (memoize (CAR (exps), new_env), inits);
} }
inits = scm_reverse_x (inits, SCM_UNDEFINED); inits = scm_reverse_x (inits, SCM_UNDEFINED);
return MAKMEMO_LET
(undefs, sets = scm_reverse_x (sets, SCM_UNDEFINED);
MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (inits, MAKMEMO_BEGIN (sets)), if (scm_is_null (sets))
memoize (body, new_env)))); 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: case SCM_M_APPLY:
return scm_cons (scm_sym_atapply, unmemoize_exprs (args)); return scm_cons (scm_sym_atapply, unmemoize_exprs (args));
case SCM_M_BEGIN: case SCM_M_SEQ:
return scm_cons (scm_sym_begin, unmemoize_exprs (args)); return scm_list_3 (scm_sym_begin, unmemoize (CAR (args)),
unmemoize (CDR (args)));
case SCM_M_CALL: case SCM_M_CALL:
return scm_cons (unmemoize (CAR (args)), unmemoize_exprs (CDDR (args))); return scm_cons (unmemoize (CAR (args)), unmemoize_exprs (CDDR (args)));
case SCM_M_CONT: case SCM_M_CONT:

4
libguile/memoize.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_MEMOIZE_H #ifndef SCM_MEMOIZE_H
#define 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. * Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * This library is free software; you can redistribute it and/or
@ -72,7 +72,7 @@ SCM_INTERNAL scm_t_bits scm_tc16_memoized;
enum enum
{ {
SCM_M_BEGIN, SCM_M_SEQ,
SCM_M_IF, SCM_M_IF,
SCM_M_LAMBDA, SCM_M_LAMBDA,
SCM_M_LET, SCM_M_LET,

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -1,6 +1,6 @@
;;; Tree Intermediate Language ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -33,7 +33,9 @@
(pmatch exps (pmatch exps
(() (make-void #f)) (() (make-void #f))
((,x) x) ((,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 (define-language tree-il
#:title "Tree Intermediate Language" #:title "Tree Intermediate Language"