mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-18 01:30:27 +02:00
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.
This commit is contained in:
Andy Wingo
parent
a881a4ae3b
commit
6fc3eae477
14 changed files with 194 additions and 172 deletions
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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}#
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue