dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

beginnings of letrec* support in the expander

Browse source 
* libguile/expand.h (SCM_EXPANDED_LETREC_IN_ORDER_P)
  (SCM_MAKE_EXPANDED_LETREC): Add a new field to letrec, in-order?. Will
  be used to support letrec*.

* libguile/expand.c (LETREC, expand_named_let, expand_letrec): Adapt
  code.

* module/language/elisp/compile-tree-il.scm (compile-pair):
* module/ice-9/psyntax.scm (build-named-let, build-letrec): Pass #f for
  in-order? to `make-letrec'.

* module/ice-9/psyntax-pp.scm: Regenerate.

* module/language/tree-il.scm: Add letrec-in-order? accessor.
  (parse-tree-il, unparse-tree-il): Parse and unparse an in-order?
  letrec as `letrec*'.
  (tree-il->scheme): Serialize letrec*.
This commit is contained in:
Andy Wingo 2010-06-17 10:49:00 +02:00
commit fb6e61ca21
6 changed files with 6810 additions and 6800 deletions
Download patch file Download diff file Expand all files Collapse all files

8
libguile/expand.c
View file

@ -81,8 +81,8 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
SCM_MAKE_EXPANDED_LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate)
#define LET(src, names, gensyms, vals, body) \
SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body)
#define LETREC(src, names, gensyms, vals, body) \
SCM_MAKE_EXPANDED_LETREC(src, names, gensyms, vals, body)
#define LETREC(src, in_order_p, names, gensyms, vals, body) \
SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body)
#define DYNLET(src, fluids, vals, body) \
SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body)
@ -984,7 +984,7 @@ expand_named_let (const SCM expr, SCM env)
inner_env = expand_env_extend (inner_env, var_names, var_syms);
return LETREC
(scm_source_properties (expr),
(scm_source_properties (expr), SCM_BOOL_F,
scm_list_1 (name), scm_list_1 (name_sym),
scm_list_1 (LAMBDA (SCM_BOOL_F,
SCM_EOL,
@ -1048,7 +1048,7 @@ expand_letrec (SCM expr, SCM env)
SCM var_names, var_syms, inits;
transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
env = expand_env_extend (env, var_names, var_syms);
return LETREC (SCM_BOOL_F,
return LETREC (SCM_BOOL_F, SCM_BOOL_F,
var_names, var_syms, expand_exprs (inits, env),
expand_sequence (CDDR (expr), env));
}

7
libguile/expand.h
View file

@ -301,18 +301,19 @@ enum
#define SCM_EXPANDED_LETREC_TYPE_NAME "letrec"
#define SCM_EXPANDED_LETREC_FIELD_NAMES \
{ "src", "names", "gensyms", "vals", "body", }
{ "src", "in-order?", "names", "gensyms", "vals", "body", }
enum
{
SCM_EXPANDED_LETREC_SRC,
SCM_EXPANDED_LETREC_IN_ORDER_P,
SCM_EXPANDED_LETREC_NAMES,
SCM_EXPANDED_LETREC_GENSYMS,
SCM_EXPANDED_LETREC_VALS,
SCM_EXPANDED_LETREC_BODY,
SCM_NUM_EXPANDED_LETREC_FIELDS,
};
#define SCM_MAKE_EXPANDED_LETREC(src, names, gensyms, vals, body) \
scm_c_make_struct (exp_vtables[SCM_EXPANDED_LETREC], 0, SCM_NUM_EXPANDED_LETREC_FIELDS, SCM_UNPACK (src), SCM_UNPACK (names), SCM_UNPACK (gensyms), SCM_UNPACK (vals), SCM_UNPACK (body))
#define SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body) \
scm_c_make_struct (exp_vtables[SCM_EXPANDED_LETREC], 0, SCM_NUM_EXPANDED_LETREC_FIELDS, SCM_UNPACK (src), SCM_UNPACK (in_order_p), SCM_UNPACK (names), SCM_UNPACK (gensyms), SCM_UNPACK (vals), SCM_UNPACK (body))
#define SCM_EXPANDED_DYNLET_TYPE_NAME "dynlet"
#define SCM_EXPANDED_DYNLET_FIELD_NAMES \

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

File diff suppressed because it is too large Load diff

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

@ -520,7 +520,7 @@
(maybe-name-value! f-name proc)
(for-each maybe-name-value! ids val-exps)
(make-letrec
src
src #f
(list f-name) (list f) (list proc)
(build-application src (build-lexical-reference 'fun src f-name f)
val-exps))))))
@ -531,7 +531,7 @@
body-exp
(begin
(for-each maybe-name-value! ids val-exps)
(make-letrec src ids vars val-exps body-exp)))))
(make-letrec src #f ids vars val-exps body-exp)))))
;; FIXME: use a faster gensym

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

@ -770,7 +770,7 @@
(iter-thunk (make-lambda loc '()
(make-lambda-case #f '() #f #f #f '() '()
lambda-body #f))))
(make-letrec loc '(iterate) (list itersym) (list iter-thunk)
(make-letrec loc #f '(iterate) (list itersym) (list iter-thunk)
iter-call)))
; Either (lambda ...) or (function (lambda ...)) denotes a lambda-expression

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

@ -42,7 +42,7 @@
lambda-case-inits lambda-case-gensyms
lambda-case-body lambda-case-alternate
<let> let? make-let let-src let-names let-gensyms let-vals let-body
<letrec> letrec? make-letrec letrec-src letrec-names letrec-gensyms letrec-vals letrec-body
<letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
<let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
<dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
@ -123,7 +123,7 @@
;; (<lambda> meta body)
;; (<lambda-case> req opt rest kw inits gensyms body alternate)
;; (<let> names gensyms vals body)
;; (<letrec> names gensyms vals body)
;; (<letrec> in-order? names gensyms vals body)
;; (<dynlet> fluids vals body)
(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
@ -216,7 +216,10 @@
(make-let loc names gensyms (map retrans vals) (retrans body)))
((letrec ,names ,gensyms ,vals ,body)
(make-letrec loc names gensyms (map retrans vals) (retrans body)))
(make-letrec loc #f names gensyms (map retrans vals) (retrans body)))
((letrec* ,names ,gensyms ,vals ,body)
(make-letrec loc #t names gensyms (map retrans vals) (retrans body)))
((fix ,names ,gensyms ,vals ,body)
(make-fix loc names gensyms (map retrans vals) (retrans body)))
@ -297,8 +300,9 @@
((<let> names gensyms vals body)
`(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
((<letrec> names gensyms vals body)
`(letrec ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
((<letrec> in-order? names gensyms vals body)
`(,(if in-order? 'letrec* 'letrec) ,names ,gensyms
,(map unparse-tree-il vals) ,(unparse-tree-il body)))
((<fix> names gensyms vals body)
`(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
@ -435,8 +439,9 @@
((<let> gensyms vals body)
`(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
((<letrec> gensyms vals body)
`(letrec ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
((<letrec> in-order? gensyms vals body)
`(,(if in-order? 'letrec* 'letrec)
,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
((<fix> gensyms vals body)
;; not a typo, we really do translate back to letrec